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