basis/ftp/client/client.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors ftp ftp.client.listing-parser io
   4 io.encodings.binary io.encodings.utf8 io.files io.pathnames
   5 io.sockets io.streams.duplex kernel math.parser sequences
   6 splitting urls ;
   7 IN: ftp.client
   8
   9 : (ftp-response-code) ( str -- n )
  10     3 head string>number ;
  11
  12 : ftp-response-code ( string -- n/f )
  13     dup fourth CHAR: - = [ drop f ] [ (ftp-response-code) ] if ;
  14
  15 : read-response-loop ( ftp-response -- ftp-response )
  16     readln
  17     [ add-response-line ] [ ftp-response-code ] bi
  18     over n>> = [ read-response-loop ] unless ;
  19
  20 : read-response ( -- ftp-response )
  21     <ftp-response> readln
  22     [ (ftp-response-code) >>n ]
  23     [ add-response-line ]
  24     [ fourth CHAR: - = ] tri
  25     [ read-response-loop ] when ;
  26
  27 ERROR: ftp-error got expected ;
  28
  29 : ftp-assert ( ftp-response n -- )
  30     2dup [ n>> ] dip = [ 2drop ] [ ftp-error ] if ;
  31
  32 : ftp-command ( string -- ftp-response )
  33     ftp-send read-response ;
  34
  35 : ftp-user ( url -- ftp-response )
  36     username>> "USER " prepend ftp-command ;
  37
  38 : ftp-password ( url -- ftp-response )
  39     password>> "PASS " prepend ftp-command ;
  40
  41 : ftp-cwd ( directory -- ftp-response )
  42     "CWD " prepend ftp-command ;
  43
  44 : ftp-retr ( filename -- ftp-response )
  45     "RETR " prepend ftp-command ;
  46
  47 : ftp-set-binary ( -- ftp-response ) "TYPE I" ftp-command ;
  48
  49 : ftp-pwd ( -- ftp-response ) "PWD" ftp-command ;
  50
  51 : ftp-list ( -- )
  52     "LIST" ftp-command 150 ftp-assert ;
  53
  54 : ftp-quit ( -- ftp-response ) "QUIT" ftp-command ;
  55
  56 : ftp-epsv ( -- ftp-response )
  57     "EPSV" ftp-command dup 229 ftp-assert ;
  58
  59 : parse-epsv ( ftp-response -- port )
  60     strings>> first "|" split 2 tail* first string>number ;
  61
  62 : open-passive-client ( url protocol -- stream )
  63     [ url-addr ftp-epsv parse-epsv with-port ] dip <client> drop ;
  64
  65 : list ( url -- ftp-response )
  66     utf8 open-passive-client
  67     ftp-list
  68     stream-lines
  69     <ftp-response> swap >>strings
  70     read-response 226 ftp-assert
  71     parse-list ;
  72
  73 : (ftp-get) ( url path -- )
  74     [ binary open-passive-client ] dip
  75     [ ftp-retr 150 ftp-assert drop ]
  76     [ binary <file-writer> stream-copy ] 2bi
  77     read-response 226 ftp-assert ;
  78
  79 : ftp-login ( url -- )
  80     read-response 220 ftp-assert
  81     [ ftp-user 331 ftp-assert ]
  82     [ ftp-password 230 ftp-assert ] bi
  83     ftp-set-binary 200 ftp-assert ;
  84
  85 : ftp-connect ( url -- stream )
  86     url-addr utf8 <client> drop ;
  87
  88 : with-ftp-client ( url quot -- )
  89     [ [ ftp-connect ] keep ] dip
  90     '[ _ [ ftp-login ] _ bi ftp-quit drop ] with-stream ; inline
  91
  92 : ensure-login ( url -- url )
  93     dup username>> [
  94         "anonymous" >>username
  95         "ftp-client@factorcode.org" >>password
  96     ] unless ;
  97
  98 : >ftp-url ( url -- url' ) >url ensure-port ensure-login ;
  99
 100 : ftp-get ( url -- )
 101     >ftp-url [
 102         dup path>>
 103         [ nip parent-directory ftp-cwd drop ]
 104         [ file-name (ftp-get) ] 2bi
 105     ] with-ftp-client ;