You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

261 lines
9.6 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2010, 2011, 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
  3. ;;;
  4. ;;; This file is part of GNU Guix.
  5. ;;;
  6. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 3 of the License, or (at
  9. ;;; your option) any later version.
  10. ;;;
  11. ;;; GNU Guix is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  14. ;;; GNU General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (guix ftp-client)
  19. #:use-module (srfi srfi-1)
  20. #:use-module (srfi srfi-9)
  21. #:use-module (srfi srfi-11)
  22. #:use-module (srfi srfi-26)
  23. #:use-module (srfi srfi-31)
  24. #:use-module (rnrs io ports)
  25. #:use-module (rnrs bytevectors)
  26. #:use-module (ice-9 match)
  27. #:use-module (ice-9 regex)
  28. #:use-module (ice-9 rdelim)
  29. #:export (ftp-connection?
  30. ftp-connection-addrinfo
  31. ftp-open
  32. ftp-close
  33. ftp-chdir
  34. ftp-size
  35. ftp-list
  36. ftp-retr))
  37. ;;; Commentary:
  38. ;;;
  39. ;;; Simple FTP client (RFC 959).
  40. ;;;
  41. ;;; Code:
  42. ;; TODO: Use SRFI-3{4,5} error conditions.
  43. (define-record-type <ftp-connection>
  44. (%make-ftp-connection socket addrinfo)
  45. ftp-connection?
  46. (socket ftp-connection-socket)
  47. (addrinfo ftp-connection-addrinfo))
  48. (define %ftp-ready-rx
  49. (make-regexp "^([0-9]{3}) (.+)$"))
  50. (define (%ftp-listen port)
  51. (let loop ((line (read-line port)))
  52. (cond ((eof-object? line) (values line #f))
  53. ((regexp-exec %ftp-ready-rx line)
  54. =>
  55. (lambda (match)
  56. (values (string->number (match:substring match 1))
  57. (match:substring match 2))))
  58. (else
  59. (loop (read-line port))))))
  60. (define (%ftp-command command expected-code port)
  61. (format port "~A~A~A" command (string #\return) (string #\newline))
  62. (let-values (((code message) (%ftp-listen port)))
  63. (if (eqv? code expected-code)
  64. message
  65. (throw 'ftp-error port command code message))))
  66. (define (%ftp-login user pass port)
  67. (let ((command (string-append "USER " user
  68. (string #\return) (string #\newline))))
  69. (display command port)
  70. (let-values (((code message) (%ftp-listen port)))
  71. (case code
  72. ((230) #t)
  73. ((331) (%ftp-command (string-append "PASS " pass) 230 port))
  74. (else (throw 'ftp-error port command code message))))))
  75. (define* (ftp-open host #:optional (port 21))
  76. "Open an FTP connection to HOST on PORT (a service-identifying string,
  77. or a TCP port number), and return it."
  78. ;; Use 21 as the default PORT instead of "ftp", to avoid depending on
  79. ;; libc's NSS, which is not available during bootstrap.
  80. (define addresses
  81. (getaddrinfo host
  82. (if (number? port) (number->string port) port)
  83. (if (number? port) AI_NUMERICSERV 0)))
  84. (let loop ((addresses addresses))
  85. (let* ((ai (car addresses))
  86. (s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
  87. (addrinfo:protocol ai))))
  88. (catch 'system-error
  89. (lambda ()
  90. (connect s (addrinfo:addr ai))
  91. (setvbuf s _IOLBF)
  92. (let-values (((code message) (%ftp-listen s)))
  93. (if (eqv? code 220)
  94. (begin
  95. ;;(%ftp-command "OPTS UTF8 ON" 200 s)
  96. (%ftp-login "anonymous" "guix@example.com" s)
  97. (%make-ftp-connection s ai))
  98. (begin
  99. (format (current-error-port)
  100. "FTP to `~a' failed: ~A: ~A~%"
  101. host code message)
  102. (close s)
  103. #f))))
  104. (lambda args
  105. ;; Connection failed, so try one of the other addresses.
  106. (close s)
  107. (if (null? addresses)
  108. (apply throw args)
  109. (loop (cdr addresses))))))))
  110. (define (ftp-close conn)
  111. (close (ftp-connection-socket conn)))
  112. (define %char-set:not-slash
  113. (char-set-complement (char-set #\/)))
  114. (define (ftp-chdir conn dir)
  115. "Change to directory DIR."
  116. ;; On ftp.gnupg.org, "PASV" right after "CWD /gcrypt/gnupg" hangs. Doing
  117. ;; CWD in two steps works, so just do this.
  118. (let ((components (string-tokenize dir %char-set:not-slash)))
  119. (fold (lambda (dir result)
  120. (%ftp-command (string-append "CWD " dir) 250
  121. (ftp-connection-socket conn)))
  122. #f
  123. (if (string-prefix? "/" dir)
  124. (cons "/" components)
  125. components))))
  126. (define (ftp-size conn file)
  127. "Return the size in bytes of FILE."
  128. (let ((message (%ftp-command (string-append "SIZE " file) 213
  129. (ftp-connection-socket conn))))
  130. (string->number (string-trim-both message))))
  131. (define (ftp-pasv conn)
  132. (define %pasv-rx
  133. (make-regexp "([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)"))
  134. (let ((message (%ftp-command "PASV" 227 (ftp-connection-socket conn))))
  135. (cond ((regexp-exec %pasv-rx message)
  136. =>
  137. (lambda (match)
  138. (+ (* (string->number (match:substring match 5)) 256)
  139. (string->number (match:substring match 6)))))
  140. (else
  141. (throw 'ftp-error conn "PASV" 227 message)))))
  142. (define (address-with-port sa port)
  143. "Return a socket-address object based on SA, but with PORT."
  144. (let ((fam (sockaddr:fam sa))
  145. (addr (sockaddr:addr sa)))
  146. (cond ((= fam AF_INET)
  147. (make-socket-address fam addr port))
  148. ((= fam AF_INET6)
  149. (make-socket-address fam addr port
  150. (sockaddr:flowinfo sa)
  151. (sockaddr:scopeid sa)))
  152. (else #f))))
  153. (define* (ftp-list conn #:optional directory)
  154. (if directory
  155. (ftp-chdir conn directory))
  156. (let* ((port (ftp-pasv conn))
  157. (ai (ftp-connection-addrinfo conn))
  158. (s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
  159. (addrinfo:protocol ai))))
  160. (connect s (address-with-port (addrinfo:addr ai) port))
  161. (setvbuf s _IOLBF)
  162. (dynamic-wind
  163. (lambda () #t)
  164. (lambda ()
  165. (%ftp-command "LIST" 150 (ftp-connection-socket conn))
  166. (let loop ((line (read-line s))
  167. (result '()))
  168. (cond ((eof-object? line) (reverse result))
  169. ((regexp-exec %ftp-ready-rx line)
  170. =>
  171. (lambda (match)
  172. (let ((code (string->number (match:substring match 1))))
  173. (if (= 126 code)
  174. (reverse result)
  175. (throw 'ftp-error conn "LIST" code)))))
  176. (else
  177. (loop (read-line s)
  178. (match (reverse (string-tokenize line))
  179. ((file _ ... permissions)
  180. (let ((type (case (string-ref permissions 0)
  181. ((#\d) 'directory)
  182. (else 'file))))
  183. (cons (list file type) result)))
  184. ((file _ ...)
  185. (cons (cons file 'file) result))))))))
  186. (lambda ()
  187. (close s)
  188. (let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
  189. (or (eqv? code 226)
  190. (throw 'ftp-error conn "LIST" code message)))))))
  191. (define* (ftp-retr conn file #:optional directory)
  192. "Retrieve FILE from DIRECTORY (or, if omitted, the current directory) from
  193. FTP connection CONN. Return a binary port to that file. The returned port
  194. must be closed before CONN can be used for other purposes."
  195. (if directory
  196. (ftp-chdir conn directory))
  197. ;; Ask for "binary mode".
  198. (%ftp-command "TYPE I" 200 (ftp-connection-socket conn))
  199. (let* ((port (ftp-pasv conn))
  200. (ai (ftp-connection-addrinfo conn))
  201. (s (with-fluids ((%default-port-encoding #f))
  202. (socket (addrinfo:fam ai) (addrinfo:socktype ai)
  203. (addrinfo:protocol ai)))))
  204. (define (terminate)
  205. (close s)
  206. (let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
  207. (or (eqv? code 226)
  208. (throw 'ftp-error conn "LIST" code message))))
  209. (connect s (address-with-port (addrinfo:addr ai) port))
  210. (setvbuf s _IOLBF)
  211. (%ftp-command (string-append "RETR " file)
  212. 150 (ftp-connection-socket conn))
  213. (make-custom-binary-input-port "FTP RETR port"
  214. (rec (read! bv start count)
  215. (match (get-bytevector-n! s bv
  216. start count)
  217. ((? eof-object?) 0)
  218. (0
  219. ;; Nothing available yet, so try
  220. ;; again. This is important because
  221. ;; the return value of `read!' makes
  222. ;; it impossible to distinguish
  223. ;; between "not yet" and "EOF".
  224. (read! bv start count))
  225. (read read)))
  226. #f #f ; no get/set position
  227. terminate)))
  228. ;;; ftp-client.scm ends here