basis/ftp/server/server.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors calendar calendar.format classes combinators
   4 combinators.short-circuit concurrency.promises continuations
   5 destructors ftp io io.directories io.encodings
   6 io.encodings.8-bit.latin1 io.encodings.binary io.encodings.utf8
   7 io.files io.files.info io.files.types io.pathnames
   8 io.servers io.sockets io.streams.string io.timeouts
   9 kernel logging math math.bitwise math.parser namespaces
  10 sequences simple-tokenizer splitting strings threads
  11 tools.files unicode.case ;
  12 IN: ftp.server
  13
  14 SYMBOL: server
  15 SYMBOL: client
  16
  17 TUPLE: ftp-server < threaded-server { serving-directory string } ;
  18
  19 TUPLE: ftp-client user password extra-connection ;
  20
  21 TUPLE: ftp-command raw tokenized ;
  22 : <ftp-command> ( str -- obj )
  23     dup \ <ftp-command> DEBUG log-message
  24     ftp-command new
  25         over >>raw
  26         swap tokenize >>tokenized ;
  27
  28 TUPLE: ftp-get path ;
  29 C: <ftp-get> ftp-get
  30
  31 TUPLE: ftp-put path ;
  32 C: <ftp-put> ftp-put
  33
  34 TUPLE: ftp-list ;
  35 C: <ftp-list> ftp-list
  36
  37 TUPLE: ftp-disconnect ;
  38 C: <ftp-disconnect> ftp-disconnect
  39
  40 : (send-response) ( n string separator -- )
  41     [ number>string write ] 2dip write ftp-send ;
  42
  43 : send-response ( ftp-response -- )
  44     [ n>> ] [ strings>> ] bi
  45     [ but-last-slice [ "-" (send-response) ] with each ]
  46     [ first " " (send-response) ] 2bi ;
  47
  48 : make-path-relative? ( path -- ? )
  49     {
  50         [ absolute-path? ]
  51         [ drop server get serving-directory>> ]
  52     } 1&& ;
  53
  54 : fixup-relative-path ( string -- string' )
  55     dup make-path-relative? [
  56         [ server get serving-directory>> ] dip append-relative-path
  57     ] when ;
  58
  59 : server-response ( string n -- )
  60     2dup number>string swap ":" glue \ server-response DEBUG log-message
  61     <ftp-response>
  62         swap >>n
  63         swap add-response-line
  64     send-response ;
  65
  66 : serving? ( path -- ? )
  67     resolve-symlinks server get serving-directory>> head? ;
  68
  69 : can-serve-directory? ( path -- ? )
  70     { [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ;
  71
  72 : can-serve-file? ( path -- ? )
  73     {
  74         [ exists? ]
  75         [ file-info regular-file? ]
  76         [ serving? ]
  77     } 1&& ;
  78
  79 : ftp-error ( string -- ) 500 server-response ;
  80
  81 : ftp-unimplemented ( string -- ) 502 server-response ;
  82
  83 : send-banner ( -- )
  84     "Welcome to " host-name append 220 server-response ;
  85
  86 : anonymous-only ( -- )
  87     "This FTP server is anonymous only." 530 server-response ;
  88
  89 : handle-QUIT ( obj -- )
  90     drop "Goodbye." 221 server-response ;
  91
  92 : handle-USER ( ftp-command -- )
  93     [
  94         tokenized>> second client get user<<
  95         "Please specify the password." 331 server-response
  96     ] [
  97         2drop "bad USER" ftp-error
  98     ] recover ;
  99
 100 : handle-PASS ( ftp-command -- )
 101     [
 102         tokenized>> second client get password<<
 103         "Login successful" 230 server-response
 104     ] [
 105         2drop "PASS error" ftp-error
 106     ] recover ;
 107
 108 ERROR: type-error type ;
 109
 110 : parse-type ( string -- string' )
 111     >upper {
 112         { "IMAGE" [ "Binary" ] }
 113         { "I" [ "Binary" ] }
 114         [ throw-type-error ]
 115     } case ;
 116
 117 : handle-TYPE ( obj -- )
 118     [
 119         tokenized>> second parse-type
 120         "Switching to " " mode" surround 200 server-response
 121     ] [
 122         2drop "TYPE is binary only" ftp-error
 123     ] recover ;
 124
 125 : random-local-server ( -- server )
 126     remote-address get class-of new binary <server> ;
 127
 128 : port>bytes ( port -- hi lo )
 129     [ -8 shift ] keep [ 8 bits ] bi@ ;
 130
 131 : display-directory ( -- string )
 132     current-directory get server get serving-directory>> swap ?head drop
 133     [ "/" ] when-empty ;
 134
 135 : handle-PWD ( obj -- )
 136     drop
 137     display-directory "\"" dup surround 257 server-response ;
 138
 139 : handle-SYST ( obj -- )
 140     drop
 141     "UNIX Type: L8" 215 server-response ;
 142
 143 : start-directory ( -- )
 144     "Here comes the directory listing." 150 server-response ;
 145
 146 : transfer-outgoing-file ( path -- )
 147     [ "Opening BINARY mode data connection for " ] dip
 148     [ file-name ] [
 149         file-info size>> number>string
 150         "(" " bytes)." surround
 151     ] bi " " glue append 150 server-response ;
 152
 153 : transfer-incoming-file ( path -- )
 154     "Opening BINARY mode data connection for " prepend
 155     150 server-response ;
 156
 157 : finish-file-transfer ( -- )
 158     "File send OK." 226 server-response ;
 159
 160 GENERIC: handle-passive-command ( stream obj -- )
 161
 162 : passive-loop ( server -- )
 163     [
 164         [
 165             |dispose
 166             30 seconds over set-timeout
 167             accept drop &dispose
 168             client get extra-connection>>
 169             30 seconds ?promise-timeout
 170             handle-passive-command
 171         ]
 172         [ client get f >>extra-connection drop ]
 173         [ drop ] cleanup
 174     ] with-destructors ;
 175
 176 : finish-directory ( -- )
 177     "Directory send OK." 226 server-response ;
 178
 179 M: ftp-list handle-passive-command ( stream obj -- )
 180     drop
 181     start-directory [
 182         utf8 encode-output [
 183             current-directory get directory.
 184         ] with-string-writer string-lines
 185         harvest [ ftp-send ] each
 186     ] with-output-stream finish-directory ;
 187
 188 M: ftp-get handle-passive-command ( stream obj -- )
 189     [
 190         path>>
 191         [ transfer-outgoing-file ]
 192         [ binary <file-reader> swap stream-copy ] bi
 193         finish-file-transfer
 194     ] [
 195         3drop "File transfer failed" ftp-error
 196     ] recover ;
 197
 198 M: ftp-put handle-passive-command ( stream obj -- )
 199     [
 200         path>>
 201         [ transfer-incoming-file ]
 202         [ binary <file-writer> stream-copy ] bi
 203         finish-file-transfer
 204     ] [
 205         3drop "File transfer failed" ftp-error
 206     ] recover ;
 207
 208 M: ftp-disconnect handle-passive-command ( stream obj -- )
 209     drop dispose ;
 210
 211 : fulfill-client ( obj -- )
 212     client get extra-connection>> [
 213         fulfill
 214     ] [
 215         drop
 216         "Establish an active or passive connection first" ftp-error
 217     ] if* ;
 218
 219 : handle-STOR ( obj -- )
 220     tokenized>> second
 221     dup can-serve-file? [
 222         <ftp-put> fulfill-client
 223     ] [
 224         drop
 225         <ftp-disconnect> fulfill-client
 226     ] if ;
 227
 228 : handle-LIST ( obj -- )
 229     drop current-directory get
 230     can-serve-directory? [
 231         <ftp-list> fulfill-client
 232     ] [
 233         <ftp-disconnect> fulfill-client
 234     ] if ;
 235
 236 : not-a-plain-file ( path -- )
 237     ": not a plain file." append ftp-error ;
 238
 239 : handle-RETR ( obj -- )
 240     tokenized>> second
 241     fixup-relative-path
 242     dup can-serve-file? [
 243         <ftp-get> fulfill-client
 244     ] [
 245         not-a-plain-file
 246         <ftp-disconnect> fulfill-client
 247     ] if ;
 248
 249 : handle-SIZE ( obj -- )
 250     tokenized>> second
 251     dup can-serve-file? [
 252         file-info size>> number>string 213 server-response
 253     ] [
 254         not-a-plain-file
 255     ] if ;
 256
 257 : expect-connection ( -- port )
 258     <promise> client get extra-connection<<
 259     random-local-server
 260     [ [ passive-loop ] curry in-thread ]
 261     [ addr>> port>> ] bi ;
 262
 263 : handle-PASV ( obj -- )
 264     drop
 265     expect-connection port>bytes [ number>string ] bi@ "," glue
 266     "Entering Passive Mode (127,0,0,1," ")" surround
 267     221 server-response ;
 268
 269 : handle-EPSV ( obj -- )
 270     drop
 271     client get f >>extra-connection drop
 272     expect-connection number>string
 273     "Entering Extended Passive Mode (|||" "|)" surround
 274     229 server-response ;
 275
 276 : handle-MDTM ( obj -- )
 277     tokenized>> ?second [
 278         fixup-relative-path
 279         dup file-info dup directory? [
 280             drop not-a-plain-file
 281         ] [
 282             nip
 283             modified>> timestamp>mdtm
 284             213 server-response
 285         ] if
 286     ] [
 287         "" not-a-plain-file
 288     ] if* ;
 289
 290 : directory-change-success ( -- )
 291     "Directory successully changed." 250 server-response ;
 292
 293 : directory-change-failed ( -- )
 294     "Failed to change directory." 553 server-response ;
 295
 296 : handle-CWD ( obj -- )
 297     tokenized>> ?second [
 298         fixup-relative-path
 299         dup can-serve-directory? [
 300             set-current-directory
 301             directory-change-success
 302         ] [
 303             drop
 304             directory-change-failed
 305         ] if
 306     ] [
 307         directory-change-success
 308     ] if* ;
 309
 310 : unrecognized-command ( obj -- )
 311     raw>> "Unrecognized command: " prepend ftp-error ;
 312
 313 : client-loop-dispatch ( str/f -- ? )
 314     dup tokenized>> first >upper {
 315         { "QUIT" [ handle-QUIT f ] }
 316         { "USER" [ handle-USER t ] }
 317         { "PASS" [ handle-PASS t ] }
 318         { "SYST" [ handle-SYST t ] }
 319         { "ACCT" [ drop "ACCT unimplemented" ftp-unimplemented t ] }
 320         { "PWD" [ handle-PWD t ] }
 321         { "TYPE" [ handle-TYPE t ] }
 322         { "CWD" [ handle-CWD t ] }
 323         { "PASV" [ handle-PASV t ] }
 324         { "EPSV" [ handle-EPSV t ] }
 325         { "LIST" [ handle-LIST t ] }
 326         { "STOR" [ handle-STOR t ] }
 327         { "RETR" [ handle-RETR t ] }
 328         { "SIZE" [ handle-SIZE t ] }
 329         { "MDTM" [ handle-MDTM t ] }
 330         [ drop unrecognized-command t ]
 331     } case ;
 332
 333 : read-command ( -- ftp-command/f )
 334     readln [ f ] [ <ftp-command> ] if-empty ;
 335
 336 : handle-client-loop ( -- )
 337     read-command [
 338         client-loop-dispatch
 339         [ handle-client-loop ] when
 340     ] when* ;
 341
 342 : serve-directory ( server -- )
 343     serving-directory>> [
 344         send-banner
 345         handle-client-loop
 346     ] with-directory ;
 347
 348 M: ftp-server handle-client* ( server -- )
 349     [
 350         "New client" \ handle-client* DEBUG log-message
 351         ftp-client new client set
 352         [ server set ] [ serve-directory ] bi
 353     ] with-destructors ;
 354
 355 : <ftp-server> ( directory port -- server )
 356     latin1 ftp-server new-threaded-server
 357         swap >>insecure
 358         swap resolve-symlinks >>serving-directory
 359         "ftp.server" >>name
 360         5 minutes >>timeout ;
 361
 362 : ftpd ( directory port -- server )
 363     <ftp-server> start-server ;
 364
 365 ! sudo tcpdump -i en1 -A -s 10000  tcp port 21
 366 ! [2010-09-04T22:07:58-05:00] DEBUG server-response: 500:Unrecognized command: EPRT |2|0:0:0:0:0:0:0:1|59359|