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