extra/ftp/client/client.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays classes.singleton combinators
   4 continuations io io.encodings.binary io.encodings.utf8
   5 io.files io.sockets kernel io.streams.duplex math
   6 math.parser sequences splitting namespaces strings fry ftp ;
   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 : ftp-command ( string -- ftp-response )
  28     ftp-send read-response ;
  29
  30 : ftp-user ( ftp-client -- ftp-response )
  31     user>> "USER " prepend ftp-command ;
  32
  33 : ftp-password ( ftp-client -- ftp-response )
  34     password>> "PASS " prepend ftp-command ;
  35
  36 : ftp-set-binary ( -- ftp-response )
  37     "TYPE I" ftp-command ;
  38
  39 : ftp-pwd ( -- ftp-response )
  40     "PWD" ftp-command ;
  41
  42 : ftp-list ( -- ftp-response )
  43     "LIST" ftp-command ;
  44
  45 : ftp-quit ( -- ftp-response )
  46     "QUIT" ftp-command ;
  47
  48 : ftp-cwd ( directory -- ftp-response )
  49     "CWD " prepend ftp-command ;
  50
  51 : ftp-retr ( filename -- ftp-response )
  52     "RETR " prepend ftp-command ;
  53
  54 : parse-epsv ( ftp-response -- port )
  55     strings>> first
  56     "|" split 2 tail* first string>number ;
  57
  58 TUPLE: remote-file
  59 type permissions links owner group size month day time year
  60 name target ;
  61
  62 : <remote-file> ( -- remote-file ) remote-file new ;
  63
  64 : parse-permissions ( remote-file str -- remote-file )
  65     [ first ch>type >>type ] [ rest >>permissions ] bi ;
  66
  67 : parse-list-11 ( lines -- seq )
  68     [
  69         11 f pad-right
  70         <remote-file> swap {
  71             [ 0 swap nth parse-permissions ]
  72             [ 1 swap nth string>number >>links ]
  73             [ 2 swap nth >>owner ]
  74             [ 3 swap nth >>group ]
  75             [ 4 swap nth string>number >>size ]
  76             [ 5 swap nth >>month ]
  77             [ 6 swap nth >>day ]
  78             [ 7 swap nth >>time ]
  79             [ 8 swap nth >>name ]
  80             [ 10 swap nth >>target ]
  81         } cleave
  82     ] map ;
  83
  84 : parse-list-8 ( lines -- seq )
  85     [
  86         <remote-file> swap {
  87             [ 0 swap nth parse-permissions ]
  88             [ 1 swap nth string>number >>links ]
  89             [ 2 swap nth >>owner ]
  90             [ 3 swap nth >>size ]
  91             [ 4 swap nth >>month ]
  92             [ 5 swap nth >>day ]
  93             [ 6 swap nth >>time ]
  94             [ 7 swap nth >>name ]
  95         } cleave
  96     ] map ;
  97
  98 : parse-list-3 ( lines -- seq )
  99     [
 100         <remote-file> swap {
 101             [ 0 swap nth parse-permissions ]
 102             [ 1 swap nth string>number >>links ]
 103             [ 2 swap nth >>name ]
 104         } cleave
 105     ] map ;
 106
 107 : parse-list ( ftp-response -- ftp-response )
 108     dup strings>>
 109     [ " " split harvest ] map
 110     dup length {
 111         { 11 [ parse-list-11 ] }
 112         { 9 [ parse-list-11 ] }
 113         { 8 [ parse-list-8 ] }
 114         { 3 [ parse-list-3 ] }
 115         [ drop ]
 116     } case >>parsed ;
 117
 118 : ftp-epsv ( -- ftp-response )
 119     "EPSV" ftp-command ;
 120
 121 ERROR: ftp-error got expected ;
 122 : ftp-assert ( ftp-response n -- )
 123     2dup >r n>> r> = [ 2drop ] [ ftp-error ] if ;
 124
 125 : ftp-login ( ftp-client -- )
 126     read-response 220 ftp-assert
 127     [ ftp-user 331 ftp-assert ]
 128     [ ftp-password 230 ftp-assert ] bi
 129     ftp-set-binary 200 ftp-assert ;
 130
 131 : open-remote-port ( -- port )
 132     ftp-epsv
 133     [ 229 ftp-assert ] [ parse-epsv ] bi ;
 134
 135 : list ( ftp-client -- ftp-response )
 136     host>> open-remote-port <inet> utf8 <client> drop
 137     ftp-list 150 ftp-assert
 138     lines
 139     <ftp-response> swap >>strings
 140     read-response 226 ftp-assert
 141     parse-list ;
 142
 143 : ftp-get ( filename ftp-client -- ftp-response )
 144     host>> open-remote-port <inet> binary <client> drop
 145     swap
 146     [ ftp-retr 150 ftp-assert drop ]
 147     [ binary <file-writer> stream-copy ] 2bi
 148     read-response dup 226 ftp-assert ;
 149
 150 : ftp-connect ( ftp-client -- stream )
 151     [ host>> ] [ port>> ] bi <inet> utf8 <client> drop ;
 152
 153 GENERIC: ftp-download ( path obj -- )
 154
 155 : with-ftp-client ( ftp-client quot -- )
 156     dupd '[
 157         _ [ ftp-login ] [ @ ] bi
 158         ftp-quit drop
 159     ] >r ftp-connect r> with-stream ; inline
 160
 161 M: ftp-client ftp-download ( path ftp-client -- )
 162     [
 163         [ drop parent-directory ftp-cwd drop ]
 164         [ >r file-name r> ftp-get drop ] 2bi
 165     ] with-ftp-client ;
 166
 167 M: string ftp-download ( path string -- )
 168     <ftp-client> ftp-download ;