basis/ftp/server/server.factor

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