From 8017364b1a59617bb82663b60aa0b0883772614d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 11 May 2008 14:47:14 -0500 Subject: [PATCH 1/7] add ftp so i can work on it on another computer --- extra/ftp/client/authors.txt | 1 + extra/ftp/client/client.factor | 107 +++++++++++++++++++++++++++++++++ 2 files changed, 108 insertions(+) create mode 100644 extra/ftp/client/authors.txt create mode 100644 extra/ftp/client/client.factor diff --git a/extra/ftp/client/authors.txt b/extra/ftp/client/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/ftp/client/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor new file mode 100644 index 0000000000..608f14544b --- /dev/null +++ b/extra/ftp/client/client.factor @@ -0,0 +1,107 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators continuations io io.encodings.binary +io.encodings.ascii io.files io.sockets kernel math +math.parser sequences splitting namespaces ; +IN: ftp.client + +TUPLE: ftp-client host port stream user password ; +TUPLE: ftp-response n strings ; + +: ( -- ftp-response ) + ftp-response new + V{ } clone >>strings ; + +: ( host -- ftp-client ) + ftp-client new + swap >>host + 21 >>port + "anonymous" >>user + "lol@test.com" >>password ; + +: read-epsv ( stream -- port ) + dup stream-readln dup print + "|" split 2 tail* first string>number ; + +: read-until-command ( stream ftp-response -- n ) + over stream-readln + " " split1 drop string>number dup number? [ + nip + ] [ + drop read-until-command + ] if ; + +: ftp-read ( ftp-client -- ftp-response ) + stream>> [ read-until-command ] keep + dup strings>> peek " " split1 ; + +: ftp-send ( str ftp-client -- ) + stream>> + [ stream-write ] + [ "\r\n" swap stream-write ] + [ stream-flush ] tri ; + +: ftp-command ( ftp-client string -- n ) + swap + [ ftp-send ] [ ftp-read ] bi ; + +: ftp-user ( ftp-client -- n ) dup user>> "USER " prepend ftp-command ; +: ftp-password ( ftp-client -- n ) dup password>> "PASS " prepend ftp-command ; +: ftp-set-binary ( ftp-client -- n ) "TYPE I" ftp-command ; +: ftp-set-ascii ( ftp-client -- n ) "TYPE A" ftp-command ; +: ftp-system ( ftp-client -- n ) "SYST" ftp-command ; +: ftp-features ( ftp-client -- n ) "FEAT" ftp-command ; +: ftp-pwd ( ftp-client -- n ) "PWD" ftp-command ; +: ftp-list ( ftp-client -- n ) "LIST" ftp-command ; +: ftp-quit ( ftp-client -- n ) "QUIT" ftp-command ; +: ftp-epsv ( ftp-client -- n str ) "EPSV" ftp-command ; +: ftp-cwd ( ftp-client directory -- n ) "CWD " prepend ftp-command ; +: ftp-retr ( ftp-client filename -- n ) "RETR " prepend ftp-command ; + +M: ftp-client dispose ( ftp-client -- ) + [ "QUIT" ftp-command ] [ stream>> dispose ] bi ; + +ERROR: ftp-error got expected ; +: ftp-assert ( m n -- ) + 2dup = [ 2drop ] [ ftp-error ] if ; + +: ftp-connect ( ftp-client -- stream ) + dup + [ host>> ] [ port>> ] bi ascii + >>stream drop ; + +: ftp-login ( ftp-client -- ) + { + [ ftp-connect ] + [ ftp-read 220 ftp-assert ] + [ ftp-user 331 ftp-assert ] + [ ftp-password 230 ftp-assert ] + [ ftp-set-binary 200 ftp-assert ] + } cleave ; + +: list ( stream -- ) + dup ftp-epsv + dup read-epsv + ! host get swap binary + over ftp-list + over read-until-command drop + contents write + read-until-command drop ; + +: ftp-get ( ftp-client filename -- ) + over ftp-epsv 229 ftp-assert + + ; + +! : ftp-get ( path stream -- ) + ! dup ftp-epsv + ! dup read-epsv + ! ! host get swap binary + ! >r [ ftp-retr ] 2keep dup read-until-command drop r> + ! rot binary stream-copy + ! read-until-command drop ; + + + +: ftp-interact ( stream -- ) + readln over ftp-send read-until-command drop ; From a8a61fb23c3d091ae03d8130dece1a84b3243bbc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 11 May 2008 17:25:25 -0500 Subject: [PATCH 2/7] refactoring ftp client --- extra/ftp/client/client.factor | 88 ++++++++++++++++++---------------- 1 file changed, 46 insertions(+), 42 deletions(-) diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor index 608f14544b..3539b2d5c2 100644 --- a/extra/ftp/client/client.factor +++ b/extra/ftp/client/client.factor @@ -19,21 +19,32 @@ TUPLE: ftp-response n strings ; "anonymous" >>user "lol@test.com" >>password ; -: read-epsv ( stream -- port ) - dup stream-readln dup print - "|" split 2 tail* first string>number ; +: add-response-line ( ftp-response string -- ftp-response ) + over strings>> push ; -: read-until-command ( stream ftp-response -- n ) +: (ftp-response-code) ( str -- n ) + 3 head string>number ; + +: ftp-response-code ( string -- n/f ) + dup fourth CHAR: - = [ drop f ] [ (ftp-response-code) ] if ; + +: last-code ( ftp-response -- n ) + strings>> peek (ftp-response-code) ; + +: 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 ; + +: read-response ( stream -- ftp-response ) + over stream-readln - " " split1 drop string>number dup number? [ - nip - ] [ - drop read-until-command - ] if ; + [ add-response-line ] [ fourth CHAR: - = ] bi + [ dup last-code read-response-until ] + [ nip ] if dup last-code >>n ; : ftp-read ( ftp-client -- ftp-response ) - stream>> [ read-until-command ] keep - dup strings>> peek " " split1 ; + stream>> read-response ; : ftp-send ( str ftp-client -- ) stream>> @@ -48,24 +59,29 @@ TUPLE: ftp-response n strings ; : ftp-user ( ftp-client -- n ) dup user>> "USER " prepend ftp-command ; : ftp-password ( ftp-client -- n ) dup password>> "PASS " prepend ftp-command ; : ftp-set-binary ( ftp-client -- n ) "TYPE I" ftp-command ; -: ftp-set-ascii ( ftp-client -- n ) "TYPE A" ftp-command ; +! : ftp-set-ascii ( ftp-client -- n ) "TYPE A" ftp-command ; : ftp-system ( ftp-client -- n ) "SYST" ftp-command ; : ftp-features ( ftp-client -- n ) "FEAT" ftp-command ; : ftp-pwd ( ftp-client -- n ) "PWD" ftp-command ; : ftp-list ( ftp-client -- n ) "LIST" ftp-command ; : ftp-quit ( ftp-client -- n ) "QUIT" ftp-command ; -: ftp-epsv ( ftp-client -- n str ) "EPSV" ftp-command ; : ftp-cwd ( ftp-client directory -- n ) "CWD " prepend ftp-command ; : ftp-retr ( ftp-client filename -- n ) "RETR " prepend ftp-command ; +: parse-epsv ( ftp-response -- port ) + strings>> first + "|" split 2 tail* first string>number ; + +: ftp-epsv ( ftp-client -- n ) "EPSV" ftp-command ; + M: ftp-client dispose ( ftp-client -- ) - [ "QUIT" ftp-command ] [ stream>> dispose ] bi ; + [ "QUIT" ftp-command drop ] [ stream>> dispose ] bi ; ERROR: ftp-error got expected ; -: ftp-assert ( m n -- ) - 2dup = [ 2drop ] [ ftp-error ] if ; +: ftp-assert ( ftp-response n -- ) + 2dup >r n>> r> = [ 2drop ] [ ftp-error ] if ; -: ftp-connect ( ftp-client -- stream ) +: ftp-connect ( ftp-client -- ) dup [ host>> ] [ port>> ] bi ascii >>stream drop ; @@ -79,29 +95,17 @@ ERROR: ftp-error got expected ; [ ftp-set-binary 200 ftp-assert ] } cleave ; -: list ( stream -- ) - dup ftp-epsv - dup read-epsv - ! host get swap binary - over ftp-list - over read-until-command drop - contents write - read-until-command drop ; +: list ( ftp-client -- ftp-response ) + dup ftp-epsv dup 229 ftp-assert + >r dup host>> r> parse-epsv ascii + over ftp-list 150 ftp-assert + lines swap >>strings + >r ftp-read 226 ftp-assert r> ; -: ftp-get ( ftp-client filename -- ) - over ftp-epsv 229 ftp-assert - - ; - -! : ftp-get ( path stream -- ) - ! dup ftp-epsv - ! dup read-epsv - ! ! host get swap binary - ! >r [ ftp-retr ] 2keep dup read-until-command drop r> - ! rot binary stream-copy - ! read-until-command drop ; - - - -: ftp-interact ( stream -- ) - readln over ftp-send read-until-command drop ; +: ftp-get ( ftp-client filename -- ftp-response ) + over ftp-epsv dup 229 ftp-assert + pick host>> swap parse-epsv binary + swap tuck + [ dupd ftp-retr 150 ftp-assert ] + [ binary stream-copy ] 2bi* + ftp-read dup 226 ftp-assert ; From b387eca7d9daa7ac0c0b12b1c84e2085ff951aba Mon Sep 17 00:00:00 2001 From: erg Date: Sun, 11 May 2008 17:59:33 -0500 Subject: [PATCH 3/7] ftp.client can download the linux kernel! --- extra/ftp/client/client.factor | 61 ++++++++++++++++++++++++---------- 1 file changed, 43 insertions(+), 18 deletions(-) diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor index 3539b2d5c2..f090a4da3e 100644 --- a/extra/ftp/client/client.factor +++ b/extra/ftp/client/client.factor @@ -1,13 +1,16 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators continuations io io.encodings.binary -io.encodings.ascii io.files io.sockets kernel math -math.parser sequences splitting namespaces ; +USING: accessors classes.singleton combinators continuations +io io.encodings.binary io.encodings.ascii io.files io.sockets +kernel math math.parser sequences splitting namespaces strings ; IN: ftp.client -TUPLE: ftp-client host port stream user password ; +TUPLE: ftp-client host port stream user password mode ; TUPLE: ftp-response n strings ; +SINGLETON: active +SINGLETON: passive + : ( -- ftp-response ) ftp-response new V{ } clone >>strings ; @@ -17,7 +20,7 @@ TUPLE: ftp-response n strings ; swap >>host 21 >>port "anonymous" >>user - "lol@test.com" >>password ; + "factor-ftp@factorcode.org" >>password ; : add-response-line ( ftp-response string -- ftp-response ) over strings>> push ; @@ -52,27 +55,38 @@ TUPLE: ftp-response n strings ; [ "\r\n" swap stream-write ] [ stream-flush ] tri ; -: ftp-command ( ftp-client string -- n ) +: ftp-command ( ftp-client string -- ftp-response ) swap [ ftp-send ] [ ftp-read ] bi ; -: ftp-user ( ftp-client -- n ) dup user>> "USER " prepend ftp-command ; -: ftp-password ( ftp-client -- n ) dup password>> "PASS " prepend ftp-command ; -: ftp-set-binary ( ftp-client -- n ) "TYPE I" ftp-command ; -! : ftp-set-ascii ( ftp-client -- n ) "TYPE A" ftp-command ; -: ftp-system ( ftp-client -- n ) "SYST" ftp-command ; -: ftp-features ( ftp-client -- n ) "FEAT" ftp-command ; -: ftp-pwd ( ftp-client -- n ) "PWD" ftp-command ; -: ftp-list ( ftp-client -- n ) "LIST" ftp-command ; -: ftp-quit ( ftp-client -- n ) "QUIT" ftp-command ; -: ftp-cwd ( ftp-client directory -- n ) "CWD " prepend ftp-command ; -: ftp-retr ( ftp-client filename -- n ) "RETR " prepend ftp-command ; +: ftp-user ( ftp-client -- ftp-response ) + dup user>> "USER " prepend ftp-command ; + +: ftp-password ( ftp-client -- ftp-response ) + dup password>> "PASS " prepend ftp-command ; + +: ftp-set-binary ( ftp-client -- ftp-response ) "TYPE I" ftp-command ; + +: ftp-pwd ( ftp-client -- ftp-response ) + "PWD" ftp-command ; + +: ftp-list ( ftp-client -- ftp-response ) + "LIST" ftp-command ; + +: ftp-quit ( ftp-client -- ftp-response ) + "QUIT" ftp-command ; + +: ftp-cwd ( ftp-client directory -- ftp-response ) + "CWD " prepend ftp-command ; + +: ftp-retr ( ftp-client filename -- ftp-response ) + "RETR " prepend ftp-command ; : parse-epsv ( ftp-response -- port ) strings>> first "|" split 2 tail* first string>number ; -: ftp-epsv ( ftp-client -- n ) "EPSV" ftp-command ; +: ftp-epsv ( ftp-client -- ftp-response ) "EPSV" ftp-command ; M: ftp-client dispose ( ftp-client -- ) [ "QUIT" ftp-command drop ] [ stream>> dispose ] bi ; @@ -109,3 +123,14 @@ ERROR: ftp-error got expected ; [ dupd ftp-retr 150 ftp-assert ] [ binary stream-copy ] 2bi* ftp-read dup 226 ftp-assert ; + +GENERIC# ftp-download 1 ( obj path -- ) + +M: ftp-client ftp-download ( ftp-client path -- ) + >r dup ftp-login r> + [ parent-directory ftp-cwd drop ] + [ file-name ftp-get drop ] + [ drop dispose ] 2tri ; + +M: string ftp-download ( string path -- ) + >r r> ftp-download ; From cc390dd53a5e87ff6f3a165bffe6e4ae4da66420 Mon Sep 17 00:00:00 2001 From: erg Date: Sun, 11 May 2008 18:26:59 -0500 Subject: [PATCH 4/7] refactor a bit --- extra/ftp/client/client.factor | 60 ++++++++++++++++++---------------- 1 file changed, 31 insertions(+), 29 deletions(-) diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor index f090a4da3e..3ae3b27f2f 100644 --- a/extra/ftp/client/client.factor +++ b/extra/ftp/client/client.factor @@ -55,41 +55,42 @@ SINGLETON: passive [ "\r\n" swap stream-write ] [ stream-flush ] tri ; -: ftp-command ( ftp-client string -- ftp-response ) - swap +: ftp-command ( string ftp-client -- ftp-response ) [ ftp-send ] [ ftp-read ] bi ; : ftp-user ( ftp-client -- ftp-response ) - dup user>> "USER " prepend ftp-command ; + [ user>> "USER " prepend ] [ ftp-command ] bi ; : ftp-password ( ftp-client -- ftp-response ) - dup password>> "PASS " prepend ftp-command ; + [ password>> "PASS " prepend ] [ ftp-command ] bi ; -: ftp-set-binary ( ftp-client -- ftp-response ) "TYPE I" ftp-command ; +: ftp-set-binary ( ftp-client -- ftp-response ) + >r "TYPE I" r> ftp-command ; : ftp-pwd ( ftp-client -- ftp-response ) - "PWD" ftp-command ; + >r "PWD" r> ftp-command ; : ftp-list ( ftp-client -- ftp-response ) - "LIST" ftp-command ; + >r "LIST" r> ftp-command ; : ftp-quit ( ftp-client -- ftp-response ) - "QUIT" ftp-command ; + >r "QUIT" r> ftp-command ; -: ftp-cwd ( ftp-client directory -- ftp-response ) - "CWD " prepend ftp-command ; +: ftp-cwd ( directory ftp-client -- ftp-response ) + >r "CWD " prepend r> ftp-command ; -: ftp-retr ( ftp-client filename -- ftp-response ) - "RETR " prepend ftp-command ; +: ftp-retr ( filename ftp-client -- ftp-response ) + >r "RETR " prepend r> ftp-command ; : parse-epsv ( ftp-response -- port ) strings>> first "|" split 2 tail* first string>number ; -: ftp-epsv ( ftp-client -- ftp-response ) "EPSV" ftp-command ; +: ftp-epsv ( ftp-client -- ftp-response ) + >r "EPSV" r> ftp-command ; M: ftp-client dispose ( ftp-client -- ) - [ "QUIT" ftp-command drop ] [ stream>> dispose ] bi ; + [ ftp-quit drop ] [ stream>> dispose ] bi ; ERROR: ftp-error got expected ; : ftp-assert ( ftp-response n -- ) @@ -109,28 +110,29 @@ ERROR: ftp-error got expected ; [ ftp-set-binary 200 ftp-assert ] } cleave ; +: start-2nd ( ftp-client -- port ) + ftp-epsv [ 229 ftp-assert ] [ parse-epsv ] bi ; + : list ( ftp-client -- ftp-response ) - dup ftp-epsv dup 229 ftp-assert - >r dup host>> r> parse-epsv ascii + dup [ host>> ] [ start-2nd ] bi ascii over ftp-list 150 ftp-assert lines swap >>strings >r ftp-read 226 ftp-assert r> ; -: ftp-get ( ftp-client filename -- ftp-response ) - over ftp-epsv dup 229 ftp-assert - pick host>> swap parse-epsv binary - swap tuck - [ dupd ftp-retr 150 ftp-assert ] +: ftp-get ( filename ftp-client -- ftp-response ) + dup [ host>> ] [ start-2nd ] bi binary + rot tuck + [ over ftp-retr 150 ftp-assert ] [ binary stream-copy ] 2bi* ftp-read dup 226 ftp-assert ; -GENERIC# ftp-download 1 ( obj path -- ) +GENERIC: ftp-download ( path obj -- ) -M: ftp-client ftp-download ( ftp-client path -- ) - >r dup ftp-login r> - [ parent-directory ftp-cwd drop ] - [ file-name ftp-get drop ] - [ drop dispose ] 2tri ; +M: ftp-client ftp-download ( path ftp-client -- ) + dup ftp-login + [ >r parent-directory r> ftp-cwd drop ] + [ >r file-name r> ftp-get drop ] + [ dispose drop ] 2tri ; -M: string ftp-download ( string path -- ) - >r r> ftp-download ; +M: string ftp-download ( path string -- ) + ftp-download ; From 8e3527f10b633d0722cbb86dcbd3f9a01bd62e2b Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 11 May 2008 19:38:22 -0400 Subject: [PATCH 5/7] Fixing tests for lisp --- extra/lisp/lisp-tests.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index ec376569f0..f2c1f59678 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -4,10 +4,6 @@ USING: lisp lisp.parser tools.test sequences math kernel ; IN: lisp.test -{ [ "aoeu" 2 1 T{ lisp-symbol f "foo" } ] } [ - "(foo 1 2 \"aoeu\")" lisp-string>factor -] unit-test - init-env "+" [ first2 + ] lisp-define From 89e6869da10a1dbbca5bfc6e880330e4a337aa41 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 11 May 2008 19:38:38 -0400 Subject: [PATCH 6/7] Cleaning up lisp --- extra/lisp/lisp.factor | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 7d4b9af02a..48b66418cd 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -38,15 +38,18 @@ DEFER: funcall PRIVATE> : split-lambda ( s-exp -- body vars ) - first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline + first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline -: rest-lambda-vars ( seq -- n newseq ) - "&rest" swap [ remove ] [ index ] 2bi ; +: rest-lambda ( body vars -- quot ) + "&rest" swap [ remove ] [ index ] 2bi + [ localize-lambda ] dip + [ , cut swap [ % , ] bake , with-locals compose ] bake ; + +: normal-lambda ( body vars -- quot ) + localize-lambda [ , with-locals compose ] bake ; : convert-lambda ( s-exp -- quot ) - split-lambda dup "&rest" swap member? [ rest-lambda-vars ] [ dup length ] if - [ localize-lambda ] dip - [ , cut [ dup length firstn ] dip dup empty? [ drop ] when , ] bake ; + split-lambda dup "&rest" swap member? [ rest-lambda ] [ normal-lambda ] if ; : convert-quoted ( s-exp -- quot ) second [ , ] bake ; @@ -64,10 +67,9 @@ PRIVATE> [ drop convert-general-form ] if ; : convert-form ( lisp-form -- quot ) - { { [ dup s-exp? ] [ body>> convert-list-form ] } - [ [ , ] [ ] make ] - } cond ; - + dup s-exp? [ body>> convert-list-form ] + [ [ , ] [ ] make ] if ; + : lisp-string>factor ( str -- quot ) lisp-expr parse-result-ast convert-form ; From f88a02b5c1f0c246e70f8053af11e332abf80739 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 11 May 2008 20:03:36 -0400 Subject: [PATCH 7/7] Don't need with-locals anymore, removing --- extra/lisp/lisp.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 48b66418cd..79071ce619 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -43,10 +43,10 @@ PRIVATE> : rest-lambda ( body vars -- quot ) "&rest" swap [ remove ] [ index ] 2bi [ localize-lambda ] dip - [ , cut swap [ % , ] bake , with-locals compose ] bake ; + [ , cut swap [ % , ] bake , compose ] bake ; : normal-lambda ( body vars -- quot ) - localize-lambda [ , with-locals compose ] bake ; + localize-lambda [ , compose ] bake ; : convert-lambda ( s-exp -- quot ) split-lambda dup "&rest" swap member? [ rest-lambda ] [ normal-lambda ] if ;