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