uses with-stream now

extra/ftp/client/client.factor

@@ -2,11 +2,11 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays classes.singleton combinators
 continuations io io.encodings.binary io.encodings.ascii
-io.files io.sockets kernel math math.parser sequences
+io.files io.sockets kernel io.streams.duplex math
-splitting namespaces strings ;
+math.parser sequences splitting namespaces strings fry ;
 IN: ftp.client
 
-TUPLE: ftp-client host port stream user password mode ;
+TUPLE: ftp-client host port user password mode ;
 TUPLE: ftp-response n strings parsed ;
 
 SINGLETON: active
@@ -21,7 +21,7 @@ SINGLETON: passive
         swap >>host
         21 >>port
         "anonymous" >>user
-        "factor-ftp@factorcode.org" >>password ;
+        "ftp@my.org" >>password ;
 
 : add-response-line ( ftp-response string -- ftp-response )
     over strings>> push ;
@@ -32,56 +32,47 @@ SINGLETON: passive
 : ftp-response-code ( string -- n/f )
     dup fourth CHAR: - = [ drop f ] [ (ftp-response-code) ] if ;
 
-: last-code ( ftp-response -- n )
+: read-response-loop ( ftp-response -- ftp-response )
-    strings>> peek (ftp-response-code) ;
+    readln
-
-: read-response-until ( stream ftp-response n -- ftp-response )
-    >r over stream-readln
     [ add-response-line ] [ ftp-response-code ] bi
-    r> tuck = [ drop nip ] [ read-response-until ] if ;
+    over n>> = [ read-response-loop ] unless ;
 
-: read-response ( stream -- ftp-response )
+: read-response ( -- ftp-response )
-    <ftp-response>
+    <ftp-response> readln
-    over stream-readln
+    [ (ftp-response-code) >>n ]
-    [ add-response-line ] [ fourth CHAR: - = ] bi
+    [ add-response-line ]
-    [ dup last-code read-response-until ]
+    [ fourth CHAR: - = ] tri
-    [ nip ] if dup last-code >>n ;
+    [ read-response-loop ] when ;
 
-: ftp-read ( ftp-client -- ftp-response )
+: ftp-send ( string -- )
-    stream>> read-response ;
+    write "\r\n" write flush ;
 
-: ftp-send ( str ftp-client -- )
+: ftp-command ( string -- ftp-response )
-    stream>>
+    ftp-send read-response ;
-    [ stream-write ]
-    [ "\r\n" swap stream-write ]
-    [ stream-flush ] tri ;
-
-: ftp-command ( string ftp-client -- ftp-response )
-    [ ftp-send ] [ ftp-read ] bi ;
 
 : ftp-user ( ftp-client -- ftp-response )
-    [ user>> "USER " prepend ] [ ftp-command ] bi ;
+    user>> "USER " prepend ftp-command ;
 
 : ftp-password ( ftp-client -- ftp-response )
-    [ password>> "PASS " prepend ] [ ftp-command ] bi ;
+    password>> "PASS " prepend ftp-command ;
 
-: ftp-set-binary ( ftp-client -- ftp-response )
+: ftp-set-binary ( -- ftp-response )
-    >r "TYPE I" r> ftp-command ;
+    "TYPE I" ftp-command ;
 
-: ftp-pwd ( ftp-client -- ftp-response )
+: ftp-pwd ( -- ftp-response )
-    >r "PWD" r> ftp-command ;
+    "PWD" ftp-command ;
 
-: ftp-list ( ftp-client -- ftp-response )
+: ftp-list ( -- ftp-response )
-    >r "LIST" r> ftp-command ;
+    "LIST" ftp-command ;
 
-: ftp-quit ( ftp-client -- ftp-response )
+: ftp-quit ( -- ftp-response )
-    >r "QUIT" r> ftp-command ;
+    "QUIT" ftp-command ;
 
-: ftp-cwd ( directory ftp-client -- ftp-response )
+: ftp-cwd ( directory -- ftp-response )
-    >r "CWD " prepend r> ftp-command ;
+    "CWD " prepend ftp-command ;
 
-: ftp-retr ( filename ftp-client -- ftp-response )
+: ftp-retr ( filename -- ftp-response )
-    >r "RETR " prepend r> ftp-command ;
+    "RETR " prepend ftp-command ;
 
 : parse-epsv ( ftp-response -- port )
     strings>> first
@@ -151,54 +142,54 @@ TUPLE: remote-file
         [ drop ]
     } case >>parsed ;
 
-: ftp-epsv ( ftp-client -- ftp-response )
+: ftp-epsv ( -- ftp-response )
-    >r "EPSV" r> ftp-command ;
+    "EPSV" ftp-command ;
-
-M: ftp-client dispose ( ftp-client -- )
-    [ ftp-quit drop ] [ stream>> dispose ] bi ;
 
 ERROR: ftp-error got expected ;
 : ftp-assert ( ftp-response n -- )
     2dup >r n>> r> = [ 2drop ] [ ftp-error ] if ;
 
-: ftp-connect ( ftp-client -- )
-    dup
-    [ host>> ] [ port>> ] bi <inet> ascii <client>
-    >>stream drop ;
-
 : ftp-login ( ftp-client -- )
-    {
+    read-response 220 ftp-assert
-        [ ftp-connect ]
+    [ ftp-user 331 ftp-assert ]
-        [ ftp-read 220 ftp-assert ]
+    [ ftp-password 230 ftp-assert ] bi
-        [ ftp-user 331 ftp-assert ]
+    ftp-set-binary 200 ftp-assert ;
-        [ ftp-password 230 ftp-assert ]
-        [ ftp-set-binary 200 ftp-assert ]
-    } cleave ;
 
-: start-2nd ( ftp-client -- port )
+: open-remote-port ( -- port )
-    ftp-epsv [ 229 ftp-assert ] [ parse-epsv ] bi ;
+    ftp-epsv
+    [ 229 ftp-assert ] [ parse-epsv ] bi ;
 
 : list ( ftp-client -- ftp-response )
-    dup [ host>> ] [ start-2nd ] bi <inet> ascii <client>
+    host>> open-remote-port <inet> ascii <client>
-    over ftp-list 150 ftp-assert
+    ftp-list 150 ftp-assert
-    lines <ftp-response> swap >>strings
+    lines
-    >r ftp-read 226 ftp-assert r>
+    <ftp-response> swap >>strings
+    read-response 226 ftp-assert
     parse-list ;
 
 : ftp-get ( filename ftp-client -- ftp-response )
-    dup [ host>> ] [ start-2nd ] bi <inet> binary <client>
+    host>> open-remote-port <inet> binary <client>
-    rot tuck
+    swap
-    [ over ftp-retr 150 ftp-assert ]
+    [ ftp-retr 150 ftp-assert drop ]
-    [ binary <file-writer> stream-copy ] 2bi*
+    [ binary <file-writer> stream-copy ] 2bi
-    ftp-read dup 226 ftp-assert ;
+    read-response dup 226 ftp-assert ;
+
+: ftp-connect ( ftp-client -- stream )
+    [ host>> ] [ port>> ] bi <inet> ascii <client> ;
 
 GENERIC: ftp-download ( path obj -- )
 
+: with-ftp-client ( ftp-client quot -- )
+    dupd '[
+        , [ ftp-login ] [ @ ] bi
+        ftp-quit drop
+    ] >r ftp-connect r> with-stream ; inline
+
 M: ftp-client ftp-download ( path ftp-client -- )
-    dup ftp-login
+    [
-    [ >r parent-directory r> ftp-cwd drop ]
+        [ drop parent-directory ftp-cwd drop ]
-    [ >r file-name r> ftp-get drop ]
+        [ >r file-name r> ftp-get drop ] 2bi
-    [ dispose drop ] 2tri ;
+    ] with-ftp-client ;
 
 M: string ftp-download ( path string -- )
     <ftp-client> ftp-download ;