basis/ftp/server/server.factor

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