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