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