From 6260cd3e5afdbca83f7433b836de9ed4142a0e5c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 Feb 2008 14:53:18 -0600 Subject: [PATCH 01/36] Working on new HTTP server --- extra/assocs/lib/lib.factor | 9 +- extra/furnace/furnace.factor | 11 ++ extra/http/client/client-tests.factor | 26 ++- extra/http/client/client.factor | 120 ++++++------- extra/http/http-tests.factor | 99 ++++++++++- extra/http/http.factor | 241 ++++++++++++++++++++++++-- extra/http/server/server-tests.factor | 68 ++++---- extra/http/server/server.factor | 156 ++++++++++++----- 8 files changed, 566 insertions(+), 164 deletions(-) mode change 100644 => 100755 extra/http/http-tests.factor diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 182f04a367..88095759e6 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -16,13 +16,16 @@ IN: assocs.lib : at-default ( key assoc -- value/key ) dupd at [ nip ] when* ; +: replace-at ( assoc value key -- assoc ) + >r >r dup r> 1vector r> rot set-at ; + : insert-at ( value key assoc -- ) [ ?push ] change-at ; -: peek-at* ( key assoc -- obj ? ) - at* dup [ >r peek r> ] when ; +: peek-at* ( assoc key -- obj ? ) + swap at* dup [ >r peek r> ] when ; -: peek-at ( key assoc -- obj ) +: peek-at ( assoc key -- obj ) peek-at* drop ; : >multi-assoc ( assoc -- new-assoc ) diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 11ff697049..f10094f07b 100755 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -35,6 +35,17 @@ SYMBOL: current-action SYMBOL: validators-errored SYMBOL: validation-errors +: build-url ( str query-params -- newstr ) + [ + over % + dup assoc-empty? [ + 2drop + ] [ + CHAR: ? rot member? "&" "?" ? % + assoc>query % + ] if + ] "" make ; + : action-link ( query action -- url ) [ "/responder/" % diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index d2fb719acd..5e407657a8 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -1,14 +1,26 @@ -USING: http.client tools.test ; +USING: http.client http.client.private http tools.test +tuple-syntax namespaces ; [ "localhost" 80 ] [ "localhost" parse-host ] unit-test [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test -[ "localhost:8888" "/foo" ] [ "http://localhost:8888/foo" parse-url ] unit-test -[ "localhost:8888" "/" ] [ "http://localhost:8888" parse-url ] unit-test -[ 404 ] [ "HTTP/1.1 404 File not found" parse-response ] unit-test -[ 404 ] [ "404 File not found" parse-response ] unit-test -[ 200 ] [ "HTTP/1.0 200" parse-response ] unit-test -[ 200 ] [ "HTTP/1.0 200 Success" parse-response ] unit-test +[ "/foo" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test +[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test [ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test [ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test [ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test [ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test + +[ + TUPLE{ request + method: "GET" + host: "www.apple.com" + path: "/index.html" + port: 80 + } +] [ + [ + "http://www.apple.com/index.html" + + request-with-url + ] with-scope +] unit-test diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 99ba045019..8b74b6dc72 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -2,64 +2,73 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs http kernel math math.parser namespaces sequences io io.sockets io.streams.string io.files io.timeouts strings -splitting continuations assocs.lib calendar ; +splitting continuations assocs.lib calendar vectors hashtables +accessors ; IN: http.client -: parse-host ( url -- host port ) - #! Extract the host name and port number from an HTTP URL. - ":" split1 [ string>number ] [ 80 ] if* ; - -SYMBOL: domain - -: parse-url ( url -- host resource ) - dup "https://" head? [ - "ssl not yet supported: " swap append throw - ] when "http://" ?head drop +: parse-url ( url -- resource host port ) + "http://" ?head [ "Only http:// supported" throw ] unless "/" split1 [ "/" swap append ] [ "/" ] if* - >r dup empty? [ drop domain get ] [ dup domain set ] if r> ; + swap parse-host ; -: parse-response ( line -- code ) - "HTTP/" ?head [ " " split1 nip ] when - " " split1 drop string>number [ - "Premature end of stream" throw - ] unless* ; +r >>path r> dup [ query>assoc ] when >>query ; -: crlf "\r\n" write ; +! This is all pretty complex because it needs to handle +! HTTP redirects, which might be absolute or relative +: request-with-url ( url request -- request ) + clone dup "request" set + swap parse-url >r >r store-path r> >>host r> >>port ; -: http-request ( host resource method -- ) - write bl write " HTTP/1.0" write crlf - "Host: " write write crlf ; +DEFER: (http-request) -: get-request ( host resource -- ) - "GET" http-request crlf ; +: absolute-redirect ( url -- request ) + "request" get request-with-url ; -DEFER: http-get-stream +: relative-redirect ( path -- request ) + "request" get swap store-path ; -: do-redirect ( code headers stream -- code headers stream ) - #! Should this support Location: headers that are - #! relative URLs? - pick 100 /i 3 = [ - dispose "location" swap peek-at nip http-get-stream - ] when ; +: do-redirect ( response -- response stream ) + dup response-code 300 399 between? [ + header>> "location" peek-at + dup "http://" head? [ + absolute-redirect + ] [ + relative-redirect + ] if "GET" >>method (http-request) + ] [ + stdio get + ] if ; -: default-timeout 1 minutes over set-timeout ; +: (http-request) ( request -- response stream ) + dup host>> over port>> stdio set + write-request flush read-response + do-redirect ; -: http-get-stream ( url -- code headers stream ) - #! Opens a stream for reading from an HTTP URL. - parse-url over parse-host [ - [ [ get-request read-response ] with-stream* ] keep - default-timeout - ] [ ] [ dispose ] cleanup do-redirect ; +PRIVATE> + +: http-request ( url request -- response stream ) + [ + request-with-url + [ + (http-request) + 1 minutes over set-timeout + ] [ ] [ stdio get dispose ] cleanup + ] with-scope ; + +: ( -- request ) + request construct-empty + "GET" >>method ; + +: http-get-stream ( url -- response stream ) + http-request ; : success? ( code -- ? ) 200 = ; -: check-response ( code headers stream -- stream ) - nip swap success? +: check-response ( response stream -- stream ) + swap code>> success? [ dispose "HTTP download failed" throw ] unless ; : http-get ( url -- string ) @@ -70,23 +79,18 @@ DEFER: http-get-stream : download-to ( url file -- ) #! Downloads the contents of a URL to a file. - >r http-get-stream check-response - r> stream-copy ; + swap http-get-stream check-response + [ swap stream-copy ] with-disposal ; : download ( url -- ) dup download-name download-to ; -: post-request ( content-type content host resource -- ) - #! Note: It is up to the caller to url encode the content if - #! it is required according to the content-type. - "POST" http-request [ - "Content-Length: " write length number>string write crlf - "Content-Type: " write url-encode write crlf - crlf - ] keep write ; +: ( content-type content -- request ) + request construct-empty + "POST" >>method + swap >>post-data + swap >>post-data-type ; -: http-post ( content-type content url -- code headers string ) - #! Make a POST request. The content is URL encoded for you. - parse-url over parse-host [ - post-request flush read-response stdio get contents - ] with-stream ; +: http-post ( content-type content url -- response string ) + #! The content is URL encoded for you. + -rot url-encode http-request contents ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor old mode 100644 new mode 100755 index 5146502644..9fa593053c --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,4 +1,5 @@ -USING: http tools.test ; +USING: http tools.test multiline tuple-syntax +io.streams.string kernel arrays splitting sequences ; IN: temporary [ "hello%20world" ] [ "hello world" url-encode ] unit-test @@ -16,3 +17,99 @@ IN: temporary [ "%20%21%20" ] [ " ! " url-encode ] unit-test [ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test + +STRING: read-request-test-1 +GET http://foo/bar HTTP/1.1 +Some-Header: 1 +Some-Header: 2 +Content-Length: 4 + +blah +; + +[ + TUPLE{ request + method: "GET" + path: "bar" + query: f + version: "1.1" + header: H{ { "some-header" V{ "1" "2" } } { "content-length" V{ "4" } } } + post-data: "blah" + } +] [ + read-request-test-1 [ + read-request + ] with-string-reader +] unit-test + +STRING: read-request-test-1' +GET bar HTTP/1.1 +content-length: 4 +some-header: 1 +some-header: 2 + +blah +; + +read-request-test-1' 1array [ + read-request-test-1 + [ read-request ] with-string-reader + [ write-request ] with-string-writer + ! normalize crlf + string-lines "\n" join +] unit-test + +STRING: read-request-test-2 +HEAD http://foo/bar HTTP/1.0 +Host: www.sex.com +; + +[ + TUPLE{ request + method: "HEAD" + path: "bar" + query: f + version: "1.0" + header: H{ { "host" V{ "www.sex.com" } } } + host: "www.sex.com" + } +] [ + read-request-test-2 [ + read-request + ] with-string-reader +] unit-test + +STRING: read-response-test-1 +HTTP/1.0 404 not found +Content-Type: text/html + +blah +; + +[ + TUPLE{ response + version: "1.0" + code: 404 + message: "not found" + header: H{ { "content-type" V{ "text/html" } } } + } +] [ + read-response-test-1 + [ read-response ] with-string-reader +] unit-test + + +STRING: read-response-test-1' +HTTP/1.0 404 not found +content-type: text/html + + +; + +read-response-test-1' 1array [ + read-response-test-1 + [ read-response ] with-string-reader + [ write-response ] with-string-writer + ! normalize crlf + string-lines "\n" join +] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 5c4dae94c7..4c2834b7ca 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -1,19 +1,34 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: hashtables io kernel math namespaces math.parser assocs -sequences strings splitting ascii io.encodings.utf8 assocs.lib -namespaces unicode.case ; +USING: hashtables io io.streams.string kernel math namespaces +math.parser assocs sequences strings splitting ascii +io.encodings.utf8 assocs.lib namespaces unicode.case combinators +vectors sorting new-slots accessors calendar ; IN: http +: http-port 80 ; inline + +: crlf "\r\n" write ; + : header-line ( line -- ) ": " split1 dup [ swap >lower insert ] [ 2drop ] if ; -: (read-header) ( -- ) +: read-header-line ( -- ) readln dup - empty? [ drop ] [ header-line (read-header) ] if ; + empty? [ drop ] [ header-line read-header-line ] if ; -: read-header ( -- hash ) - [ (read-header) ] H{ } make-assoc ; +: read-header ( -- multi-assoc ) + [ read-header-line ] H{ } make-assoc ; + +: write-header ( multi-assoc -- ) + >alist sort-keys + [ + swap write ": " write { + { [ dup number? ] [ number>string ] } + { [ dup timestamp? ] [ timestamp>http-string ] } + { [ dup string? ] [ ] } + } cond write crlf + ] multi-assoc-each crlf ; : url-quotable? ( ch -- ? ) #! In a URL, can this character be used without @@ -23,7 +38,7 @@ IN: http over digit? or swap "/_-." member? or ; foldable -: push-utf8 ( string -- ) +: push-utf8 ( ch -- ) 1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; : url-encode ( str -- str ) @@ -58,17 +73,205 @@ IN: http : url-decode ( str -- str ) [ 0 swap url-decode-iter ] "" make decode-utf8 ; -: hash>query ( hash -- str ) +: query>assoc ( query -- assoc ) + dup [ + "&" split [ + "=" split1 [ dup [ url-decode ] when ] 2apply + ] H{ } map>assoc + ] when ; + +: assoc>query ( hash -- str ) [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map "&" join ; -: build-url ( str query-params -- newstr ) +TUPLE: request +host +port +method +path +query +version +header +post-data +post-data-type ; + +: + request construct-empty + "1.0" >>version + http-port >>port ; + +: url>path ( url -- path ) + url-decode "http://" ?head + [ "/" split1 "" or nip ] [ "/" ?head drop ] if ; + +: read-method ( request -- request ) + " " read-until [ "Bad request: method" throw ] unless + >>method ; + +: read-query ( request -- request ) + " " read-until + [ "Bad request: query params" throw ] unless + query>assoc >>query ; + +: read-url ( request -- request ) + " ?" read-until { + { CHAR: \s [ dup empty? [ drop read-url ] [ url>path >>path ] if ] } + { CHAR: ? [ url>path >>path read-query ] } + [ "Bad request: URL" throw ] + } case ; + +: parse-version ( string -- version ) + "HTTP/" ?head [ "Bad version" throw ] unless + dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ; + +: read-request-version ( request -- request ) + readln [ CHAR: \s = ] left-trim + parse-version + >>version ; + +: read-request-header ( request -- request ) + read-header >>header ; + +SYMBOL: max-post-request + +1024 256 * max-post-request set-global + +: content-length ( header -- n ) + "content-length" peek-at string>number dup [ + dup max-post-request get > [ + "content-length > max-post-request" throw + ] when + ] when ; + +: read-post-data ( request -- request ) + dup header>> content-length [ read >>post-data ] when* ; + +: parse-host ( string -- host port ) + "." ?tail drop ":" split1 + [ string>number ] [ http-port ] if* ; + +: extract-host ( request -- request ) + dup header>> "host" peek-at parse-host >r >>host r> >>port ; + +: extract-post-data-type ( request -- request ) + dup header>> "content-type" peek-at >>post-data-type ; + +: read-request ( -- request ) + + read-method + read-url + read-request-version + read-request-header + read-post-data + extract-host + extract-post-data-type ; + +: write-method ( request -- request ) + dup method>> write bl ; + +: write-url ( request -- request ) + dup path>> url-encode write + dup query>> dup assoc-empty? [ drop ] [ + "?" write + assoc>query write + ] if ; + +: write-request-url ( request -- request ) + write-url bl ; + +: write-version ( request -- request ) + "HTTP/" write dup request-version write crlf ; + +: write-request-header ( request -- request ) + dup header>> >hashtable + over host>> [ "host" replace-at ] when* + over post-data>> [ length "content-length" replace-at ] when* + over post-data-type>> [ "content-type" replace-at ] when* + write-header ; + +: write-post-data ( request -- request ) + dup post-data>> [ write ] when* ; + +: write-request ( request -- ) + write-method + write-url + write-version + write-request-header + write-post-data + flush + drop ; + +: request-url ( request -- url ) [ - over % - dup assoc-empty? [ - 2drop - ] [ - CHAR: ? rot member? "&" "?" ? % - hash>query % - ] if - ] "" make ; + dup host>> [ + "http://" write + dup host>> url-encode write + ":" write + dup port>> number>string write + ] when + "/" write + write-url + drop + ] with-string-writer ; + +TUPLE: response +version +code +message +header ; + +: + response construct-empty + "1.0" >>version + H{ } clone >>header ; + +: read-response-version + " " read-until + [ "Bad response: version" throw ] unless + parse-version + >>version ; + +: read-response-code + " " read-until [ "Bad response: code" throw ] unless + string>number [ "Bad response: code" throw ] unless* + >>code ; + +: read-response-message + readln >>message ; + +: read-response-header + read-header >>header ; + +: read-response ( -- response ) + + read-response-version + read-response-code + read-response-message + read-response-header ; + +: write-response-version ( response -- response ) + "HTTP/" write + dup version>> write bl ; + +: write-response-code ( response -- response ) + dup code>> number>string write bl ; + +: write-response-message ( response -- response ) + dup message>> write crlf ; + +: write-response-header ( response -- response ) + dup header>> write-header ; + +: write-response ( respose -- ) + write-response-version + write-response-code + write-response-message + write-response-header + flush + drop ; + +: set-response-header ( response value key -- response ) + pick header>> -rot replace-at drop ; + +: set-content-type ( response content-type -- response ) + "content-type" set-response-header ; diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index 18edd94f12..a67d21a640 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -1,39 +1,45 @@ -USING: webapps.file http.server.responders http -http.server namespaces io tools.test strings io.server -logging ; +USING: http.server tools.test kernel namespaces accessors +new-slots assocs.lib io http math sequences ; IN: temporary -[ ] [ f [ "404 not found" httpd-error ] with-logging ] unit-test +TUPLE: mock-responder ; -[ "inspect/global" ] [ "/inspect/global" trim-/ ] unit-test +: ( path -- responder ) + mock-responder construct-delegate ; -[ "index.html" ] -[ "http://www.jedit.org/index.html" url>path ] unit-test +M: mock-responder do-responder + 2nip + path>> on + [ "Hello world" print ] + "text/plain" ; -[ "foo/bar" ] -[ "http://www.jedit.org/foo/bar" url>path ] unit-test +: check-dispatch ( tag path -- ? ) + over off + swap default-host get call-responder + write-response call get ; -[ "" ] -[ "http://www.jedit.org/" url>path ] unit-test +[ + "" + "foo" add-responder + "bar" add-responder + "baz/" + "123" add-responder + "default" >>default + add-responder + default-host set -[ "" ] -[ "http://www.jedit.org" url>path ] unit-test + [ t ] [ "foo" "foo" check-dispatch ] unit-test + [ f ] [ "foo" "bar" check-dispatch ] unit-test + [ t ] [ "bar" "bar" check-dispatch ] unit-test + [ t ] [ "default" "baz/xxx" check-dispatch ] unit-test + [ t ] [ "123" "baz/123" check-dispatch ] unit-test -[ "foobar" ] -[ "foobar" secure-path ] unit-test - -[ f ] -[ "foobar/../baz" secure-path ] unit-test - -[ ] [ f [ "GET ../index.html" parse-request ] with-logging ] unit-test -[ ] [ f [ "POO" parse-request ] with-logging ] unit-test - -[ H{ { "Foo" "Bar" } } ] [ "Foo=Bar" query>hash ] unit-test - -[ H{ { "Foo" "Bar" } { "Baz" "Quux" } } ] -[ "Foo=Bar&Baz=Quux" query>hash ] unit-test - -[ H{ { "Baz" " " } } ] -[ "Baz=%20" query>hash ] unit-test - -[ H{ { "Foo" f } } ] [ "Foo" query>hash ] unit-test + [ t ] [ + + "baz" >>path + "baz" default-host get call-responder + dup code>> 300 399 between? >r + header>> "location" peek-at "baz/" tail? r> and + nip + ] unit-test +] with-scope diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index a2f5c3474b..e06ae6a95c 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -1,65 +1,131 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel namespaces io io.timeouts strings splitting -threads http http.server.responders sequences prettyprint -io.server logging calendar ; - +threads http sequences prettyprint io.server logging calendar +new-slots html.elements accessors math.parser combinators.lib ; IN: http.server -: (url>path) ( uri -- path ) - url-decode "http://" ?head [ - "/" split1 dup "" ? nip - ] when ; +TUPLE: responder path directory ; -: url>path ( uri -- path ) - "?" split1 dup [ - >r (url>path) "?" r> 3append - ] [ - drop (url>path) - ] if ; +: ( path -- responder ) + "/" ?tail responder construct-boa ; -: secure-path ( path -- path ) - ".." over subseq? [ drop f ] when ; +GENERIC: do-responder ( request path responder -- quot response ) -: request-method ( cmd -- method ) - H{ - { "GET" "get" } - { "POST" "post" } - { "HEAD" "head" } - } at "bad" or ; +TUPLE: trivial-responder quot response ; -: (handle-request) ( arg cmd -- method path host ) - request-method dup "method" set swap - prepare-url prepare-header host ; +: ( quot response -- responder ) + trivial-responder construct-boa + "" over set-delegate ; -: handle-request ( arg cmd -- ) - [ (handle-request) serve-responder ] with-scope ; +M: trivial-responder do-responder + 2nip dup quot>> swap response>> ; -: parse-request ( request -- ) - " " split1 dup [ - " HTTP" split1 drop url>path secure-path dup [ - swap handle-request - ] [ - 2drop bad-request - ] if - ] [ - 2drop bad-request - ] if ; +: trivial-response-body ( code message -- ) + + +

swap number>string write bl write

+ + ; -\ parse-request NOTICE add-input-logging +: ( code message -- quot response ) + [ [ trivial-response-body ] 2curry ] 2keep + "text/html" set-content-type + swap >>message + swap >>code ; + +: <404> ( -- quot response ) + 404 "Not Found" ; + +: ( to code message -- quot response ) + + rot "location" set-response-header ; + +: ( to -- quot response ) + 301 "Moved Permanently" ; + +: ( to -- quot response ) + 307 "Temporary Redirect" ; + +: ( content-type -- response ) + + 200 >>code + swap set-content-type ; + +TUPLE: dispatcher responders default ; + +: responder-matches? ( path responder -- ? ) + path>> head? ; + +TUPLE: no-/-responder ; + +M: no-/-responder do-responder + 2drop + dup path>> "/" append >>path + request-url ; + +: ( -- responder ) + "" no-/-responder construct-delegate ; + + no-/-responder set-global + +: find-responder ( path dispatcher -- path responder ) + >r "/" ?head drop r> + [ responders>> [ dupd responder-matches? ] find nip ] keep + default>> or [ path>> ?head drop ] keep ; + +: no-trailing-/ ( path responder -- path responder ) + over empty? over directory>> and + [ drop no-/-responder get-global ] when ; + +: call-responder ( request path responder -- quot response ) + no-trailing-/ do-responder ; + +SYMBOL: 404-responder + +<404> 404-responder set-global + +M: dispatcher do-responder + find-responder call-responder ; + +: ( path -- dispatcher ) + + dispatcher construct-delegate + 404-responder get-global >>default + V{ } clone >>responders ; + +: add-responder ( dispatcher responder -- dispatcher ) + over responders>> push ; + +SYMBOL: virtual-hosts +SYMBOL: default-host + +virtual-hosts global [ drop H{ } clone ] cache drop +default-host global [ drop 404-responder ] cache drop + +: find-virtual-host ( host -- responder ) + virtual-hosts get at [ default-host get ] unless* ; + +: handle-request ( request -- ) + [ + dup path>> over host>> find-virtual-host + call-responder + write-response + ] keep method>> "HEAD" = [ drop ] [ call ] if ; + +: default-timeout 1 minutes stdio get set-timeout ; + +LOG: httpd-hit NOTICE + +: log-request ( request -- ) + { method>> host>> path>> } map-exec-with httpd-hit ; : httpd ( port -- ) internet-server "http.server" [ - 1 minutes stdio get set-timeout - readln [ parse-request ] when* + default-timeout + read-request dup log-request handle-request ] with-server ; : httpd-main ( -- ) 8888 httpd ; MAIN: httpd-main - -! Load default webapps -USE: webapps.file -USE: webapps.callback -USE: webapps.continuation -USE: webapps.cgi From a2aa718cd4ac97a7856cce886adf482cff7c66c1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 Feb 2008 15:40:40 -0600 Subject: [PATCH 02/36] Remove obsolete vocab --- extra/http/server/responders/authors.txt | 1 - .../http/server/responders/responders.factor | 225 ------------------ 2 files changed, 226 deletions(-) delete mode 100755 extra/http/server/responders/authors.txt delete mode 100755 extra/http/server/responders/responders.factor diff --git a/extra/http/server/responders/authors.txt b/extra/http/server/responders/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/http/server/responders/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor deleted file mode 100755 index e4e0e257c4..0000000000 --- a/extra/http/server/responders/responders.factor +++ /dev/null @@ -1,225 +0,0 @@ -! Copyright (C) 2004, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs hashtables html html.elements splitting -http io kernel math math.parser namespaces parser sequences -strings io.server vectors assocs.lib logging ; - -IN: http.server.responders - -! Variables -SYMBOL: vhosts -SYMBOL: responders - -: >header ( value key -- multi-hash ) - H{ } clone [ insert-at ] keep ; - -: print-header ( alist -- ) - [ swap write ": " write print ] multi-assoc-each nl ; - -: response ( msg -- ) "HTTP/1.0 " write print ; - -: error-body ( error -- ) -

write

; - -: error-head ( error -- ) - response - H{ { "Content-Type" V{ "text/html" } } } print-header nl ; - -: httpd-error ( error -- ) - #! This must be run from handle-request - dup error-head - "head" "method" get = [ drop ] [ error-body ] if ; - -\ httpd-error ERROR add-error-logging - -: bad-request ( -- ) - [ - ! Make httpd-error print a body - "get" "method" set - "400 Bad request" httpd-error - ] with-scope ; - -: serving-content ( mime -- ) - "200 Document follows" response - "Content-Type" >header print-header ; - -: serving-html "text/html" serving-content ; - -: serve-html ( quot -- ) - serving-html with-html-stream ; - -: serving-text "text/plain" serving-content ; - -: redirect ( to response -- ) - response "Location" >header print-header ; - -: permanent-redirect ( to -- ) - "301 Moved Permanently" redirect ; - -: temporary-redirect ( to -- ) - "307 Temporary Redirect" redirect ; - -: directory-no/ ( -- ) - [ - "request" get % CHAR: / , - "raw-query" get [ CHAR: ? , % ] when* - ] "" make permanent-redirect ; - -: query>hash ( query -- hash ) - dup [ - "&" split [ - "=" split1 [ dup [ url-decode ] when ] 2apply 2array - ] map - ] when >hashtable ; - -SYMBOL: max-post-request - -1024 256 * max-post-request set-global - -: content-length ( header -- n ) - "Content-Length" swap at string>number dup [ - dup max-post-request get > [ - "Content-Length > max-post-request" throw - ] when - ] when ; - -: read-post-request ( header -- str hash ) - content-length [ read dup query>hash ] [ f f ] if* ; - -LOG: log-headers DEBUG - -: interesting-headers ( assoc -- string ) - [ - [ - drop { - "user-agent" - "referer" - "x-forwarded-for" - "host" - } member? - ] assoc-subset [ - ": " swap 3append % "\n" % - ] multi-assoc-each - ] "" make ; - -: prepare-url ( url -- url ) - #! This is executed in the with-request namespace. - "?" split1 - dup "raw-query" set query>hash "query" set - dup "request" set ; - -: prepare-header ( -- ) - read-header - dup "header" set - dup interesting-headers log-headers - read-post-request "response" set "raw-response" set ; - -! Responders are called in a new namespace with these -! variables: - -! - method -- one of get, post, or head. -! - request -- the entire URL requested, including responder -! name -! - responder-url -- the component of the URL for the responder -! - raw-query -- raw query string -! - query -- a hashtable of query parameters, eg -! foo.bar?a=b&c=d becomes -! H{ { "a" "b" } { "c" "d" } } -! - header -- a hashtable of headers from the user's client -! - response -- a hashtable of the POST request response -! - raw-response -- raw POST request response - -: query-param ( key -- value ) "query" get at ; - -: header-param ( key -- value ) - "header" get peek-at ; - -: host ( -- string ) - #! The host the current responder was called from. - "Host" header-param ":" split1 drop ; - -: add-responder ( responder -- ) - #! Add a responder object to the list. - "responder" over at responders get set-at ; - -: make-responder ( quot -- ) - #! quot has stack effect ( url -- ) - [ - [ - drop "GET method not implemented" httpd-error - ] "get" set - [ - drop "POST method not implemented" httpd-error - ] "post" set - [ - drop "HEAD method not implemented" httpd-error - ] "head" set - [ - drop bad-request - ] "bad" set - - call - ] H{ } make-assoc add-responder ; - -: add-simple-responder ( name quot -- ) - [ - [ drop ] swap append dup "get" set "post" set - "responder" set - ] make-responder ; - -: vhost ( name -- vhost ) - vhosts get at [ "default" vhost ] unless* ; - -: responder ( name -- responder ) - responders get at [ "404" responder ] unless* ; - -: set-default-responder ( name -- ) - responder "default" responders get set-at ; - -: call-responder ( method argument responder -- ) - over "argument" set [ swap get with-scope ] bind ; - -: serve-default-responder ( method url -- ) - "/" "responder-url" set - "default" responder call-responder ; - -: trim-/ ( url -- url ) - #! Trim a leading /, if there is one. - "/" ?head drop ; - -: serve-explicit-responder ( method url -- ) - "/" split1 - "/responder/" pick "/" 3append "responder-url" set - dup [ - swap responder call-responder - ] [ - ! Just a responder name by itself - drop "request" get "/" append permanent-redirect 2drop - ] if ; - -: serve-responder ( method path host -- ) - #! Responder paths come in two forms: - #! /foo/bar... - default responder used - #! /responder/foo/bar - responder foo, argument bar - vhost [ - trim-/ "responder/" ?head [ - serve-explicit-responder - ] [ - serve-default-responder - ] if - ] bind ; - -\ serve-responder DEBUG add-input-logging - -: no-such-responder ( -- ) - "404 No such responder" httpd-error ; - -! create a responders hash if it doesn't already exist -global [ - responders [ H{ } assoc-like ] change - - ! 404 error message pages are served by this guy - "404" [ no-such-responder ] add-simple-responder - - H{ } clone "default" associate vhosts set -] bind From cc3f226cd39823e6cb548b77fc6d2b4d3eada1a6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 29 Feb 2008 00:57:38 -0600 Subject: [PATCH 03/36] New HTTPD work in progress --- extra/http/basic-authentication/authors.txt | 1 - .../basic-authentication-docs.factor | 69 ----- .../basic-authentication-tests.factor | 66 ----- .../basic-authentication.factor | 65 ----- extra/http/basic-authentication/summary.txt | 1 - extra/http/basic-authentication/tags.txt | 1 - extra/http/client/client-tests.factor | 2 + extra/http/client/client.factor | 11 +- extra/http/http-tests.factor | 33 ++- extra/http/http.factor | 239 ++++++++++++++---- extra/http/mime/mime.factor | 1 + .../server/authentication/basic/basic.factor | 50 ++++ extra/http/server/callbacks/callbacks.factor | 170 +++++++++++++ extra/http/server/cgi/cgi.factor | 65 +++++ extra/http/server/server-tests.factor | 38 +-- extra/http/server/server.factor | 133 +++++----- extra/http/server/sessions/authors.txt | 1 + .../server/sessions/sessions-tests.factor | 32 +++ extra/http/server/sessions/sessions.factor | 112 ++++++++ extra/http/server/static/static.factor | 95 +++++++ .../http/server/templating/templating.factor | 17 +- extra/webapps/cgi/authors.txt | 1 - extra/webapps/cgi/cgi.factor | 75 ------ extra/webapps/file/authors.txt | 1 - extra/webapps/file/file.factor | 136 ---------- extra/webapps/source/authors.txt | 1 - extra/webapps/source/source.factor | 35 --- .../code2html/responder/responder.factor | 15 ++ 28 files changed, 864 insertions(+), 602 deletions(-) delete mode 100644 extra/http/basic-authentication/authors.txt delete mode 100644 extra/http/basic-authentication/basic-authentication-docs.factor delete mode 100644 extra/http/basic-authentication/basic-authentication-tests.factor delete mode 100644 extra/http/basic-authentication/basic-authentication.factor delete mode 100644 extra/http/basic-authentication/summary.txt delete mode 100644 extra/http/basic-authentication/tags.txt mode change 100644 => 100755 extra/http/mime/mime.factor create mode 100755 extra/http/server/authentication/basic/basic.factor create mode 100755 extra/http/server/callbacks/callbacks.factor create mode 100755 extra/http/server/cgi/cgi.factor create mode 100755 extra/http/server/sessions/authors.txt create mode 100755 extra/http/server/sessions/sessions-tests.factor create mode 100755 extra/http/server/sessions/sessions.factor create mode 100755 extra/http/server/static/static.factor delete mode 100755 extra/webapps/cgi/authors.txt delete mode 100755 extra/webapps/cgi/cgi.factor delete mode 100755 extra/webapps/file/authors.txt delete mode 100755 extra/webapps/file/file.factor delete mode 100755 extra/webapps/source/authors.txt delete mode 100755 extra/webapps/source/source.factor create mode 100755 extra/xmode/code2html/responder/responder.factor diff --git a/extra/http/basic-authentication/authors.txt b/extra/http/basic-authentication/authors.txt deleted file mode 100644 index 44b06f94bc..0000000000 --- a/extra/http/basic-authentication/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/http/basic-authentication/basic-authentication-docs.factor b/extra/http/basic-authentication/basic-authentication-docs.factor deleted file mode 100644 index 68d6e6bf1d..0000000000 --- a/extra/http/basic-authentication/basic-authentication-docs.factor +++ /dev/null @@ -1,69 +0,0 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax crypto.sha2 ; -IN: http.basic-authentication - -HELP: realms -{ $description - "A hashtable mapping a basic authentication realm (a string) " - "to either a quotation or a hashtable. The quotation has " - "stack effect ( username sha-256-string -- bool ). It " - "is expected to perform the user authentication when called." $nl - "If the realm maps to a hashtable then the hashtable should be a " - "mapping of usernames to sha-256 hashed passwords." $nl - "If the 'realms' variable does not exist in the current scope then " - "authentication will always fail." } -{ $see-also add-realm with-basic-authentication } ; - -HELP: add-realm -{ $values - { "data" "a quotation or a hashtable" } { "name" "a string" } } -{ $description - "Adds the authentication data to the " { $link realms } ". 'data' can be " - "a quotation with stack effect ( username sha-256-string -- bool ) or " - "a hashtable mapping username strings to sha-256-string passwords." } -{ $examples - { $code "H{ { \"admin\" \"...\" } { \"user\" \"...\" } } \"my-realm\" add-realm" } - { $code "[ \"...\" = swap \"admin\" = and ] \"my-realm\" add-realm" } -} -{ $see-also with-basic-authentication realms } ; - -HELP: with-basic-authentication -{ $values - { "realm" "a string" } { "quot" "a quotation with stack effect ( -- )" } } -{ $description - "Checks if the HTTP request has the correct authorisation headers " - "for basic authentication within the named realm. If the headers " - "are not present then a '401' HTTP response results from the " - "request, otherwise the quotation is called." } -{ $examples -{ $code "\"my-realm\" [\n serving-html \"Success!\" write\n] with-basic-authentication" } } -{ $see-also add-realm realms } - ; - -ARTICLE: { "http-authentication" "basic-authentication" } "Basic Authentication" -"The Basic Authentication system provides a simple browser based " -"authentication method to web applications. When the browser requests " -"a resource protected with basic authentication the server responds with " -"a '401' response code which means the user is unauthorized." -$nl -"When the browser receives this it prompts the user for a username and " -"password. This is sent back to the server in a special HTTP header. The " -"server then checks this against its authentication information and either " -"accepts or rejects the users request." -$nl -"Authentication is split up into " { $link realms } ". Each realm can have " -"a different database of username and password information. A responder can " -"require basic authentication by using the " { $link with-basic-authentication } " word." -$nl -"Username and password information can be maintained using " { $link realms } " and " { $link add-realm } "." -$nl -"All passwords on the server should be stored as sha-256 strings generated with the " { $link string>sha-256-string } " word." -$nl -"Note that Basic Authentication itself is insecure in that it " -"sends the username and password as clear text (although it is " -"base64 encoded this is not much help). To prevent eavesdropping " -"it is best to use Basic Authentication with SSL." ; - -IN: http.basic-authentication -ABOUT: { "http-authentication" "basic-authentication" } diff --git a/extra/http/basic-authentication/basic-authentication-tests.factor b/extra/http/basic-authentication/basic-authentication-tests.factor deleted file mode 100644 index 318123b0b4..0000000000 --- a/extra/http/basic-authentication/basic-authentication-tests.factor +++ /dev/null @@ -1,66 +0,0 @@ -! Copyright (c) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel crypto.sha2 http.basic-authentication tools.test - namespaces base64 sequences ; - -{ t } [ - [ - H{ } clone realms set - H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm - "test-realm" "Basic " "admin:passwordx" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm - "test-realm" "Basic " "xadmin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ t } [ - [ - H{ } clone realms set - [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm - "test-realm" "Basic " "xadmin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm - "test-realm" "Basic " "admin:xpassword" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - f realms set - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test diff --git a/extra/http/basic-authentication/basic-authentication.factor b/extra/http/basic-authentication/basic-authentication.factor deleted file mode 100644 index dfe04dc4b5..0000000000 --- a/extra/http/basic-authentication/basic-authentication.factor +++ /dev/null @@ -1,65 +0,0 @@ -! Copyright (c) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel base64 http.server crypto.sha2 namespaces assocs - quotations hashtables combinators splitting sequences - http.server.responders io html.elements ; -IN: http.basic-authentication - -! 'realms' is a hashtable mapping a realm (a string) to -! either a quotation or a hashtable. The quotation -! has stack effect ( username sha-256-string -- bool ). -! It should perform the user authentication. 'sha-256-string' -! is the plain text password provided by the user passed through -! 'string>sha-256-string'. If 'realms' maps to a hashtable then -! it is a mapping of usernames to sha-256 hashed passwords. -! -! 'realms' can be set on a per vhost basis in the vhosts -! table. -! -! If there are no realms then authentication fails. -SYMBOL: realms - -: add-realm ( data name -- ) - #! Add the named realm to the realms table. - #! 'data' should be a hashtable or a quotation. - realms get [ H{ } clone dup realms set ] unless* - set-at ; - -: user-authorized? ( username password realm -- bool ) - realms get dup [ - at { - { [ dup quotation? ] [ call ] } - { [ dup hashtable? ] [ swapd at = ] } - { [ t ] [ 3drop f ] } - } cond - ] [ - 3drop drop f - ] if ; - -: authorization-ok? ( realm header -- bool ) - #! Given the realm and the 'Authorization' header, - #! authenticate the user. - dup [ - " " split dup first "Basic" = [ - second base64> ":" split first2 string>sha-256-string rot - user-authorized? - ] [ - 2drop f - ] if - ] [ - 2drop f - ] if ; - -: authentication-error ( realm -- ) - "401 Unauthorized" response - "Basic realm=\"" swap "\"" 3append "WWW-Authenticate" associate print-header - - "Username or Password is invalid" write - ; - -: with-basic-authentication ( realm quot -- ) - #! Check if the user is authenticated in the given realm - #! to run the specified quotation. If not, use Basic - #! Authentication to ask for authorization details. - over "authorization" header-param authorization-ok? - [ nip call ] [ drop authentication-error ] if ; diff --git a/extra/http/basic-authentication/summary.txt b/extra/http/basic-authentication/summary.txt deleted file mode 100644 index 60cef7e630..0000000000 --- a/extra/http/basic-authentication/summary.txt +++ /dev/null @@ -1 +0,0 @@ -HTTP Basic Authentication implementation diff --git a/extra/http/basic-authentication/tags.txt b/extra/http/basic-authentication/tags.txt deleted file mode 100644 index c0772185a0..0000000000 --- a/extra/http/basic-authentication/tags.txt +++ /dev/null @@ -1 +0,0 @@ -web diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index 5e407657a8..4fca1697a5 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -16,6 +16,8 @@ tuple-syntax namespaces ; host: "www.apple.com" path: "/index.html" port: 80 + version: "1.1" + cookies: V{ } } ] [ [ diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 8b74b6dc72..1c408e44e3 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs http kernel math math.parser namespaces sequences io io.sockets io.streams.string io.files io.timeouts strings -splitting continuations assocs.lib calendar vectors hashtables +splitting continuations calendar vectors hashtables accessors ; IN: http.client @@ -32,7 +32,7 @@ DEFER: (http-request) : do-redirect ( response -- response stream ) dup response-code 300 399 between? [ - header>> "location" peek-at + header>> "location" swap at dup "http://" head? [ absolute-redirect ] [ @@ -44,7 +44,7 @@ DEFER: (http-request) : (http-request) ( request -- response stream ) dup host>> over port>> stdio set - write-request flush read-response + dup "r" set-global write-request flush read-response do-redirect ; PRIVATE> @@ -59,8 +59,7 @@ PRIVATE> ] with-scope ; : ( -- request ) - request construct-empty - "GET" >>method ; + "GET" >>method ; : http-get-stream ( url -- response stream ) http-request ; @@ -86,7 +85,7 @@ PRIVATE> dup download-name download-to ; : ( content-type content -- request ) - request construct-empty + "POST" >>method swap >>post-data swap >>post-data-type ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 9fa593053c..681ebd97e2 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -29,12 +29,14 @@ blah [ TUPLE{ request + port: 80 method: "GET" path: "bar" - query: f + query: H{ } version: "1.1" - header: H{ { "some-header" V{ "1" "2" } } { "content-length" V{ "4" } } } + header: H{ { "some-header" "1; 2" } { "content-length" "4" } } post-data: "blah" + cookies: V{ } } ] [ read-request-test-1 [ @@ -45,8 +47,7 @@ blah STRING: read-request-test-1' GET bar HTTP/1.1 content-length: 4 -some-header: 1 -some-header: 2 +some-header: 1; 2 blah ; @@ -60,18 +61,20 @@ read-request-test-1' 1array [ ] unit-test STRING: read-request-test-2 -HEAD http://foo/bar HTTP/1.0 +HEAD http://foo/bar HTTP/1.1 Host: www.sex.com ; [ TUPLE{ request + port: 80 method: "HEAD" path: "bar" - query: f - version: "1.0" - header: H{ { "host" V{ "www.sex.com" } } } + query: H{ } + version: "1.1" + header: H{ { "host" "www.sex.com" } } host: "www.sex.com" + cookies: V{ } } ] [ read-request-test-2 [ @@ -80,7 +83,7 @@ Host: www.sex.com ] unit-test STRING: read-response-test-1 -HTTP/1.0 404 not found +HTTP/1.1 404 not found Content-Type: text/html blah @@ -88,10 +91,11 @@ blah [ TUPLE{ response - version: "1.0" + version: "1.1" code: 404 message: "not found" - header: H{ { "content-type" V{ "text/html" } } } + header: H{ { "content-type" "text/html" } } + cookies: V{ } } ] [ read-response-test-1 @@ -100,7 +104,7 @@ blah STRING: read-response-test-1' -HTTP/1.0 404 not found +HTTP/1.1 404 not found content-type: text/html @@ -113,3 +117,8 @@ read-response-test-1' 1array [ ! normalize crlf string-lines "\n" join ] unit-test + +[ t ] [ + "rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT" + dup parse-cookies unparse-cookies = +] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 4c2834b7ca..8686d87052 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -2,34 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: hashtables io io.streams.string kernel math namespaces math.parser assocs sequences strings splitting ascii -io.encodings.utf8 assocs.lib namespaces unicode.case combinators -vectors sorting new-slots accessors calendar ; +io.encodings.utf8 namespaces unicode.case combinators +vectors sorting new-slots accessors calendar calendar.format +quotations arrays ; IN: http : http-port 80 ; inline -: crlf "\r\n" write ; - -: header-line ( line -- ) - ": " split1 dup [ swap >lower insert ] [ 2drop ] if ; - -: read-header-line ( -- ) - readln dup - empty? [ drop ] [ header-line read-header-line ] if ; - -: read-header ( -- multi-assoc ) - [ read-header-line ] H{ } make-assoc ; - -: write-header ( multi-assoc -- ) - >alist sort-keys - [ - swap write ": " write { - { [ dup number? ] [ number>string ] } - { [ dup timestamp? ] [ timestamp>http-string ] } - { [ dup string? ] [ ] } - } cond write crlf - ] multi-assoc-each crlf ; - : url-quotable? ( ch -- ? ) #! In a URL, can this character be used without #! URL-encoding? @@ -73,6 +52,54 @@ IN: http : url-decode ( str -- str ) [ 0 swap url-decode-iter ] "" make decode-utf8 ; +: crlf "\r\n" write ; + +: add-header ( value key assoc -- ) + [ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ; + +: header-line ( line -- ) + dup first blank? [ + [ blank? ] left-trim + "last-header" get + "header" get + add-header + ] [ + ": " split1 dup [ + swap >lower dup "last-header" set + "header" get add-header + ] [ + 2drop + ] if + ] if ; + +: read-header-line ( -- ) + readln dup + empty? [ drop ] [ header-line read-header-line ] if ; + +: read-header ( -- assoc ) + H{ } clone [ + "header" [ read-header-line ] with-variable + ] keep ; + +: header-value>string ( value -- string ) + { + { [ dup number? ] [ number>string ] } + { [ dup timestamp? ] [ timestamp>http-string ] } + { [ dup string? ] [ ] } + { [ dup sequence? ] [ [ header-value>string ] map "; " join ] } + } cond ; + +: check-header-string ( str -- str ) + #! http://en.wikipedia.org/wiki/HTTP_Header_Injection + dup [ "\r\n" member? ] contains? + [ "Header injection attack" throw ] when ; + +: write-header ( assoc -- ) + >alist sort-keys [ + swap url-encode write ": " write + header-value>string check-header-string write crlf + ] assoc-each crlf ; + : query>assoc ( query -- assoc ) dup [ "&" split [ @@ -84,6 +111,50 @@ IN: http [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map "&" join ; +TUPLE: cookie name value path domain expires http-only ; + +: ( value name -- cookie ) + cookie construct-empty + swap >>name swap >>value ; + +: parse-cookies ( string -- seq ) + [ + f swap + + ";" split [ + [ blank? ] trim "=" split1 swap >lower { + { "expires" [ >>expires ] } + { "domain" [ >>domain ] } + { "path" [ >>path ] } + { "httponly" [ drop t >>http-only ] } + { "" [ drop ] } + [ dup , nip ] + } case + ] each + + drop + ] { } make ; + +: (unparse-cookie) ( key value -- ) + { + { [ dup f eq? ] [ 2drop ] } + { [ dup t eq? ] [ drop , ] } + { [ t ] [ "=" swap 3append , ] } + } cond ; + +: unparse-cookie ( cookie -- strings ) + [ + dup name>> >lower over value>> (unparse-cookie) + "path" over path>> (unparse-cookie) + "domain" over domain>> (unparse-cookie) + "expires" over expires>> (unparse-cookie) + "httponly" over http-only>> (unparse-cookie) + drop + ] { } make ; + +: unparse-cookies ( cookies -- string ) + [ unparse-cookie ] map concat "; " join ; + TUPLE: request host port @@ -93,12 +164,21 @@ query version header post-data -post-data-type ; +post-data-type +cookies ; : request construct-empty - "1.0" >>version - http-port >>port ; + "1.1" >>version + http-port >>port + H{ } clone >>query + V{ } clone >>cookies ; + +: query-param ( request key -- value ) + swap query>> at ; + +: set-query-param ( request value key -- request ) + pick query>> set-at ; : url>path ( url -- path ) url-decode "http://" ?head @@ -132,12 +212,15 @@ post-data-type ; : read-request-header ( request -- request ) read-header >>header ; +: header ( request/response key -- value ) + swap header>> at ; + SYMBOL: max-post-request 1024 256 * max-post-request set-global : content-length ( header -- n ) - "content-length" peek-at string>number dup [ + "content-length" swap at string>number dup [ dup max-post-request get > [ "content-length > max-post-request" throw ] when @@ -151,10 +234,13 @@ SYMBOL: max-post-request [ string>number ] [ http-port ] if* ; : extract-host ( request -- request ) - dup header>> "host" peek-at parse-host >r >>host r> >>port ; + dup "host" header parse-host >r >>host r> >>port ; : extract-post-data-type ( request -- request ) - dup header>> "content-type" peek-at >>post-data-type ; + dup "content-type" header >>post-data-type ; + +: extract-cookies ( request -- request ) + dup "cookie" header [ parse-cookies >>cookies ] when* ; : read-request ( -- request ) @@ -164,7 +250,8 @@ SYMBOL: max-post-request read-request-header read-post-data extract-host - extract-post-data-type ; + extract-post-data-type + extract-cookies ; : write-method ( request -- request ) dup method>> write bl ; @@ -184,9 +271,10 @@ SYMBOL: max-post-request : write-request-header ( request -- request ) dup header>> >hashtable - over host>> [ "host" replace-at ] when* - over post-data>> [ length "content-length" replace-at ] when* - over post-data-type>> [ "content-type" replace-at ] when* + over host>> [ "host" pick set-at ] when* + over post-data>> [ length "content-length" pick set-at ] when* + over post-data-type>> [ "content-type" pick set-at ] when* + over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when* write-header ; : write-post-data ( request -- request ) @@ -194,7 +282,7 @@ SYMBOL: max-post-request : write-request ( request -- ) write-method - write-url + write-request-url write-version write-request-header write-post-data @@ -209,30 +297,42 @@ SYMBOL: max-post-request ":" write dup port>> number>string write ] when - "/" write + dup path>> "/" head? [ "/" write ] unless write-url drop ] with-string-writer ; +: set-header ( request/response value key -- request/response ) + pick header>> set-at ; + +GENERIC: write-response ( response -- ) + +GENERIC: write-full-response ( request response -- ) + TUPLE: response version code message -header ; +header +cookies +body ; : response construct-empty - "1.0" >>version - H{ } clone >>header ; + "1.1" >>version + H{ } clone >>header + "close" "connection" set-header + now timestamp>http-string "date" set-header + V{ } clone >>cookies ; : read-response-version - " " read-until + " \t" read-until [ "Bad response: version" throw ] unless parse-version >>version ; : read-response-code - " " read-until [ "Bad response: code" throw ] unless + " \t" read-until [ "Bad response: code" throw ] unless string>number [ "Bad response: code" throw ] unless* >>code ; @@ -240,7 +340,8 @@ header ; readln >>message ; : read-response-header - read-header >>header ; + read-header >>header + dup "set-cookie" header [ parse-cookies >>cookies ] when* ; : read-response ( -- response ) @@ -260,9 +361,20 @@ header ; dup message>> write crlf ; : write-response-header ( response -- response ) - dup header>> write-header ; + dup header>> clone + over cookies>> f like + [ unparse-cookies "set-cookie" pick set-at ] when* + write-header ; -: write-response ( respose -- ) +: write-response-body ( response -- response ) + dup body>> { + { [ dup not ] [ drop ] } + { [ dup string? ] [ write ] } + { [ dup callable? ] [ call ] } + { [ t ] [ stdio get stream-copy ] } + } cond ; + +M: response write-response ( respose -- ) write-response-version write-response-code write-response-message @@ -270,8 +382,39 @@ header ; flush drop ; -: set-response-header ( response value key -- response ) - pick header>> -rot replace-at drop ; +M: response write-full-response ( request response -- ) + dup write-response + swap method>> "HEAD" = [ write-response-body ] unless ; -: set-content-type ( response content-type -- response ) - "content-type" set-response-header ; +: set-content-type ( request/response content-type -- request/response ) + "content-type" set-header ; + +: get-cookie ( request/response name -- cookie/f ) + >r cookies>> r> [ swap name>> = ] curry find nip ; + +: delete-cookie ( request/response name -- ) + over cookies>> >r get-cookie r> delete ; + +: put-cookie ( request/response cookie -- request/response ) + [ dupd name>> get-cookie [ dupd delete-cookie ] when* ] keep + over cookies>> push ; + +TUPLE: raw-response +version +code +message +body ; + +: ( -- response ) + raw-response construct-empty + "1.1" >>version ; + +M: raw-response write-response ( respose -- ) + write-response-version + write-response-code + write-response-message + write-response-body + drop ; + +M: raw-response write-full-response ( response -- ) + write-response nip ; diff --git a/extra/http/mime/mime.factor b/extra/http/mime/mime.factor old mode 100644 new mode 100755 index 3365127d87..f9097ecce3 --- a/extra/http/mime/mime.factor +++ b/extra/http/mime/mime.factor @@ -30,5 +30,6 @@ H{ { "pdf" "application/pdf" } { "factor" "text/plain" } + { "cgi" "application/x-cgi-script" } { "fhtml" "application/x-factor-server-page" } } "mime-types" set-global diff --git a/extra/http/server/authentication/basic/basic.factor b/extra/http/server/authentication/basic/basic.factor new file mode 100755 index 0000000000..b6dbed4b62 --- /dev/null +++ b/extra/http/server/authentication/basic/basic.factor @@ -0,0 +1,50 @@ +! Copyright (c) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.authentication.basic +USING: accessors new-slots quotations assocs kernel splitting +base64 crypto.sha2 html.elements io combinators http.server +http sequences ; + +! 'users' is a quotation or an assoc. The quotation +! has stack effect ( sha-256-string username -- ? ). +! It should perform the user authentication. 'sha-256-string' +! is the plain text password provided by the user passed through +! 'string>sha-256-string'. If 'users' is an assoc then +! it is a mapping of usernames to sha-256 hashed passwords. +TUPLE: realm responder name users ; + +C: realm + +: user-authorized? ( password username realm -- ? ) + users>> { + { [ dup callable? ] [ call ] } + { [ dup assoc? ] [ at = ] } + } cond ; + +: authorization-ok? ( realm header -- bool ) + #! Given the realm and the 'Authorization' header, + #! authenticate the user. + dup [ + " " split1 swap "Basic" = [ + base64> ":" split1 string>sha-256-string + spin user-authorized? + ] [ + 2drop f + ] if + ] [ + 2drop f + ] if ; + +: <401> ( realm -- response ) + 401 "Unauthorized" + "Basic realm=\"" rot name>> "\"" 3append + "WWW-Authenticate" set-header + [ + + "Username or Password is invalid" write + + ] >>body ; + +M: realm call-responder ( request path realm -- response ) + pick "authorization" header dupd authorization-ok? + [ responder>> call-responder ] [ 2nip <401> ] if ; diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor new file mode 100755 index 0000000000..a000a76040 --- /dev/null +++ b/extra/http/server/callbacks/callbacks.factor @@ -0,0 +1,170 @@ +! Copyright (C) 2004 Chris Double. +! Copyright (C) 2006, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: html http http.server io kernel math namespaces +continuations calendar sequences assocs new-slots hashtables +accessors arrays alarms quotations combinators ; +IN: http.server.callbacks + +SYMBOL: responder + +TUPLE: callback-responder responder callbacks ; + +: ( responder -- responder' ) + #! A continuation responder is a special type of session + #! manager. However it works entirely differently from + #! the URL and cookie session managers. + H{ } clone callback-responder construct-boa ; + +TUPLE: callback cont quot expires alarm responder ; + +: timeout 20 minutes ; + +: timeout-callback ( callback -- ) + dup alarm>> cancel-alarm + dup responder>> callbacks>> delete-at ; + +: touch-callback ( callback -- ) + dup expires>> [ + dup alarm>> [ cancel-alarm ] when* + dup [ timeout-callback ] curry timeout later >>alarm + ] when drop ; + +: ( cont quot expires? -- callback ) + [ f responder get callback construct-boa ] keep + [ dup touch-callback ] when ; + +: invoke-callback ( request exit-cont callback -- response ) + [ quot>> 3array ] keep cont>> continue-with ; + +: register-callback ( cont quot expires? -- id ) + + responder get callbacks>> generate-key + [ responder get callbacks>> set-at ] keep ; + +SYMBOL: exit-continuation + +: exit-with exit-continuation get continue-with ; + +: forward-to-url ( url -- * ) + #! When executed inside a 'show' call, this will force a + #! HTTP 302 to occur to instruct the browser to forward to + #! the request URL. + exit-with ; + +: cont-id "factorcontid" ; + +: id>url ( id -- url ) + request get clone + swap cont-id associate >>query + request-url ; + +: forward-to-id ( id -- * ) + #! When executed inside a 'show' call, this will force a + #! HTTP 302 to occur to instruct the browser to forward to + #! the request URL. + id>url forward-to-url ; + +: restore-request ( pair -- ) + first3 >r exit-continuation set request set r> call ; + +: resume-page ( request page responder callback -- * ) + dup touch-callback + >r 2drop exit-continuation get + r> invoke-callback ; + +SYMBOL: post-refresh-get? + +: redirect-to-here ( -- ) + #! Force a redirect to the client browser so that the browser + #! goes to the current point in the code. This forces an URL + #! change on the browser so that refreshing that URL will + #! immediately run from this code point. This prevents the + #! "this request will issue a POST" warning from the browser + #! and prevents re-running the previous POST logic. This is + #! known as the 'post-refresh-get' pattern. + post-refresh-get? get [ + [ + [ ] t register-callback forward-to-id + ] callcc1 restore-request + ] [ + post-refresh-get? on + ] if ; + +SYMBOL: current-show + +: store-current-show ( -- ) + #! Store the current continuation in the variable 'current-show' + #! so it can be returned to later by 'quot-id'. Note that it + #! recalls itself when the continuation is called to ensure that + #! it resets its value back to the most recent show call. + [ current-show set f ] callcc1 + [ restore-request store-current-show ] when* ; + +: show-final ( quot -- * ) + [ + >r store-current-show redirect-to-here r> call exit-with + ] with-scope ; inline + +M: callback-responder call-responder + [ + [ + exit-continuation set + dup responder set + pick request set + pick cont-id query-param over callbacks>> at [ + resume-page + ] [ + responder>> call-responder + "Continuation responder pages must use show-final" throw + ] if* + ] with-scope + ] callcc1 >r 3drop r> ; + +: show-page ( quot -- ) + [ + >r store-current-show redirect-to-here r> + [ + [ ] register-callback + call + exit-with + ] callcc1 restore-request + ] with-scope ; inline + +: quot-id ( quot -- id ) + current-show get swap t register-callback ; + +: quot-url ( quot -- url ) + quot-id id>url ; + +! SYMBOL: current-show +! +! : store-current-show ( -- ) +! #! Store the current continuation in the variable 'current-show' +! #! so it can be returned to later by href callbacks. Note that it +! #! recalls itself when the continuation is called to ensure that +! #! it resets its value back to the most recent show call. +! [ ( 0 -- ) +! [ ( 0 1 -- ) +! current-show set ( 0 -- ) +! continue +! ] callcc1 +! nip +! store-current-show +! ] callcc0 ; +! + +! +! : show-final ( quot -- * ) +! store-current-show +! redirect-to-here +! call +! exit-with ; inline +! +! : show-page ( quot -- request ) +! store-current-show redirect-to-here +! [ +! register-continuation +! call +! exit-with +! ] callcc1 restore-request ; inline diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor new file mode 100755 index 0000000000..9950a9a4a4 --- /dev/null +++ b/extra/http/server/cgi/cgi.factor @@ -0,0 +1,65 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces kernel assocs io.files combinators +arrays io.launcher io http.server.static http.server +http accessors sequences strings math.parser ; +IN: http.server.cgi + +: post? request get method>> "POST" = ; + +: cgi-variables ( script-path -- assoc ) + #! This needs some work. + [ + "CGI/1.0" "GATEWAY_INTERFACE" set + "HTTP/" request get version>> append "SERVER_PROTOCOL" set + "Factor" "SERVER_SOFTWARE" set + + dup "PATH_TRANSLATED" set + "SCRIPT_FILENAME" set + + request get path>> "SCRIPT_NAME" set + + request get host>> "SERVER_NAME" set + request get port>> number>string "SERVER_PORT" set + "" "PATH_INFO" set + "" "REMOTE_HOST" set + "" "REMOTE_ADDR" set + "" "AUTH_TYPE" set + "" "REMOTE_USER" set + "" "REMOTE_IDENT" set + + request get method>> "REQUEST_METHOD" set + request get query>> assoc>query "QUERY_STRING" set + request get "cookie" header "HTTP_COOKIE" set + + request get "user-agent" header "HTTP_USER_AGENT" set + request get "accept" header "HTTP_ACCEPT" set + + post? [ + request get post-data-type>> "CONTENT_TYPE" set + request get post-data>> length number>string "CONTENT_LENGTH" set + ] when + ] H{ } make-assoc ; + +: cgi-descriptor ( name -- desc ) + [ + dup 1array +arguments+ set + cgi-variables +environment+ set + ] H{ } make-assoc ; + +: serve-cgi ( name -- response ) + + 200 >>code + "CGI output follows" >>message + swap [ + stdio get swap cgi-descriptor [ + post? [ + request get post-data>> write flush + ] when + stdio get swap (stream-copy) + ] with-stream + ] curry >>body ; + +: enable-cgi ( responder -- responder ) + [ serve-cgi ] "application/x-cgi-script" + pick special>> set-at ; diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index a67d21a640..8616071580 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -1,45 +1,53 @@ USING: http.server tools.test kernel namespaces accessors -new-slots assocs.lib io http math sequences ; +new-slots io http math sequences assocs ; IN: temporary -TUPLE: mock-responder ; +TUPLE: mock-responder path ; -: ( path -- responder ) - mock-responder construct-delegate ; +C: mock-responder -M: mock-responder do-responder +M: mock-responder call-responder 2nip path>> on - [ "Hello world" print ] "text/plain" ; : check-dispatch ( tag path -- ? ) over off swap default-host get call-responder - write-response call get ; + write-response get ; [ - "" - "foo" add-responder - "bar" add-responder - "baz/" - "123" add-responder + + "foo" "foo" add-responder + "bar" "bar" add-responder + + "123" "123" add-responder "default" >>default - add-responder + "baz" add-responder default-host set + [ "foo" ] [ + "foo" default-host get find-responder path>> nip + ] unit-test + + [ "bar" ] [ + "bar" default-host get find-responder path>> nip + ] unit-test + [ t ] [ "foo" "foo" check-dispatch ] unit-test [ f ] [ "foo" "bar" check-dispatch ] unit-test [ t ] [ "bar" "bar" check-dispatch ] unit-test [ t ] [ "default" "baz/xxx" check-dispatch ] unit-test + [ t ] [ "default" "baz/xxx//" check-dispatch ] unit-test + [ t ] [ "default" "/baz/xxx//" check-dispatch ] unit-test [ t ] [ "123" "baz/123" check-dispatch ] unit-test + [ t ] [ "123" "baz///123" check-dispatch ] unit-test [ t ] [ "baz" >>path "baz" default-host get call-responder dup code>> 300 399 between? >r - header>> "location" peek-at "baz/" tail? r> and - nip + header>> "location" swap at "baz/" tail? r> and ] unit-test ] with-scope diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index e06ae6a95c..3780b2110d 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -2,24 +2,17 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel namespaces io io.timeouts strings splitting threads http sequences prettyprint io.server logging calendar -new-slots html.elements accessors math.parser combinators.lib ; +new-slots html.elements accessors math.parser combinators.lib +vocabs.loader debugger html continuations random ; IN: http.server -TUPLE: responder path directory ; +GENERIC: call-responder ( request path responder -- response ) -: ( path -- responder ) - "/" ?tail responder construct-boa ; +TUPLE: trivial-responder response ; -GENERIC: do-responder ( request path responder -- quot response ) +C: trivial-responder -TUPLE: trivial-responder quot response ; - -: ( quot response -- responder ) - trivial-responder construct-boa - "" over set-delegate ; - -M: trivial-responder do-responder - 2nip dup quot>> swap response>> ; +M: trivial-responder call-responder 2nip response>> call ; : trivial-response-body ( code message -- ) @@ -28,23 +21,30 @@ M: trivial-responder do-responder ; -: ( code message -- quot response ) - [ [ trivial-response-body ] 2curry ] 2keep +: ( code message -- response ) + + 2over [ trivial-response-body ] 2curry >>body "text/html" set-content-type swap >>message swap >>code ; -: <404> ( -- quot response ) +: <404> ( -- response ) 404 "Not Found" ; -: ( to code message -- quot response ) - - rot "location" set-response-header ; +SYMBOL: 404-responder -: ( to -- quot response ) +[ <404> ] 404-responder set-global + +: ( to code message -- response ) + + swap "location" set-header ; + +\ DEBUG add-input-logging + +: ( to -- response ) 301 "Moved Permanently" ; -: ( to -- quot response ) +: ( to -- response ) 307 "Temporary Redirect" ; : ( content-type -- response ) @@ -52,66 +52,58 @@ M: trivial-responder do-responder 200 >>code swap set-content-type ; -TUPLE: dispatcher responders default ; +TUPLE: dispatcher default responders ; -: responder-matches? ( path responder -- ? ) - path>> head? ; +: get-responder ( name dispatcher -- responder ) + tuck responders>> at [ ] [ default>> ] ?if ; -TUPLE: no-/-responder ; +: find-responder ( path dispatcher -- path responder ) + >r [ CHAR: / = ] left-trim "/" split1 + swap [ CHAR: / = ] right-trim r> get-responder ; -M: no-/-responder do-responder - 2drop +: redirect-with-/ ( request -- response ) dup path>> "/" append >>path request-url ; -: ( -- responder ) - "" no-/-responder construct-delegate ; +M: dispatcher call-responder + over [ + find-responder call-responder + ] [ + 2drop redirect-with-/ + ] if ; - no-/-responder set-global +: ( -- dispatcher ) + 404-responder get-global H{ } clone + dispatcher construct-boa ; -: find-responder ( path dispatcher -- path responder ) - >r "/" ?head drop r> - [ responders>> [ dupd responder-matches? ] find nip ] keep - default>> or [ path>> ?head drop ] keep ; - -: no-trailing-/ ( path responder -- path responder ) - over empty? over directory>> and - [ drop no-/-responder get-global ] when ; - -: call-responder ( request path responder -- quot response ) - no-trailing-/ do-responder ; - -SYMBOL: 404-responder - -<404> 404-responder set-global - -M: dispatcher do-responder - find-responder call-responder ; - -: ( path -- dispatcher ) - - dispatcher construct-delegate - 404-responder get-global >>default - V{ } clone >>responders ; - -: add-responder ( dispatcher responder -- dispatcher ) - over responders>> push ; +: add-responder ( dispatcher responder path -- dispatcher ) + pick responders>> set-at ; SYMBOL: virtual-hosts SYMBOL: default-host virtual-hosts global [ drop H{ } clone ] cache drop -default-host global [ drop 404-responder ] cache drop +default-host global [ drop 404-responder get-global ] cache drop : find-virtual-host ( host -- responder ) virtual-hosts get at [ default-host get ] unless* ; +: <500> ( error -- response ) + 500 "Internal server error" + swap [ + "Internal server error" [ + [ print-error nl :c ] with-html-stream + ] simple-page + ] curry >>body ; + : handle-request ( request -- ) [ - dup path>> over host>> find-virtual-host - call-responder - write-response - ] keep method>> "HEAD" = [ drop ] [ call ] if ; + dup dup path>> over host>> + find-virtual-host call-responder + ] [ <500> ] recover + dup write-response + swap method>> "HEAD" = + [ drop ] [ write-response-body ] if ; : default-timeout 1 minutes stdio get set-timeout ; @@ -120,12 +112,21 @@ LOG: httpd-hit NOTICE : log-request ( request -- ) { method>> host>> path>> } map-exec-with httpd-hit ; +SYMBOL: development-mode + +: (httpd) ( -- ) + default-timeout + development-mode get-global + [ global [ refresh-all ] bind ] when + read-request dup log-request handle-request ; + : httpd ( port -- ) - internet-server "http.server" [ - default-timeout - read-request dup log-request handle-request - ] with-server ; + internet-server "http.server" [ (httpd) ] with-server ; : httpd-main ( -- ) 8888 httpd ; MAIN: httpd-main + +: generate-key ( assoc -- str ) + 4 big-random >hex dup pick key? + [ drop generate-key ] [ nip ] if ; diff --git a/extra/http/server/sessions/authors.txt b/extra/http/server/sessions/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/http/server/sessions/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor new file mode 100755 index 0000000000..988ae41609 --- /dev/null +++ b/extra/http/server/sessions/sessions-tests.factor @@ -0,0 +1,32 @@ +IN: temporary +USING: tools.test http.server.sessions math namespaces +kernel accessors ; + +"1234" f [ + [ ] [ 3 "x" sset ] unit-test + + [ 9 ] [ "x" sget sq ] unit-test + + [ ] [ "x" [ 1- ] schange ] unit-test + + [ 4 ] [ "x" sget sq ] unit-test +] with-session + +[ t ] [ f url-sessions? ] unit-test +[ t ] [ f cookie-sessions? ] unit-test + +[ ] [ + f + [ 0 "x" sset ] >>init + "manager" set +] unit-test + +[ { 5 0 } ] [ + [ + "manager" get new-session + dup "manager" get get-session [ 5 "a" sset ] with-session + dup "manager" get get-session [ "a" sget , ] with-session + dup "manager" get get-session [ "x" sget , ] with-session + "manager" get get-session delete-session + ] { } make +] unit-test diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor new file mode 100755 index 0000000000..7d6ca5a637 --- /dev/null +++ b/extra/http/server/sessions/sessions.factor @@ -0,0 +1,112 @@ +! Copyright (C) 2008 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs calendar kernel math.parser namespaces random +boxes alarms new-slots accessors http http.server +quotations hashtables sequences ; +IN: http.server.sessions + +! ! ! ! ! ! +! WARNING: this session manager is vulnerable to XSRF attacks +! ! ! ! ! ! + +TUPLE: session-manager responder init sessions ; + +: ( responder class -- responder' ) + >r [ ] H{ } clone session-manager construct-boa r> + construct-delegate ; inline + +TUPLE: session id manager namespace alarm ; + +: ( id manager -- session ) + H{ } clone \ session construct-boa ; + +: timeout ( -- dt ) 20 minutes ; + +: cancel-timeout ( session -- ) + alarm>> ?box [ cancel-alarm ] [ drop ] if ; + +: delete-session ( session -- ) + dup cancel-timeout + dup manager>> sessions>> delete-at ; + +: touch-session ( session -- ) + dup cancel-timeout + dup [ delete-session ] curry timeout later + swap session-alarm >box ; + +: session ( -- assoc ) \ session get namespace>> ; + +: sget ( key -- value ) session at ; + +: sset ( value key -- ) session set-at ; + +: schange ( key quot -- ) session swap change-at ; inline + +: with-session ( session quot -- ) + >r \ session r> with-variable ; inline + +: new-session ( responder -- id ) + [ sessions>> generate-key dup ] keep + [ dup touch-session ] keep + [ init>> with-session ] 2keep + >r over r> sessions>> set-at ; + +: get-session ( id responder -- session ) + sessions>> tuck at* [ + nip dup touch-session + ] [ + 2drop f + ] if ; + +: call-responder/session ( request path responder session -- response ) + [ responder>> call-responder ] with-session ; + +: sessions ( -- manager/f ) + \ session get dup [ manager>> ] when ; + +GENERIC: session-link* ( url query sessions -- string ) + +M: object session-link* 2drop url-encode ; + +: session-link ( url query -- string ) sessions session-link* ; + +TUPLE: url-sessions ; + +: ( responder -- responder' ) + url-sessions ; + +: sess-id "factorsessid" ; + +M: url-sessions call-responder ( request path responder -- response ) + pick sess-id query-param over get-session [ + call-responder/session + ] [ + new-session nip sess-id set-query-param + request-url + ] if* ; + +M: url-sessions session-link* + drop + \ session get id>> sess-id associate union assoc>query + >r url-encode r> + dup assoc-empty? [ drop ] [ "?" swap 3append ] if ; + +TUPLE: cookie-sessions ; + +: ( responder -- responder' ) + cookie-sessions ; + +: get-session-cookie ( request -- cookie ) + sess-id get-cookie ; + +: ( id -- cookie ) + sess-id ; + +M: cookie-sessions call-responder ( request path responder -- response ) + pick get-session-cookie value>> over get-session [ + call-responder/session + ] [ + dup new-session + [ over get-session call-responder/session ] keep + put-cookie + ] if* ; diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor new file mode 100755 index 0000000000..e1a7a3cae9 --- /dev/null +++ b/extra/http/server/static/static.factor @@ -0,0 +1,95 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: calendar html io io.files kernel math math.parser http +http.server namespaces parser sequences strings assocs +hashtables debugger http.mime sorting html.elements logging +calendar.format new-slots accessors ; +IN: http.server.static + +SYMBOL: responder + +! special maps mime types to quots with effect ( path -- ) +TUPLE: file-responder root hook special ; + +: unix-time>timestamp ( n -- timestamp ) + >r unix-1970 r> seconds time+ ; + +: file-http-date ( filename -- string ) + file-modified unix-time>timestamp timestamp>http-string ; + +: last-modified-matches? ( filename -- ? ) + file-http-date dup [ + request get "if-modified-since" header = + ] when ; + +: <304> ( -- response ) + 304 "Not modified" ; + +: ( root hook -- responder ) + H{ } clone file-responder construct-boa ; + +: ( root -- responder ) + [ + + over file-length "content-length" set-header + over file-http-date "last-modified" set-header + swap [ stdio get stream-copy ] curry >>body + ] ; + +: serve-static ( filename mime-type -- response ) + over last-modified-matches? + [ 2drop <304> ] [ responder get hook>> call ] if ; + +: serving-path ( filename -- filename ) + "" or responder get root>> swap path+ ; + +: serve-file ( filename -- response ) + dup mime-type + dup responder get special>> at + [ call ] [ serve-static ] ?if ; + +\ serve-file NOTICE add-input-logging + +: file. ( name dirp -- ) + [ "/" append ] when + dup write ; + +: directory. ( path -- ) + dup file-name [ +

dup file-name write

+
    + directory sort-keys + [
  • file.
    • ] assoc-each +
+ ] simple-html-document ; + +: list-directory ( directory -- response ) + "text/html" + swap [ directory. ] curry >>body ; + +: find-index ( filename -- path ) + { "index.html" "index.fhtml" } + [ dupd path+ exists? ] find nip + dup [ path+ ] [ nip ] if ; + +: serve-directory ( filename -- response ) + dup "/" tail? [ + dup find-index + [ serve-file ] [ list-directory ] ?if + ] [ + drop request get redirect-with-/ + ] if ; + +: serve-object ( filename -- response ) + serving-path dup exists? [ + dup directory? [ serve-directory ] [ serve-file ] if + ] [ + drop <404> + ] if ; + +M: file-responder call-responder ( request path responder -- response ) + [ + responder set + swap request set + serve-object + ] with-scope ; diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index 3b0dcb8e5e..b298faca74 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -4,7 +4,8 @@ USING: continuations sequences kernel parser namespaces io io.files io.streams.lines io.streams.string html html.elements source-files debugger combinators math quotations generic -strings splitting ; +strings splitting accessors http.server.static http.server +assocs ; IN: http.server.templating @@ -82,10 +83,10 @@ DEFER: <% delimiter templating-vocab use+ ! so that reload works properly dup source-file file set - dup ?resource-path file-contents + ?resource-path file-contents [ eval-template ] [ html-error. drop ] recover ] with-file-vocabs - ] assert-depth drop ; + ] curry assert-depth ; : run-relative-template-file ( filename -- ) file get source-file-path parent-directory @@ -93,3 +94,13 @@ DEFER: <% delimiter : template-convert ( infile outfile -- ) [ run-template-file ] with-file-writer ; + +! file responder integration +: serve-fhtml ( filename -- response ) + "text/html" + swap [ run-template-file ] curry >>body ; + +: enable-fhtml ( responder -- responder ) + [ serve-fhtml ] + "application/x-factor-server-page" + pick special>> set-at ; diff --git a/extra/webapps/cgi/authors.txt b/extra/webapps/cgi/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/webapps/cgi/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/webapps/cgi/cgi.factor b/extra/webapps/cgi/cgi.factor deleted file mode 100755 index 5dba9dae00..0000000000 --- a/extra/webapps/cgi/cgi.factor +++ /dev/null @@ -1,75 +0,0 @@ -! Copyright (C) 2007, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel assocs io.files combinators -arrays io.launcher io http.server.responders webapps.file -sequences strings math.parser unicode.case ; -IN: webapps.cgi - -SYMBOL: cgi-root - -: post? "method" get "post" = ; - -: cgi-variables ( script-path -- assoc ) - #! This needs some work. - [ - "CGI/1.0" "GATEWAY_INTERFACE" set - "HTTP/1.0" "SERVER_PROTOCOL" set - "Factor" "SERVER_SOFTWARE" set - - dup "PATH_TRANSLATED" set - "SCRIPT_FILENAME" set - - "request" get "SCRIPT_NAME" set - - host "SERVER_NAME" set - "" "SERVER_PORT" set - "" "PATH_INFO" set - "" "REMOTE_HOST" set - "" "REMOTE_ADDR" set - "" "AUTH_TYPE" set - "" "REMOTE_USER" set - "" "REMOTE_IDENT" set - - "method" get >upper "REQUEST_METHOD" set - "raw-query" get "QUERY_STRING" set - "cookie" header-param "HTTP_COOKIE" set - - "user-agent" header-param "HTTP_USER_AGENT" set - "accept" header-param "HTTP_ACCEPT" set - - post? [ - "content-type" header-param "CONTENT_TYPE" set - "raw-response" get length number>string "CONTENT_LENGTH" set - ] when - ] H{ } make-assoc ; - -: cgi-descriptor ( name -- desc ) - [ - cgi-root get swap path+ dup 1array +arguments+ set - cgi-variables +environment+ set - ] H{ } make-assoc ; - -: (do-cgi) ( name -- ) - "200 CGI output follows" response - stdio get swap cgi-descriptor [ - post? [ - "raw-response" get write flush - ] when - stdio get swap (stream-copy) - ] with-stream ; - -: serve-regular-file ( -- ) - cgi-root get doc-root [ file-responder ] with-variable ; - -: do-cgi ( name -- ) - { - { [ dup ".cgi" tail? not ] [ drop serve-regular-file ] } - { [ dup empty? ] [ "403 forbidden" httpd-error ] } - { [ cgi-root get not ] [ "404 cgi-root not set" httpd-error ] } - { [ ".." over subseq? ] [ "403 forbidden" httpd-error ] } - { [ t ] [ (do-cgi) ] } - } cond ; - -global [ - "cgi" [ "argument" get do-cgi ] add-simple-responder -] bind diff --git a/extra/webapps/file/authors.txt b/extra/webapps/file/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/webapps/file/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/webapps/file/file.factor b/extra/webapps/file/file.factor deleted file mode 100755 index 411c70c76a..0000000000 --- a/extra/webapps/file/file.factor +++ /dev/null @@ -1,136 +0,0 @@ -! Copyright (C) 2004, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: calendar html io io.files kernel math math.parser -http.server.responders http.server.templating namespaces parser -sequences strings assocs hashtables debugger http.mime sorting -html.elements logging calendar.format ; -IN: webapps.file - -SYMBOL: doc-root - -: serving-path ( filename -- filename ) - "" or doc-root get swap path+ ; - -: unix-time>timestamp ( n -- timestamp ) - >r unix-1970 r> seconds time+ ; - -: file-http-date ( filename -- string ) - file-modified unix-time>timestamp timestamp>http-string ; - -: file-response ( filename mime-type -- ) - "200 OK" response - [ - "Content-Type" set - dup file-length number>string "Content-Length" set - file-http-date "Last-Modified" set - now timestamp>http-string "Date" set - ] H{ } make-assoc print-header ; - -: last-modified-matches? ( filename -- bool ) - file-http-date dup [ - "if-modified-since" header-param = - ] when ; - -: not-modified-response ( -- ) - "304 Not Modified" response - now timestamp>http-string "Date" associate print-header ; - -! You can override how files are served in a custom responder -SYMBOL: serve-file-hook - -[ - dupd - file-response - stdio get stream-copy -] serve-file-hook set-global - -: serve-static ( filename mime-type -- ) - over last-modified-matches? [ - 2drop not-modified-response - ] [ - "method" get "head" = [ - file-response - ] [ - serve-file-hook get call - ] if - ] if ; - -SYMBOL: page - -: run-page ( filename -- ) - dup - [ [ dup page set run-template-file ] with-scope ] try - drop ; - -\ run-page DEBUG add-input-logging - -: include-page ( filename -- ) - serving-path run-page ; - -: serve-fhtml ( filename -- ) - serving-html - "method" get "head" = [ drop ] [ run-page ] if ; - -: serve-file ( filename -- ) - dup mime-type dup "application/x-factor-server-page" = - [ drop serve-fhtml ] [ serve-static ] if ; - -\ serve-file NOTICE add-input-logging - -: file. ( name dirp -- ) - [ "/" append ] when - dup write ; - -: directory. ( path request -- ) - dup [ -

write

-
    - directory sort-keys - [
  • file.
    • ] assoc-each -
- ] simple-html-document ; - -: list-directory ( directory -- ) - serving-html - "method" get "head" = [ - drop - ] [ - "request" get directory. - ] if ; - -: find-index ( filename -- path ) - { "index.html" "index.fhtml" } - [ dupd path+ exists? ] find nip - dup [ path+ ] [ nip ] if ; - -: serve-directory ( filename -- ) - dup "/" tail? [ - dup find-index - [ serve-file ] [ list-directory ] ?if - ] [ - drop directory-no/ - ] if ; - -: serve-object ( filename -- ) - serving-path dup exists? [ - dup directory? [ serve-directory ] [ serve-file ] if - ] [ - drop "404 not found" httpd-error - ] if ; - -: file-responder ( -- ) - doc-root get [ - "argument" get serve-object - ] [ - "404 doc-root not set" httpd-error - ] if ; - -global [ - ! Serves files from a directory stored in the doc-root - ! variable. You can set the variable in the global - ! namespace, or inside the responder. - "file" [ file-responder ] add-simple-responder - - ! The root directory is served by... - "file" set-default-responder -] bind \ No newline at end of file diff --git a/extra/webapps/source/authors.txt b/extra/webapps/source/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/webapps/source/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/webapps/source/source.factor b/extra/webapps/source/source.factor deleted file mode 100755 index 98fb5b8873..0000000000 --- a/extra/webapps/source/source.factor +++ /dev/null @@ -1,35 +0,0 @@ -! Copyright (C) 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: io.files namespaces webapps.file http.server.responders -xmode.code2html kernel html sequences ; -IN: webapps.source - -! This responder is a potential security problem. Make sure you -! don't have sensitive files stored under vm/, core/, extra/ -! or misc/. - -: check-source-path ( path -- ? ) - { "vm/" "core/" "extra/" "misc/" } - [ head? ] with contains? ; - -: source-responder ( path mime-type -- ) - drop - serving-html - [ - dup file-name swap htmlize-stream - ] with-html-stream ; - -global [ - ! Serve up our own source code - "source" [ - "argument" get check-source-path [ - [ - "" resource-path doc-root set - [ source-responder ] serve-file-hook set - file-responder - ] with-scope - ] [ - "403 forbidden" httpd-error - ] if - ] add-simple-responder -] bind diff --git a/extra/xmode/code2html/responder/responder.factor b/extra/xmode/code2html/responder/responder.factor new file mode 100755 index 0000000000..d14ffd93b3 --- /dev/null +++ b/extra/xmode/code2html/responder/responder.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.files namespaces http.server http.server.static http +xmode.code2html kernel html sequences accessors ; +IN: xmode.code2html.responder + +: ( root -- responder ) + [ + drop + "text/html" + over file-http-date "last-modified" set-header + swap [ + dup file-name swap htmlize-stream + ] curry >>body + ] ; From 24b4fb0df9da74f086a572fc987aab658d78c58b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 29 Feb 2008 10:37:39 -0600 Subject: [PATCH 04/36] Use if-box in http.server --- extra/http/server/sessions/sessions.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index 7d6ca5a637..4db256ca72 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -23,7 +23,7 @@ TUPLE: session id manager namespace alarm ; : timeout ( -- dt ) 20 minutes ; : cancel-timeout ( session -- ) - alarm>> ?box [ cancel-alarm ] [ drop ] if ; + alarm>> [ cancel-alarm ] if-box? ; : delete-session ( session -- ) dup cancel-timeout From c26b1a895f8ff2580c408cba41acf4eec9e51e0d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Mar 2008 02:19:36 -0600 Subject: [PATCH 05/36] More httpd work --- extra/http/http-tests.factor | 11 ++- extra/http/http.factor | 10 +- extra/http/server/actions/actions.factor | 12 +++ extra/http/server/callbacks/callbacks.factor | 53 ++--------- extra/http/server/db/db.factor | 13 +++ extra/http/server/server-tests.factor | 8 ++ extra/http/server/server.factor | 92 +++++++++++++------ .../server/sessions/sessions-tests.factor | 4 +- extra/http/server/sessions/sessions.factor | 22 ++--- extra/http/server/static/static.factor | 18 +++- 10 files changed, 148 insertions(+), 95 deletions(-) create mode 100755 extra/http/server/actions/actions.factor create mode 100755 extra/http/server/db/db.factor diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 51cc933736..b706f34d13 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -18,6 +18,11 @@ IN: http.tests [ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test +[ "/" ] [ "http://foo.com" url>path ] unit-test +[ "/" ] [ "http://foo.com/" url>path ] unit-test +[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test +[ "/bar" ] [ "/bar" url>path ] unit-test + STRING: read-request-test-1 GET http://foo/bar HTTP/1.1 Some-Header: 1 @@ -31,7 +36,7 @@ blah TUPLE{ request port: 80 method: "GET" - path: "bar" + path: "/bar" query: H{ } version: "1.1" header: H{ { "some-header" "1; 2" } { "content-length" "4" } } @@ -45,7 +50,7 @@ blah ] unit-test STRING: read-request-test-1' -GET bar HTTP/1.1 +GET /bar HTTP/1.1 content-length: 4 some-header: 1; 2 @@ -69,7 +74,7 @@ Host: www.sex.com TUPLE{ request port: 80 method: "HEAD" - path: "bar" + path: "/bar" query: H{ } version: "1.1" header: H{ { "host" "www.sex.com" } } diff --git a/extra/http/http.factor b/extra/http/http.factor index 8686d87052..35fe3ce544 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -180,9 +180,15 @@ cookies ; : set-query-param ( request value key -- request ) pick query>> set-at ; +: chop-hostname ( str -- str' ) + CHAR: / over index over length or tail + dup empty? [ drop "/" ] when ; + : url>path ( url -- path ) - url-decode "http://" ?head - [ "/" split1 "" or nip ] [ "/" ?head drop ] if ; + #! Technically, only proxies are meant to support hostnames + #! in HTTP requests, but IE sends these sometimes so we + #! just chop the hostname part. + url-decode "http://" ?head [ chop-hostname ] when ; : read-method ( request -- request ) " " read-until [ "Bad request: method" throw ] unless diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor new file mode 100755 index 0000000000..4396c7a9da --- /dev/null +++ b/extra/http/server/actions/actions.factor @@ -0,0 +1,12 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.actions + +TUPLE: action quot params method ; + +C: action + +: extract-params ( assoc action -- ... ) + params>> [ first2 >r swap at r> call ] with each ; + +: call-action ; diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor index a000a76040..fd2e8f8ad7 100755 --- a/extra/http/server/callbacks/callbacks.factor +++ b/extra/http/server/callbacks/callbacks.factor @@ -50,12 +50,12 @@ SYMBOL: exit-continuation #! When executed inside a 'show' call, this will force a #! HTTP 302 to occur to instruct the browser to forward to #! the request URL. - exit-with ; + request get swap exit-with ; : cont-id "factorcontid" ; : id>url ( id -- url ) - request get clone + request get swap cont-id associate >>query request-url ; @@ -102,9 +102,8 @@ SYMBOL: current-show [ restore-request store-current-show ] when* ; : show-final ( quot -- * ) - [ - >r store-current-show redirect-to-here r> call exit-with - ] with-scope ; inline + >r redirect-to-here store-current-show + r> call exit-with ; inline M: callback-responder call-responder [ @@ -122,49 +121,15 @@ M: callback-responder call-responder ] callcc1 >r 3drop r> ; : show-page ( quot -- ) + >r redirect-to-here store-current-show r> [ - >r store-current-show redirect-to-here r> - [ - [ ] register-callback - call - exit-with - ] callcc1 restore-request - ] with-scope ; inline + [ ] register-callback + with-scope + exit-with + ] callcc1 restore-request ; inline : quot-id ( quot -- id ) current-show get swap t register-callback ; : quot-url ( quot -- url ) quot-id id>url ; - -! SYMBOL: current-show -! -! : store-current-show ( -- ) -! #! Store the current continuation in the variable 'current-show' -! #! so it can be returned to later by href callbacks. Note that it -! #! recalls itself when the continuation is called to ensure that -! #! it resets its value back to the most recent show call. -! [ ( 0 -- ) -! [ ( 0 1 -- ) -! current-show set ( 0 -- ) -! continue -! ] callcc1 -! nip -! store-current-show -! ] callcc0 ; -! - -! -! : show-final ( quot -- * ) -! store-current-show -! redirect-to-here -! call -! exit-with ; inline -! -! : show-page ( quot -- request ) -! store-current-show redirect-to-here -! [ -! register-continuation -! call -! exit-with -! ] callcc1 restore-request ; inline diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor new file mode 100755 index 0000000000..ab45570b88 --- /dev/null +++ b/extra/http/server/db/db.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: db http.server kernel new-slots accessors ; +IN: http.server.db + +TUPLE: db-persistence responder db params ; + +C: db-persistence + +M: db-persistence call-responder + dup db>> over params>> [ + responder>> call-responder + ] with-db ; diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index 864df9204d..0635e1f895 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -51,3 +51,11 @@ M: mock-responder call-responder header>> "location" swap at "baz/" tail? r> and ] unit-test ] with-scope + +[ + + "default" >>default + default-host set + + [ "/default" ] [ "/default" default-host get find-responder drop ] unit-test +] with-scope diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 3780b2110d..f71b1d3ec6 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -3,7 +3,7 @@ USING: assocs kernel namespaces io io.timeouts strings splitting threads http sequences prettyprint io.server logging calendar new-slots html.elements accessors math.parser combinators.lib -vocabs.loader debugger html continuations random ; +vocabs.loader debugger html continuations random combinators ; IN: http.server GENERIC: call-responder ( request path responder -- response ) @@ -12,7 +12,7 @@ TUPLE: trivial-responder response ; C: trivial-responder -M: trivial-responder call-responder 2nip response>> call ; +M: trivial-responder call-responder nip response>> call ; : trivial-response-body ( code message -- ) @@ -33,18 +33,26 @@ M: trivial-responder call-responder 2nip response>> call ; SYMBOL: 404-responder -[ <404> ] 404-responder set-global +[ drop <404> ] 404-responder set-global -: ( to code message -- response ) +: modify-for-redirect ( request to -- url ) + { + { [ dup "http://" head? ] [ nip ] } + { [ dup "/" head? ] [ >>path request-url ] } + { [ t ] [ >r dup path>> "/" last-split1 drop "/" r> 3append >>path request-url ] } + } cond ; + +: ( request to code message -- response ) - swap "location" set-header ; + -rot modify-for-redirect + "location" set-header ; \ DEBUG add-input-logging -: ( to -- response ) +: ( request to -- response ) 301 "Moved Permanently" ; -: ( to -- response ) +: ( request to -- response ) 307 "Temporary Redirect" ; : ( content-type -- response ) @@ -54,31 +62,46 @@ SYMBOL: 404-responder TUPLE: dispatcher default responders ; -: get-responder ( name dispatcher -- responder ) - tuck responders>> at [ ] [ default>> ] ?if ; +: ( -- dispatcher ) + 404-responder H{ } clone dispatcher construct-boa ; + +: set-main ( dispatcher name -- dispatcher ) + [ ] curry + >>default ; + +: split-path ( path -- rest first ) + [ CHAR: / = ] left-trim "/" split1 swap ; : find-responder ( path dispatcher -- path responder ) - >r [ CHAR: / = ] left-trim "/" split1 - swap [ CHAR: / = ] right-trim r> get-responder ; + over split-path pick responders>> at* + [ >r >r 2drop r> r> ] [ 2drop default>> ] if ; : redirect-with-/ ( request -- response ) - dup path>> "/" append >>path - request-url ; + dup path>> "/" append ; M: dispatcher call-responder over [ - find-responder call-responder + 3dup find-responder call-responder [ + >r 3drop r> + ] [ + default>> [ + call-responder + ] [ + 3drop f + ] if* + ] if* ] [ 2drop redirect-with-/ ] if ; -: ( -- dispatcher ) - 404-responder get-global H{ } clone - dispatcher construct-boa ; - : add-responder ( dispatcher responder path -- dispatcher ) pick responders>> set-at ; +: add-main-responder ( dispatcher responder path -- dispatcher ) + [ add-responder ] keep set-main ; + +: ( class -- dispatcher ) + swap construct-delegate ; inline SYMBOL: virtual-hosts SYMBOL: default-host @@ -88,23 +111,33 @@ default-host global [ drop 404-responder get-global ] cache drop : find-virtual-host ( host -- responder ) virtual-hosts get at [ default-host get ] unless* ; +SYMBOL: development-mode + : <500> ( error -- response ) 500 "Internal server error" swap [ "Internal server error" [ - [ print-error nl :c ] with-html-stream + development-mode get [ + [ print-error nl :c ] with-html-stream + ] [ + 500 "Internal server error" + trivial-response-body + ] if ] simple-page ] curry >>body ; -: handle-request ( request -- ) - [ - dup dup path>> over host>> - find-virtual-host call-responder - ] [ <500> ] recover +: do-response ( request response -- ) dup write-response swap method>> "HEAD" = [ drop ] [ write-response-body ] if ; +: do-request ( request -- request ) + [ + dup dup path>> over host>> + find-virtual-host call-responder + [ <404> ] unless* + ] [ dup \ do-request log-error <500> ] recover ; + : default-timeout 1 minutes stdio get set-timeout ; LOG: httpd-hit NOTICE @@ -112,16 +145,17 @@ LOG: httpd-hit NOTICE : log-request ( request -- ) { method>> host>> path>> } map-exec-with httpd-hit ; -SYMBOL: development-mode - -: (httpd) ( -- ) +: handle-client ( -- ) default-timeout development-mode get-global [ global [ refresh-all ] bind ] when - read-request dup log-request handle-request ; + read-request + dup log-request + do-request do-response ; : httpd ( port -- ) - internet-server "http.server" [ (httpd) ] with-server ; + internet-server "http.server" + [ handle-client ] with-server ; : httpd-main ( -- ) 8888 httpd ; diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor index 988ae41609..4c21ba3c8d 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/http/server/sessions/sessions-tests.factor @@ -1,7 +1,9 @@ -IN: temporary +IN: http.server.sessions.tests USING: tools.test http.server.sessions math namespaces kernel accessors ; +: with-session \ session swap with-variable ; inline + "1234" f [ [ ] [ 3 "x" sset ] unit-test diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index 4db256ca72..2977e5938d 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -9,10 +9,12 @@ IN: http.server.sessions ! WARNING: this session manager is vulnerable to XSRF attacks ! ! ! ! ! ! -TUPLE: session-manager responder init sessions ; +GENERIC: init-session ( responder -- ) + +TUPLE: session-manager responder sessions ; : ( responder class -- responder' ) - >r [ ] H{ } clone session-manager construct-boa r> + >r H{ } clone session-manager construct-boa r> construct-delegate ; inline TUPLE: session id manager namespace alarm ; @@ -42,13 +44,10 @@ TUPLE: session id manager namespace alarm ; : schange ( key quot -- ) session swap change-at ; inline -: with-session ( session quot -- ) - >r \ session r> with-variable ; inline - : new-session ( responder -- id ) [ sessions>> generate-key dup ] keep [ dup touch-session ] keep - [ init>> with-session ] 2keep + [ swap \ session [ responder>> init-session ] with-variable ] 2keep >r over r> sessions>> set-at ; : get-session ( id responder -- session ) @@ -59,7 +58,7 @@ TUPLE: session id manager namespace alarm ; ] if ; : call-responder/session ( request path responder session -- response ) - [ responder>> call-responder ] with-session ; + \ session set responder>> call-responder ; : sessions ( -- manager/f ) \ session get dup [ manager>> ] when ; @@ -82,7 +81,7 @@ M: url-sessions call-responder ( request path responder -- response ) call-responder/session ] [ new-session nip sess-id set-query-param - request-url + dup request-url ] if* ; M: url-sessions session-link* @@ -96,14 +95,15 @@ TUPLE: cookie-sessions ; : ( responder -- responder' ) cookie-sessions ; -: get-session-cookie ( request -- cookie ) - sess-id get-cookie ; +: get-session-cookie ( request responder -- cookie ) + >r sess-id get-cookie dup + [ value>> r> get-session ] [ r> 2drop f ] if ; : ( id -- cookie ) sess-id ; M: cookie-sessions call-responder ( request path responder -- response ) - pick get-session-cookie value>> over get-session [ + 3dup nip get-session-cookie [ call-responder/session ] [ dup new-session diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index e1a7a3cae9..10a3df4de8 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -87,9 +87,17 @@ TUPLE: file-responder root hook special ; drop <404> ] if ; +: <400> 400 "Bad request" ; + M: file-responder call-responder ( request path responder -- response ) - [ - responder set - swap request set - serve-object - ] with-scope ; + over [ + ".." pick subseq? [ + 3drop <400> + ] [ + responder set + swap request set + serve-object + ] if + ] [ + 2drop redirect-with-/ + ] if ; From a239304b0db8d2a02bf1469c53561b64e1bf60e3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Mar 2008 05:40:29 -0500 Subject: [PATCH 06/36] Improving http.server's db support and actions --- extra/bootstrap/image/upload/upload.factor | 2 +- .../http/server/actions/actions-tests.factor | 37 +++++++++++++++++++ extra/http/server/actions/actions.factor | 22 ++++++++++- extra/http/server/db/db.factor | 9 +++-- extra/http/server/server.factor | 6 ++- extra/http/server/static/static.factor | 2 - 6 files changed, 68 insertions(+), 10 deletions(-) create mode 100644 extra/http/server/actions/actions-tests.factor diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index 084f30a103..3c0b464dbf 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -8,7 +8,7 @@ SYMBOL: upload-images-destination : destination ( -- dest ) upload-images-destination get - "slava@/var/www/factorcode.org/newsite/images/latest/" + "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/" or ; : checksums "checksums.txt" temp-file ; diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor new file mode 100644 index 0000000000..2d74e92e86 --- /dev/null +++ b/extra/http/server/actions/actions-tests.factor @@ -0,0 +1,37 @@ +IN: http.server.actions.tests +USING: http.server.actions tools.test math math.parser +multiline namespaces http io.streams.string http.server +sequences ; + +[ + ] +{ { "a" [ string>number ] } { "b" [ string>number ] } } +"GET" "action-1" set + +STRING: action-request-test-1 +GET http://foo/bar?a=12&b=13 HTTP/1.1 + +blah +; + +[ 25 ] [ + action-request-test-1 [ read-request ] with-string-reader + "/blah" + "action-1" get call-responder +] unit-test + +[ "X" concat append ] +{ { +path+ [ ] } { "xxx" [ string>number ] } } +"POST" "action-2" set + +STRING: action-request-test-2 +POST http://foo/bar/baz HTTP/1.1 +content-length: 5 + +xxx=4 +; + +[ "/blahXXXX" ] [ + action-request-test-2 [ read-request ] with-string-reader + "/blah" + "action-2" get call-responder +] unit-test diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index 4396c7a9da..feb16a4488 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -1,12 +1,30 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: accessors new-slots sequences kernel assocs combinators +http.server http hashtables namespaces ; IN: http.server.actions +SYMBOL: +path+ + TUPLE: action quot params method ; C: action -: extract-params ( assoc action -- ... ) +: extract-params ( request path -- assoc ) + >r dup method>> { + { "GET" [ query>> ] } + { "POST" [ post-data>> query>assoc ] } + } case r> +path+ associate union ; + +: push-params ( assoc action -- ... ) params>> [ first2 >r swap at r> call ] with each ; -: call-action ; +M: action call-responder ( request path action -- response ) + pick request set + pick method>> over method>> = [ + >r extract-params r> + [ push-params ] keep + quot>> call + ] [ + 3drop <400> + ] if ; diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor index ab45570b88..4baee5f02b 100755 --- a/extra/http/server/db/db.factor +++ b/extra/http/server/db/db.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: db http.server kernel new-slots accessors ; +USING: db http.server kernel new-slots accessors +continuations namespaces ; IN: http.server.db TUPLE: db-persistence responder db params ; @@ -8,6 +9,6 @@ TUPLE: db-persistence responder db params ; C: db-persistence M: db-persistence call-responder - dup db>> over params>> [ - responder>> call-responder - ] with-db ; + dup db>> over params>> make-db dup db-open [ + db set responder>> call-responder + ] with-disposal ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index f71b1d3ec6..f397b280d0 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -28,6 +28,9 @@ M: trivial-responder call-responder nip response>> call ; swap >>message swap >>code ; +: <400> ( -- response ) + 400 "Bad request" ; + : <404> ( -- response ) 404 "Not Found" ; @@ -66,7 +69,7 @@ TUPLE: dispatcher default responders ; 404-responder H{ } clone dispatcher construct-boa ; : set-main ( dispatcher name -- dispatcher ) - [ ] curry + [ ] curry >>default ; : split-path ( path -- rest first ) @@ -102,6 +105,7 @@ M: dispatcher call-responder : ( class -- dispatcher ) swap construct-delegate ; inline + SYMBOL: virtual-hosts SYMBOL: default-host diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 10a3df4de8..8d47d38eb1 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -87,8 +87,6 @@ TUPLE: file-responder root hook special ; drop <404> ] if ; -: <400> 400 "Bad request" ; - M: file-responder call-responder ( request path responder -- response ) over [ ".." pick subseq? [ From a350a91232ad6fd4179c3c39717a234be27886eb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Mar 2008 05:40:50 -0500 Subject: [PATCH 07/36] db: minor fixes --- extra/db/sqlite/ffi/ffi.factor | 2 +- extra/db/sqlite/sqlite.factor | 8 +++++--- extra/db/tuples/tuples.factor | 2 +- 3 files changed, 7 insertions(+), 5 deletions(-) diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index 8c957108e1..63bce0a8c3 100755 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/extra/db/sqlite/ffi/ffi.factor @@ -112,7 +112,7 @@ FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppSt FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ; -FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; +FUNCTION: sqlite3_int64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ; FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ; FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index c03496530b..3c548ae03d 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -173,9 +173,11 @@ M: sqlite-db ( tuple class -- statement ) " from " 0% 0% [ sql-spec-slot-name swap get-slot-named ] with subset - " where " 0% - [ ", " 0% ] - [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + dup empty? [ drop ] [ + " where " 0% + [ ", " 0% ] + [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + ] if ";" 0% ] sqlite-make ; diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index e7fe7e49c2..d61fe8135e 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -103,7 +103,7 @@ HOOK: insert-tuple* db ( tuple statement -- ) db get db-delete-statements [ ] cache [ bind-tuple ] keep execute-statement ; -: select-tuples ( tuple -- tuple ) +: select-tuples ( tuple -- tuples ) dup dup class [ [ bind-tuple ] keep query-tuples ] with-disposal ; From 27dd4f17019d5287d1d9ab524694e7cd81bbddd4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 Mar 2008 22:04:56 -0600 Subject: [PATCH 08/36] Working on Windows launcher stream inheritance --- extra/io/launcher/launcher-docs.factor | 16 ++- extra/io/windows/nt/launcher/launcher.factor | 116 ++++++++++++------- extra/io/windows/windows.factor | 2 +- 3 files changed, 88 insertions(+), 46 deletions(-) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 96639dee87..31d7e7a60d 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -35,33 +35,43 @@ HELP: +environment-mode+ HELP: +stdin+ { $description "Launch descriptor key. Must equal one of the following:" { $list - { { $link f } " - standard input is inherited" } + { { $link f } " - standard input is either inherited from the current process, or is a " { $link } " pipe" } + { { $link +inherit+ } " - standard input is inherited from the current process" } { { $link +closed+ } " - standard input is closed" } { "a path name - standard input is read from the given file, which must exist" } + { "a file stream or a socket - standard input is read from the given stream, which must be closed after the process has been started" } } } ; HELP: +stdout+ { $description "Launch descriptor key. Must equal one of the following:" { $list - { { $link f } " - standard output is inherited" } + { { $link f } " - standard output is either inherited from the current process, or is a " { $link } " pipe" } + { { $link +inherit+ } " - standard output is inherited from the current process" } { { $link +closed+ } " - standard output is closed" } { "a path name - standard output is written to the given file, which is overwritten if it already exists" } + { "a file stream or a socket - standard output is written to the given stream, which must be closed after the process has been started" } } } ; HELP: +stderr+ { $description "Launch descriptor key. Must equal one of the following:" { $list - { { $link f } " - standard error is inherited" } + { { $link f } " - standard error is inherited from the current process" } + { { $link +inherit+ } " - same as above" } + { { $link +stdout+ } " - standard error is merged with standard output" } { { $link +closed+ } " - standard error is closed" } { "a path name - standard error is written to the given file, which is overwritten if it already exists" } + { "a file stream or a socket - standard error is written to the given stream, which must be closed after the process has been started" } } } ; HELP: +closed+ { $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ; +HELP: +inherit+ +{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ; + HELP: +prepend-environment+ { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence." $nl diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index cd9bb9baef..a4a3122b4d 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -1,18 +1,38 @@ -! Copyright (C) 2007 Doug Coleman, Slava Pestov. +! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays continuations destructors io io.windows libc io.nonblocking io.streams.duplex windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs splitting system strings io.windows.launcher io.windows.nt.pipes io.backend -combinators ; +combinators shuffle ; IN: io.windows.nt.launcher +: duplicate-handle ( handle -- handle' ) + GetCurrentProcess ! source process + swap ! handle + GetCurrentProcess ! target process + f [ ! target handle + DUPLICATE_SAME_ACCESS ! desired access + TRUE ! inherit handle + DUPLICATE_CLOSE_SOURCE ! options + DuplicateHandle win32-error=0/f + ] keep *void* ; + ! The below code is based on the example given in ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx -: (redirect) ( path access-mode create-mode -- handle ) - >r >r +: redirect-default ( default obj access-mode create-mode -- handle ) + 3drop ; + +: redirect-inherit ( default obj access-mode create-mode -- handle ) + 4drop f ; + +: redirect-closed ( default obj access-mode create-mode -- handle ) + drop 2nip null-pipe ; + +: redirect-file ( default path access-mode create-mode -- handle ) + >r >r >r drop r> normalize-pathname r> ! access-mode share-mode @@ -22,47 +42,59 @@ IN: io.windows.nt.launcher f ! template file CreateFile dup invalid-handle? dup close-later ; -: redirect ( obj access-mode create-mode -- handle ) - { - { [ pick not ] [ 3drop f ] } - { [ pick +closed+ eq? ] [ drop nip null-pipe ] } - { [ pick string? ] [ (redirect) ] } - } cond ; - -: ?closed or dup t eq? [ drop f ] when ; - -: inherited-stdout ( args -- handle ) - CreateProcess-args-stdout-pipe - [ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ; - -: redirect-stdout ( args -- handle ) - +stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect - swap inherited-stdout ?closed ; - -: inherited-stderr ( args -- handle ) - drop STD_ERROR_HANDLE GetStdHandle ; - -: redirect-stderr ( args -- handle ) - +stderr+ get - dup +stdout+ eq? [ - drop - CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput - ] [ - GENERIC_WRITE CREATE_ALWAYS redirect - swap inherited-stderr ?closed - ] if ; - -: inherited-stdin ( args -- handle ) - CreateProcess-args-stdin-pipe - [ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ; - -: redirect-stdin ( args -- handle ) - +stdin+ get GENERIC_READ OPEN_EXISTING redirect - swap inherited-stdin ?closed ; - : set-inherit ( handle ? -- ) >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ; +: redirect-stream ( default stream access-mode create-mode -- handle ) + 2drop nip + underlying-handle win32-file-handle + duplicate-handle dup t set-inherit ; + +: redirect ( default obj access-mode create-mode -- handle ) + { + { [ pick not ] [ redirect-default ] } + { [ pick +inherit+ eq? ] [ redirect-inherit ] } + { [ pick +closed+ eq? ] [ redirect-closed ] } + { [ pick string? ] [ redirect-file ] } + { [ t ] [ redirect-stream ] } + } cond ; + +: default-stdout ( args -- handle ) + CreateProcess-args-stdout-pipe dup [ pipe-out ] when ; + +: redirect-stdout ( args -- handle ) + default-stdout + +stdout+ get + GENERIC_WRITE + CREATE_ALWAYS + redirect + STD_OUTPUT_HANDLE GetStdHandle or ; + +: redirect-stderr ( args -- handle ) + +stderr+ get +stdout+ eq? [ + CreateProcess-args-lpStartupInfo + STARTUPINFO-hStdOutput + ] [ + drop + f + +stderr+ get + GENERIC_WRITE + CREATE_ALWAYS + redirect + STD_ERROR_HANDLE GetStdHandle or + ] if ; + +: default-stdin ( args -- handle ) + CreateProcess-args-stdin-pipe dup [ pipe-in ] when ; + +: redirect-stdin ( args -- handle ) + default-stdin + +stdin+ get + GENERIC_READ + OPEN_EXISTING + redirect + STD_INPUT_HANDLE GetStdHandle or ; + : add-pipe-dtors ( pipe -- ) dup pipe-in close-later diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 38b7d4829c..291bef6018 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -55,7 +55,7 @@ M: win32-file close-handle ( handle -- ) : open-file ( path access-mode create-mode flags -- handle ) [ >r >r >r normalize-pathname r> - share-mode f r> r> CreateFile-flags f CreateFile + share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile dup invalid-handle? dup close-later dup add-completion ] with-destructors ; From 18d8f449b9f319a9f25b637ea0cb284ae5745467 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 Mar 2008 22:13:30 -0600 Subject: [PATCH 09/36] Remove unnecessary method tuple, move its slots to word properties --- core/generic/generic-docs.factor | 10 +- core/generic/generic.factor | 52 +- core/generic/math/math.factor | 2 +- core/generic/standard/standard.factor | 2 +- core/inference/backend/backend.factor | 3 +- core/optimizer/inlining/inlining.factor | 416 ++++++------- core/optimizer/optimizer-tests.factor | 756 ++++++++++++------------ core/prettyprint/prettyprint.factor | 14 +- core/words/words.factor | 2 +- 9 files changed, 629 insertions(+), 628 deletions(-) diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 631aa7e62d..b2fba47d3a 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -116,16 +116,18 @@ HELP: method-spec { $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." } { $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ; +HELP: method-body +{ $class-description "The class of method bodies, which are words with special word properties set." } ; + HELP: method -{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method } " or " { $link f } } } -{ $description "Looks up a method definition." } -{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ; +{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } } +{ $description "Looks up a method definition." } ; { method define-method POSTPONE: M: } related-words HELP: { $values { "def" "a quotation" } { "method" "a new method definition" } } -{ $description "Creates a new "{ $link method } " instance." } ; +{ $description "Creates a new method." } ; HELP: methods { $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } } diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 35cc471033..dbff82777f 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -33,8 +33,6 @@ M: generic definition drop f ; dup { "unannotated-def" } reset-props dup dup "combination" word-prop perform-combination define ; -TUPLE: method word def specializer generic loc ; - : method ( class generic -- method/f ) "methods" word-prop at ; @@ -47,7 +45,7 @@ PREDICATE: pair method-spec : methods ( word -- assoc ) "methods" word-prop [ keys sort-classes ] keep - [ dupd at method-word ] curry { } map>assoc ; + [ dupd at ] curry { } map>assoc ; TUPLE: check-method class generic ; @@ -63,29 +61,33 @@ TUPLE: check-method class generic ; : method-word-name ( class word -- string ) word-name "/" rot word-name 3append ; -: make-method-def ( quot word combination -- quot ) +: make-method-def ( quot class generic -- quot ) "combination" word-prop method-prologue swap append ; -PREDICATE: word method-body "method" word-prop >boolean ; +PREDICATE: word method-body "method-def" word-prop >boolean ; M: method-body stack-effect - "method" word-prop method-generic stack-effect ; + "method-generic" word-prop stack-effect ; -: ( quot class generic -- word ) - [ make-method-def ] 2keep - method-word-name f - dup rot define - dup xref ; +: method-word-props ( quot class generic -- assoc ) + [ + "method-generic" set + "method-class" set + "method-def" set + ] H{ } make-assoc ; -: ( quot class generic -- method ) +: ( quot class generic -- word ) check-method - [ ] 3keep f \ method construct-boa - dup method-word over "method" set-word-prop ; + [ make-method-def ] 3keep + [ method-word-props ] 2keep + method-word-name f + tuck set-word-props + dup rot define ; : redefine-method ( quot class generic -- ) - [ method set-method-def ] 3keep + [ method swap "method-def" set-word-prop ] 3keep [ make-method-def ] 2keep - method method-word swap define ; + method swap define ; : define-method ( quot class generic -- ) >r bootstrap-word r> @@ -102,21 +104,22 @@ M: method-body stack-effect ! Definition protocol M: method-spec where - dup first2 method [ method-word ] [ second ] ?if where ; + dup first2 method [ ] [ second ] ?if where ; M: method-spec set-where - first2 method method-word set-where ; + first2 method set-where ; M: method-spec definer drop \ M: \ ; ; M: method-spec definition - first2 method dup [ method-def ] when ; + first2 method dup + [ "method-def" word-prop ] when ; : forget-method ( class generic -- ) check-method [ delete-at* ] with-methods - [ method-word forget-word ] [ drop ] if ; + [ forget-word ] [ drop ] if ; M: method-spec forget* first2 forget-method ; @@ -125,11 +128,11 @@ M: method-body definer drop \ M: \ ; ; M: method-body definition - "method" word-prop method-def ; + "method-def" word-prop ; M: method-body forget* - "method" word-prop - { method-specializer method-generic } get-slots + dup "method-class" word-prop + swap "method-generic" word-prop forget-method ; : implementors* ( classes -- words ) @@ -168,8 +171,7 @@ M: word subwords drop f ; M: generic subwords dup "methods" word-prop values - swap "default-method" word-prop add - [ method-word ] map ; + swap "default-method" word-prop add ; M: generic forget-word dup subwords [ forget-word ] each (forget-word) ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 0b2b9fcca3..27b0ddb7a2 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ; : applicable-method ( generic class -- quot ) over method - [ method-word word-def ] + [ word-def ] [ default-math-method ] ?if ; : object-method ( generic -- quot ) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 230ec446c7..313f487c99 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -69,7 +69,7 @@ TUPLE: no-method object generic ; ] if ; : default-method ( word -- pair ) - "default-method" word-prop method-word + "default-method" word-prop object bootstrap-word swap 2array ; : method-alist>quot ( alist base-class -- quot ) diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index cadf326692..2a2e6995eb 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -10,8 +10,7 @@ IN: inference.backend recursive-state get at ; : inline? ( word -- ? ) - dup "method" word-prop - [ method-generic inline? ] [ "inline" word-prop ] ?if ; + dup "method-generic" word-prop swap or "inline" word-prop ; : local-recursive-state ( -- assoc ) recursive-state get dup keys diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index f3709780f9..04d7ab4ee5 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -1,208 +1,208 @@ -! Copyright (C) 2004, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic assocs inference inference.class -inference.dataflow inference.backend inference.state io kernel -math namespaces sequences vectors words quotations hashtables -combinators classes generic.math continuations optimizer.def-use -optimizer.backend generic.standard optimizer.specializers -optimizer.def-use optimizer.pattern-match generic.standard -optimizer.control kernel.private ; -IN: optimizer.inlining - -: remember-inlining ( node history -- ) - [ swap set-node-history ] curry each-node ; - -: inlining-quot ( node quot -- node ) - over node-in-d dataflow-with - dup rot infer-classes/node ; - -: splice-quot ( #call quot history -- node ) - #! Must add history *before* splicing in, otherwise - #! the rest of the IR will also remember the history - pick node-history append - >r dupd inlining-quot dup r> remember-inlining - tuck splice-node ; - -! A heuristic to avoid excessive inlining -DEFER: (flat-length) - -: word-flat-length ( word -- n ) - { - ! heuristic: { ... } declare comes up in method bodies - ! and we don't care about it - { [ dup \ declare eq? ] [ drop -2 ] } - ! recursive - { [ dup get ] [ drop 1 ] } - ! not inline - { [ dup inline? not ] [ drop 1 ] } - ! inline - { [ t ] [ dup dup set word-def (flat-length) ] } - } cond ; - -: (flat-length) ( seq -- n ) - [ - { - { [ dup quotation? ] [ (flat-length) 1+ ] } - { [ dup array? ] [ (flat-length) ] } - { [ dup word? ] [ word-flat-length ] } - { [ t ] [ drop 1 ] } - } cond - ] map sum ; - -: flat-length ( seq -- n ) - [ word-def (flat-length) ] with-scope ; - -! Single dispatch method inlining optimization -: specific-method ( class word -- class ) order min-class ; - -: node-class# ( node n -- class ) - over node-in-d ?nth node-class ; - -: dispatching-class ( node word -- class ) - [ dispatch# node-class# ] keep specific-method ; - -: inline-standard-method ( node word -- node ) - 2dup dispatching-class dup [ - over +inlined+ depends-on - swap method method-word 1quotation f splice-quot - ] [ - 3drop t - ] if ; - -! Partial dispatch of math-generic words -: math-both-known? ( word left right -- ? ) - math-class-max swap specific-method ; - -: inline-math-method ( #call word -- node ) - over node-input-classes first2 3dup math-both-known? - [ math-method f splice-quot ] [ 2drop 2drop t ] if ; - -: inline-method ( #call -- node ) - dup node-param { - { [ dup standard-generic? ] [ inline-standard-method ] } - { [ dup math-generic? ] [ inline-math-method ] } - { [ t ] [ 2drop t ] } - } cond ; - -! Resolve type checks at compile time where possible -: comparable? ( actual testing -- ? ) - #! If actual is a subset of testing or if the two classes - #! are disjoint, return t. - 2dup class< >r classes-intersect? not r> or ; - -: optimize-predicate? ( #call -- ? ) - dup node-param "predicating" word-prop dup [ - >r node-class-first r> comparable? - ] [ - 2drop f - ] if ; - -: literal-quot ( node literals -- quot ) - #! Outputs a quotation which drops the node's inputs, and - #! pushes some literals. - >r node-in-d length \ drop - r> [ literalize ] map append >quotation ; - -: inline-literals ( node literals -- node ) - #! Make #shuffle -> #push -> #return -> successor - dupd literal-quot f splice-quot ; - -: evaluate-predicate ( #call -- ? ) - dup node-param "predicating" word-prop >r - node-class-first r> class< ; - -: optimize-predicate ( #call -- node ) - #! If the predicate is followed by a branch we fold it - #! immediately - dup evaluate-predicate swap - dup node-successor #if? [ - dup drop-inputs >r - node-successor swap 0 1 ? fold-branch - r> [ set-node-successor ] keep - ] [ - swap 1array inline-literals - ] if ; - -: optimizer-hooks ( node -- conditions ) - node-param "optimizer-hooks" word-prop ; - -: optimizer-hook ( node -- pair/f ) - dup optimizer-hooks [ first call ] find 2nip ; - -: optimize-hook ( node -- ) - dup optimizer-hook second call ; - -: define-optimizers ( word optimizers -- ) - "optimizer-hooks" set-word-prop ; - -: flush-eval? ( #call -- ? ) - dup node-param "flushable" word-prop [ - node-out-d [ unused? ] all? - ] [ - drop f - ] if ; - -: flush-eval ( #call -- node ) - dup node-param +inlined+ depends-on - dup node-out-d length f inline-literals ; - -: partial-eval? ( #call -- ? ) - dup node-param "foldable" word-prop [ - dup node-in-d [ node-literal? ] with all? - ] [ - drop f - ] if ; - -: literal-in-d ( #call -- inputs ) - dup node-in-d [ node-literal ] with map ; - -: partial-eval ( #call -- node ) - dup node-param +inlined+ depends-on - dup literal-in-d over node-param 1quotation - [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ; - -: define-identities ( words identities -- ) - [ "identities" set-word-prop ] curry each ; - -: find-identity ( node -- quot ) - [ node-param "identities" word-prop ] keep - [ swap first in-d-match? ] curry find - nip dup [ second ] when ; - -: apply-identities ( node -- node/f ) - dup find-identity dup [ f splice-quot ] [ 2drop f ] if ; - -: optimistic-inline? ( #call -- ? ) - dup node-param "specializer" word-prop dup [ - >r node-input-classes r> specialized-length tail* - [ types length 1 = ] all? - ] [ - 2drop f - ] if ; - -: splice-word-def ( #call word -- node ) - dup +inlined+ depends-on - dup word-def swap 1array splice-quot ; - -: optimistic-inline ( #call -- node ) - dup node-param over node-history memq? [ - drop t - ] [ - dup node-param splice-word-def - ] if ; - -: method-body-inline? ( #call -- ? ) - node-param dup method-body? - [ flat-length 10 <= ] [ drop f ] if ; - -M: #call optimize-node* - { - { [ dup flush-eval? ] [ flush-eval ] } - { [ dup partial-eval? ] [ partial-eval ] } - { [ dup find-identity ] [ apply-identities ] } - { [ dup optimizer-hook ] [ optimize-hook ] } - { [ dup optimize-predicate? ] [ optimize-predicate ] } - { [ dup optimistic-inline? ] [ optimistic-inline ] } - { [ dup method-body-inline? ] [ optimistic-inline ] } - { [ t ] [ inline-method ] } - } cond dup not ; +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays generic assocs inference inference.class +inference.dataflow inference.backend inference.state io kernel +math namespaces sequences vectors words quotations hashtables +combinators classes generic.math continuations optimizer.def-use +optimizer.backend generic.standard optimizer.specializers +optimizer.def-use optimizer.pattern-match generic.standard +optimizer.control kernel.private ; +IN: optimizer.inlining + +: remember-inlining ( node history -- ) + [ swap set-node-history ] curry each-node ; + +: inlining-quot ( node quot -- node ) + over node-in-d dataflow-with + dup rot infer-classes/node ; + +: splice-quot ( #call quot history -- node ) + #! Must add history *before* splicing in, otherwise + #! the rest of the IR will also remember the history + pick node-history append + >r dupd inlining-quot dup r> remember-inlining + tuck splice-node ; + +! A heuristic to avoid excessive inlining +DEFER: (flat-length) + +: word-flat-length ( word -- n ) + { + ! heuristic: { ... } declare comes up in method bodies + ! and we don't care about it + { [ dup \ declare eq? ] [ drop -2 ] } + ! recursive + { [ dup get ] [ drop 1 ] } + ! not inline + { [ dup inline? not ] [ drop 1 ] } + ! inline + { [ t ] [ dup dup set word-def (flat-length) ] } + } cond ; + +: (flat-length) ( seq -- n ) + [ + { + { [ dup quotation? ] [ (flat-length) 1+ ] } + { [ dup array? ] [ (flat-length) ] } + { [ dup word? ] [ word-flat-length ] } + { [ t ] [ drop 1 ] } + } cond + ] map sum ; + +: flat-length ( seq -- n ) + [ word-def (flat-length) ] with-scope ; + +! Single dispatch method inlining optimization +: specific-method ( class word -- class ) order min-class ; + +: node-class# ( node n -- class ) + over node-in-d ?nth node-class ; + +: dispatching-class ( node word -- class ) + [ dispatch# node-class# ] keep specific-method ; + +: inline-standard-method ( node word -- node ) + 2dup dispatching-class dup [ + over +inlined+ depends-on + swap method 1quotation f splice-quot + ] [ + 3drop t + ] if ; + +! Partial dispatch of math-generic words +: math-both-known? ( word left right -- ? ) + math-class-max swap specific-method ; + +: inline-math-method ( #call word -- node ) + over node-input-classes first2 3dup math-both-known? + [ math-method f splice-quot ] [ 2drop 2drop t ] if ; + +: inline-method ( #call -- node ) + dup node-param { + { [ dup standard-generic? ] [ inline-standard-method ] } + { [ dup math-generic? ] [ inline-math-method ] } + { [ t ] [ 2drop t ] } + } cond ; + +! Resolve type checks at compile time where possible +: comparable? ( actual testing -- ? ) + #! If actual is a subset of testing or if the two classes + #! are disjoint, return t. + 2dup class< >r classes-intersect? not r> or ; + +: optimize-predicate? ( #call -- ? ) + dup node-param "predicating" word-prop dup [ + >r node-class-first r> comparable? + ] [ + 2drop f + ] if ; + +: literal-quot ( node literals -- quot ) + #! Outputs a quotation which drops the node's inputs, and + #! pushes some literals. + >r node-in-d length \ drop + r> [ literalize ] map append >quotation ; + +: inline-literals ( node literals -- node ) + #! Make #shuffle -> #push -> #return -> successor + dupd literal-quot f splice-quot ; + +: evaluate-predicate ( #call -- ? ) + dup node-param "predicating" word-prop >r + node-class-first r> class< ; + +: optimize-predicate ( #call -- node ) + #! If the predicate is followed by a branch we fold it + #! immediately + dup evaluate-predicate swap + dup node-successor #if? [ + dup drop-inputs >r + node-successor swap 0 1 ? fold-branch + r> [ set-node-successor ] keep + ] [ + swap 1array inline-literals + ] if ; + +: optimizer-hooks ( node -- conditions ) + node-param "optimizer-hooks" word-prop ; + +: optimizer-hook ( node -- pair/f ) + dup optimizer-hooks [ first call ] find 2nip ; + +: optimize-hook ( node -- ) + dup optimizer-hook second call ; + +: define-optimizers ( word optimizers -- ) + "optimizer-hooks" set-word-prop ; + +: flush-eval? ( #call -- ? ) + dup node-param "flushable" word-prop [ + node-out-d [ unused? ] all? + ] [ + drop f + ] if ; + +: flush-eval ( #call -- node ) + dup node-param +inlined+ depends-on + dup node-out-d length f inline-literals ; + +: partial-eval? ( #call -- ? ) + dup node-param "foldable" word-prop [ + dup node-in-d [ node-literal? ] with all? + ] [ + drop f + ] if ; + +: literal-in-d ( #call -- inputs ) + dup node-in-d [ node-literal ] with map ; + +: partial-eval ( #call -- node ) + dup node-param +inlined+ depends-on + dup literal-in-d over node-param 1quotation + [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ; + +: define-identities ( words identities -- ) + [ "identities" set-word-prop ] curry each ; + +: find-identity ( node -- quot ) + [ node-param "identities" word-prop ] keep + [ swap first in-d-match? ] curry find + nip dup [ second ] when ; + +: apply-identities ( node -- node/f ) + dup find-identity dup [ f splice-quot ] [ 2drop f ] if ; + +: optimistic-inline? ( #call -- ? ) + dup node-param "specializer" word-prop dup [ + >r node-input-classes r> specialized-length tail* + [ types length 1 = ] all? + ] [ + 2drop f + ] if ; + +: splice-word-def ( #call word -- node ) + dup +inlined+ depends-on + dup word-def swap 1array splice-quot ; + +: optimistic-inline ( #call -- node ) + dup node-param over node-history memq? [ + drop t + ] [ + dup node-param splice-word-def + ] if ; + +: method-body-inline? ( #call -- ? ) + node-param dup method-body? + [ flat-length 10 <= ] [ drop f ] if ; + +M: #call optimize-node* + { + { [ dup flush-eval? ] [ flush-eval ] } + { [ dup partial-eval? ] [ partial-eval ] } + { [ dup find-identity ] [ apply-identities ] } + { [ dup optimizer-hook ] [ optimize-hook ] } + { [ dup optimize-predicate? ] [ optimize-predicate ] } + { [ dup optimistic-inline? ] [ optimistic-inline ] } + { [ dup method-body-inline? ] [ optimistic-inline ] } + { [ t ] [ inline-method ] } + } cond dup not ; diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 5116d66715..3abccecc7f 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -1,378 +1,378 @@ -USING: arrays compiler.units generic hashtables inference kernel -kernel.private math optimizer prettyprint sequences sbufs -strings tools.test vectors words sequences.private quotations -optimizer.backend classes inference.dataflow tuples.private -continuations growable optimizer.inlining namespaces hints ; -IN: optimizer.tests - -[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ - H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* -] unit-test - -[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [ - H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* -] unit-test - -! Test method inlining -[ f ] [ fixnum { } min-class ] unit-test - -[ string ] [ - \ string - [ integer string array reversed sbuf - slice vector quotation ] - sort-classes min-class -] unit-test - -[ fixnum ] [ - \ fixnum - [ fixnum integer object ] - sort-classes min-class -] unit-test - -[ integer ] [ - \ fixnum - [ integer float object ] - sort-classes min-class -] unit-test - -[ object ] [ - \ word - [ integer float object ] - sort-classes min-class -] unit-test - -[ reversed ] [ - \ reversed - [ integer reversed slice ] - sort-classes min-class -] unit-test - -GENERIC: xyz ( obj -- obj ) -M: array xyz xyz ; - -[ t ] [ \ xyz compiled? ] unit-test - -! Test predicate inlining -: pred-test-1 - dup fixnum? [ - dup integer? [ "integer" ] [ "nope" ] if - ] [ - "not a fixnum" - ] if ; - -[ 1 "integer" ] [ 1 pred-test-1 ] unit-test - -TUPLE: pred-test ; - -: pred-test-2 - dup tuple? [ - dup pred-test? [ "pred-test" ] [ "nope" ] if - ] [ - "not a tuple" - ] if ; - -[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test - -: pred-test-3 - dup pred-test? [ - dup tuple? [ "pred-test" ] [ "nope" ] if - ] [ - "not a tuple" - ] if ; - -[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test - -: inline-test - "nom" = ; - -[ t ] [ "nom" inline-test ] unit-test -[ f ] [ "shayin" inline-test ] unit-test -[ f ] [ 3 inline-test ] unit-test - -: fixnum-declarations >fixnum 24 shift 1234 bitxor ; - -[ ] [ 1000000 fixnum-declarations . ] unit-test - -! regression - -: literal-not-branch 0 not [ ] [ ] if ; - -[ ] [ literal-not-branch ] unit-test - -! regression - -: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline -: bad-kill-2 bad-kill-1 drop ; - -[ 3 ] [ t bad-kill-2 ] unit-test - -! regression -: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline -: the-test ( -- x y ) 2 dup (the-test) ; - -[ 2 0 ] [ the-test ] unit-test - -! regression -: (double-recursion) ( start end -- ) - < [ - 6 1 (double-recursion) - 3 2 (double-recursion) - ] when ; inline - -: double-recursion 0 2 (double-recursion) ; - -[ ] [ double-recursion ] unit-test - -! regression -: double-label-1 ( a b c -- d ) - [ f double-label-1 ] [ swap nth-unsafe ] if ; inline - -: double-label-2 ( a -- b ) - dup array? [ ] [ ] if 0 t double-label-1 ; - -[ 0 ] [ 10 double-label-2 ] unit-test - -! regression -GENERIC: void-generic ( obj -- * ) -: breakage "hi" void-generic ; -[ t ] [ \ breakage compiled? ] unit-test -[ breakage ] must-fail - -! regression -: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline -: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline -: test-2 ( -- ) 5 test-1 ; - -[ f ] [ f test-2 ] unit-test - -: branch-fold-regression-0 ( m -- n ) - t [ ] [ 1+ branch-fold-regression-0 ] if ; inline - -: branch-fold-regression-1 ( -- m ) - 10 branch-fold-regression-0 ; - -[ 10 ] [ branch-fold-regression-1 ] unit-test - -! another regression -: constant-branch-fold-0 "hey" ; foldable -: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline -[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test - -! another regression -: foo f ; -: bar foo 4 4 = and ; -[ f ] [ bar ] unit-test - -! ensure identities are working in some form -[ t ] [ - [ { number } declare 0 + ] dataflow optimize - [ #push? ] node-exists? not -] unit-test - -! compiling with a non-literal class failed -: -regression ; - -[ t ] [ \ -regression compiled? ] unit-test - -GENERIC: foozul ( a -- b ) -M: reversed foozul ; -M: integer foozul ; -M: slice foozul ; - -[ reversed ] [ reversed \ foozul specific-method ] unit-test - -! regression -: constant-fold-2 f ; foldable -: constant-fold-3 4 ; foldable - -[ f t ] [ - [ constant-fold-2 constant-fold-3 4 = ] compile-call -] unit-test - -: constant-fold-4 f ; foldable -: constant-fold-5 f ; foldable - -[ f ] [ - [ constant-fold-4 constant-fold-5 or ] compile-call -] unit-test - -[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test -[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test -[ 0 ] [ 5 [ dup - ] compile-call ] unit-test - -[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test -[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test -[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test -[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test - -[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test -[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test - -[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test -[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test -[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test -[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test -[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test -[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test -[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test -[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test -[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test - -[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test - -[ f ] [ 5 [ dup < ] compile-call ] unit-test -[ t ] [ 5 [ dup <= ] compile-call ] unit-test -[ f ] [ 5 [ dup > ] compile-call ] unit-test -[ t ] [ 5 [ dup >= ] compile-call ] unit-test - -[ t ] [ 5 [ dup eq? ] compile-call ] unit-test -[ t ] [ 5 [ dup = ] compile-call ] unit-test -[ t ] [ 5 [ dup number= ] compile-call ] unit-test -[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test - -GENERIC: detect-number ( obj -- obj ) -M: number detect-number ; - -[ 10 f [ 0 + detect-number ] compile-call ] must-fail - -! Regression -[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test - -! Regression -USE: sorting -USE: sorting.private - -: old-binsearch ( elt quot seq -- elt quot i ) - dup length 1 <= [ - slice-from - ] [ - [ midpoint swap call ] 3keep roll dup zero? - [ drop dup slice-from swap midpoint@ + ] - [ partition old-binsearch ] if - ] if ; inline - -[ 10 ] [ - 10 20 >vector - [ [ - ] swap old-binsearch ] compile-call 2nip -] unit-test - -! Regression -TUPLE: silly-tuple a b ; - -[ 1 2 { silly-tuple-a silly-tuple-b } ] [ - T{ silly-tuple f 1 2 } - [ - { silly-tuple-a silly-tuple-b } [ get-slots ] keep - ] compile-call -] unit-test - -! Regression -: empty-compound ; - -: node-successor-f-bug ( x -- * ) - [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; - -[ t ] [ \ node-successor-f-bug compiled? ] unit-test - -[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test - -[ ] [ [ ] dataflow optimize drop ] unit-test - -! Make sure we have sane heuristics -: should-inline? method method-word flat-length 10 <= ; - -[ t ] [ \ fixnum \ shift should-inline? ] unit-test -[ f ] [ \ array \ equal? should-inline? ] unit-test -[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test -[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test -[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test -[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test - -! Regression -: lift-throw-tail-regression - dup integer? [ "an integer" ] [ - dup string? [ "a string" ] [ - "error" throw - ] if - ] if ; - -[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test -[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test -[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test - -: lift-loop-tail-test-1 ( a quot -- ) - over even? [ - [ >r 3 - r> call ] keep lift-loop-tail-test-1 - ] [ - over 0 < [ - 2drop - ] [ - [ >r 2 - r> call ] keep lift-loop-tail-test-1 - ] if - ] if ; inline - -: lift-loop-tail-test-2 - 10 [ ] lift-loop-tail-test-1 1 2 3 ; - -[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test - -! Make sure we don't lose -GENERIC: generic-inline-test ( x -- y ) -M: integer generic-inline-test ; - -: generic-inline-test-1 - 1 - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test ; - -[ { t f } ] [ - \ generic-inline-test-1 word-def dataflow - [ optimize-1 , optimize-1 , drop ] { } make -] unit-test - -! Forgot a recursive inline check -: recursive-inline-hang ( a -- a ) - dup array? [ recursive-inline-hang ] when ; - -HINTS: recursive-inline-hang array ; - -: recursive-inline-hang-1 - { } recursive-inline-hang ; - -[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test - -DEFER: recursive-inline-hang-3 - -: recursive-inline-hang-2 ( a -- a ) - dup array? [ recursive-inline-hang-3 ] when ; - -HINTS: recursive-inline-hang-2 array ; - -: recursive-inline-hang-3 ( a -- a ) - dup array? [ recursive-inline-hang-2 ] when ; - -HINTS: recursive-inline-hang-3 array ; - - +USING: arrays compiler.units generic hashtables inference kernel +kernel.private math optimizer prettyprint sequences sbufs +strings tools.test vectors words sequences.private quotations +optimizer.backend classes inference.dataflow tuples.private +continuations growable optimizer.inlining namespaces hints ; +IN: optimizer.tests + +[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ + H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* +] unit-test + +[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [ + H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* +] unit-test + +! Test method inlining +[ f ] [ fixnum { } min-class ] unit-test + +[ string ] [ + \ string + [ integer string array reversed sbuf + slice vector quotation ] + sort-classes min-class +] unit-test + +[ fixnum ] [ + \ fixnum + [ fixnum integer object ] + sort-classes min-class +] unit-test + +[ integer ] [ + \ fixnum + [ integer float object ] + sort-classes min-class +] unit-test + +[ object ] [ + \ word + [ integer float object ] + sort-classes min-class +] unit-test + +[ reversed ] [ + \ reversed + [ integer reversed slice ] + sort-classes min-class +] unit-test + +GENERIC: xyz ( obj -- obj ) +M: array xyz xyz ; + +[ t ] [ \ xyz compiled? ] unit-test + +! Test predicate inlining +: pred-test-1 + dup fixnum? [ + dup integer? [ "integer" ] [ "nope" ] if + ] [ + "not a fixnum" + ] if ; + +[ 1 "integer" ] [ 1 pred-test-1 ] unit-test + +TUPLE: pred-test ; + +: pred-test-2 + dup tuple? [ + dup pred-test? [ "pred-test" ] [ "nope" ] if + ] [ + "not a tuple" + ] if ; + +[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test + +: pred-test-3 + dup pred-test? [ + dup tuple? [ "pred-test" ] [ "nope" ] if + ] [ + "not a tuple" + ] if ; + +[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test + +: inline-test + "nom" = ; + +[ t ] [ "nom" inline-test ] unit-test +[ f ] [ "shayin" inline-test ] unit-test +[ f ] [ 3 inline-test ] unit-test + +: fixnum-declarations >fixnum 24 shift 1234 bitxor ; + +[ ] [ 1000000 fixnum-declarations . ] unit-test + +! regression + +: literal-not-branch 0 not [ ] [ ] if ; + +[ ] [ literal-not-branch ] unit-test + +! regression + +: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline +: bad-kill-2 bad-kill-1 drop ; + +[ 3 ] [ t bad-kill-2 ] unit-test + +! regression +: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline +: the-test ( -- x y ) 2 dup (the-test) ; + +[ 2 0 ] [ the-test ] unit-test + +! regression +: (double-recursion) ( start end -- ) + < [ + 6 1 (double-recursion) + 3 2 (double-recursion) + ] when ; inline + +: double-recursion 0 2 (double-recursion) ; + +[ ] [ double-recursion ] unit-test + +! regression +: double-label-1 ( a b c -- d ) + [ f double-label-1 ] [ swap nth-unsafe ] if ; inline + +: double-label-2 ( a -- b ) + dup array? [ ] [ ] if 0 t double-label-1 ; + +[ 0 ] [ 10 double-label-2 ] unit-test + +! regression +GENERIC: void-generic ( obj -- * ) +: breakage "hi" void-generic ; +[ t ] [ \ breakage compiled? ] unit-test +[ breakage ] must-fail + +! regression +: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline +: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline +: test-2 ( -- ) 5 test-1 ; + +[ f ] [ f test-2 ] unit-test + +: branch-fold-regression-0 ( m -- n ) + t [ ] [ 1+ branch-fold-regression-0 ] if ; inline + +: branch-fold-regression-1 ( -- m ) + 10 branch-fold-regression-0 ; + +[ 10 ] [ branch-fold-regression-1 ] unit-test + +! another regression +: constant-branch-fold-0 "hey" ; foldable +: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline +[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test + +! another regression +: foo f ; +: bar foo 4 4 = and ; +[ f ] [ bar ] unit-test + +! ensure identities are working in some form +[ t ] [ + [ { number } declare 0 + ] dataflow optimize + [ #push? ] node-exists? not +] unit-test + +! compiling with a non-literal class failed +: -regression ; + +[ t ] [ \ -regression compiled? ] unit-test + +GENERIC: foozul ( a -- b ) +M: reversed foozul ; +M: integer foozul ; +M: slice foozul ; + +[ reversed ] [ reversed \ foozul specific-method ] unit-test + +! regression +: constant-fold-2 f ; foldable +: constant-fold-3 4 ; foldable + +[ f t ] [ + [ constant-fold-2 constant-fold-3 4 = ] compile-call +] unit-test + +: constant-fold-4 f ; foldable +: constant-fold-5 f ; foldable + +[ f ] [ + [ constant-fold-4 constant-fold-5 or ] compile-call +] unit-test + +[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test +[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test +[ 0 ] [ 5 [ dup - ] compile-call ] unit-test + +[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test +[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test +[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test +[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test + +[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test +[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test + +[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test +[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test +[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test +[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test +[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test +[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test +[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test +[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test +[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test + +[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test + +[ f ] [ 5 [ dup < ] compile-call ] unit-test +[ t ] [ 5 [ dup <= ] compile-call ] unit-test +[ f ] [ 5 [ dup > ] compile-call ] unit-test +[ t ] [ 5 [ dup >= ] compile-call ] unit-test + +[ t ] [ 5 [ dup eq? ] compile-call ] unit-test +[ t ] [ 5 [ dup = ] compile-call ] unit-test +[ t ] [ 5 [ dup number= ] compile-call ] unit-test +[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test + +GENERIC: detect-number ( obj -- obj ) +M: number detect-number ; + +[ 10 f [ 0 + detect-number ] compile-call ] must-fail + +! Regression +[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test + +! Regression +USE: sorting +USE: sorting.private + +: old-binsearch ( elt quot seq -- elt quot i ) + dup length 1 <= [ + slice-from + ] [ + [ midpoint swap call ] 3keep roll dup zero? + [ drop dup slice-from swap midpoint@ + ] + [ partition old-binsearch ] if + ] if ; inline + +[ 10 ] [ + 10 20 >vector + [ [ - ] swap old-binsearch ] compile-call 2nip +] unit-test + +! Regression +TUPLE: silly-tuple a b ; + +[ 1 2 { silly-tuple-a silly-tuple-b } ] [ + T{ silly-tuple f 1 2 } + [ + { silly-tuple-a silly-tuple-b } [ get-slots ] keep + ] compile-call +] unit-test + +! Regression +: empty-compound ; + +: node-successor-f-bug ( x -- * ) + [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; + +[ t ] [ \ node-successor-f-bug compiled? ] unit-test + +[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test + +[ ] [ [ ] dataflow optimize drop ] unit-test + +! Make sure we have sane heuristics +: should-inline? method flat-length 10 <= ; + +[ t ] [ \ fixnum \ shift should-inline? ] unit-test +[ f ] [ \ array \ equal? should-inline? ] unit-test +[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test +[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test + +! Regression +: lift-throw-tail-regression + dup integer? [ "an integer" ] [ + dup string? [ "a string" ] [ + "error" throw + ] if + ] if ; + +[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test +[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test +[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test + +: lift-loop-tail-test-1 ( a quot -- ) + over even? [ + [ >r 3 - r> call ] keep lift-loop-tail-test-1 + ] [ + over 0 < [ + 2drop + ] [ + [ >r 2 - r> call ] keep lift-loop-tail-test-1 + ] if + ] if ; inline + +: lift-loop-tail-test-2 + 10 [ ] lift-loop-tail-test-1 1 2 3 ; + +[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test + +! Make sure we don't lose +GENERIC: generic-inline-test ( x -- y ) +M: integer generic-inline-test ; + +: generic-inline-test-1 + 1 + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test ; + +[ { t f } ] [ + \ generic-inline-test-1 word-def dataflow + [ optimize-1 , optimize-1 , drop ] { } make +] unit-test + +! Forgot a recursive inline check +: recursive-inline-hang ( a -- a ) + dup array? [ recursive-inline-hang ] when ; + +HINTS: recursive-inline-hang array ; + +: recursive-inline-hang-1 + { } recursive-inline-hang ; + +[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test + +DEFER: recursive-inline-hang-3 + +: recursive-inline-hang-2 ( a -- a ) + dup array? [ recursive-inline-hang-3 ] when ; + +HINTS: recursive-inline-hang-2 array ; + +: recursive-inline-hang-3 ( a -- a ) + dup array? [ recursive-inline-hang-2 ] when ; + +HINTS: recursive-inline-hang-3 array ; + + diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 2efc9b4e67..6cb03e4199 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -175,10 +175,10 @@ M: method-spec synopsis* dup definer. [ pprint-word ] each ; M: method-body synopsis* - dup definer. - "method" word-prop dup - method-specializer pprint* - method-generic pprint* ; + dup dup + definer. + "method-class" word-prop pprint* + "method-generic" word-prop pprint* ; M: mixin-instance synopsis* dup definer. @@ -269,7 +269,7 @@ M: builtin-class see-class* : see-implementors ( class -- seq ) dup implementors - [ method method-word ] with map + [ method ] with map natural-sort ; : see-class ( class -- ) @@ -280,9 +280,7 @@ M: builtin-class see-class* ] when drop ; : see-methods ( generic -- seq ) - "methods" word-prop - [ nip method-word ] { } assoc>map - natural-sort ; + "methods" word-prop values natural-sort ; M: word see dup see-class diff --git a/core/words/words.factor b/core/words/words.factor index e8b3fd9781..c9505d3d1d 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -68,7 +68,7 @@ SYMBOL: bootstrapping? : crossref? ( word -- ? ) { { [ dup "forgotten" word-prop ] [ f ] } - { [ dup "method" word-prop ] [ t ] } + { [ dup "method-definition" word-prop ] [ t ] } { [ dup word-vocabulary ] [ t ] } { [ t ] [ f ] } } cond nip ; From e156e0212ca1646dc677c542369bc5d52790ee63 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 4 Mar 2008 22:32:12 -0600 Subject: [PATCH 10/36] add a c-struct update a using --- extra/windows/kernel32/kernel32.factor | 12 ++++ extra/windows/time/time.factor | 78 +++++++++++++------------- 2 files changed, 51 insertions(+), 39 deletions(-) diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 3574df36db..37b833cae1 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -445,6 +445,18 @@ C-STRUCT: WIN32_FIND_DATA { { "TCHAR" 260 } "cFileName" } { { "TCHAR" 14 } "cAlternateFileName" } ; +C-STRUCT: BY_HANDLE_FILE_INFORMATION + { "DWORD" "dwFileAttributes" } + { "FILETIME" "ftCreationTime" } + { "FILETIME" "ftLastAccessTime" } + { "FILETIME" "ftLastWriteTime" } + { "DWORD" "dwVolumeSerialNumber" } + { "DWORD" "nFileSizeHigh" } + { "DWORD" "nFileSizeLow" } + { "DWORD" "nNumberOfLinks" } + { "DWORD" "nFileIndexHigh" } + { "DWORD" "nFileIndexLow" } ; + TYPEDEF: WIN32_FIND_DATA* PWIN32_FIND_DATA TYPEDEF: WIN32_FIND_DATA* LPWIN32_FIND_DATA TYPEDEF: void* POVERLAPPED diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor index 62d2805f01..e910ca2888 100755 --- a/extra/windows/time/time.factor +++ b/extra/windows/time/time.factor @@ -1,39 +1,39 @@ -! Copyright (C) 2007 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types kernel math windows windows.kernel32 -namespaces calendar.backend ; -IN: windows.time - -: >64bit ( lo hi -- n ) - 32 shift bitor ; - -: windows-1601 ( -- timestamp ) - 1601 1 1 0 0 0 0 ; - -: FILETIME>windows-time ( FILETIME -- n ) - [ FILETIME-dwLowDateTime ] keep - FILETIME-dwHighDateTime >64bit ; - -: windows-time>timestamp ( n -- timestamp ) - 10000000 /i seconds windows-1601 swap time+ ; - -: windows-time ( -- n ) - "FILETIME" [ GetSystemTimeAsFileTime ] keep - FILETIME>windows-time ; - -: timestamp>windows-time ( timestamp -- n ) - #! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC) - >gmt windows-1601 (time-) 10000000 * >integer ; - -: windows-time>FILETIME ( n -- FILETIME ) - "FILETIME" - [ - [ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep - >r -32 shift r> set-FILETIME-dwHighDateTime - ] keep ; - -: timestamp>FILETIME ( timestamp -- FILETIME/f ) - [ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ; - -: FILETIME>timestamp ( FILETIME -- timestamp/f ) - FILETIME>windows-time windows-time>timestamp ; +! Copyright (C) 2007 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types kernel math windows windows.kernel32 +namespaces calendar calendar.backend ; +IN: windows.time + +: >64bit ( lo hi -- n ) + 32 shift bitor ; + +: windows-1601 ( -- timestamp ) + 1601 1 1 0 0 0 0 ; + +: FILETIME>windows-time ( FILETIME -- n ) + [ FILETIME-dwLowDateTime ] keep + FILETIME-dwHighDateTime >64bit ; + +: windows-time>timestamp ( n -- timestamp ) + 10000000 /i seconds windows-1601 swap time+ ; + +: windows-time ( -- n ) + "FILETIME" [ GetSystemTimeAsFileTime ] keep + FILETIME>windows-time ; + +: timestamp>windows-time ( timestamp -- n ) + #! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC) + >gmt windows-1601 (time-) 10000000 * >integer ; + +: windows-time>FILETIME ( n -- FILETIME ) + "FILETIME" + [ + [ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep + >r -32 shift r> set-FILETIME-dwHighDateTime + ] keep ; + +: timestamp>FILETIME ( timestamp -- FILETIME/f ) + [ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ; + +: FILETIME>timestamp ( FILETIME -- timestamp/f ) + FILETIME>windows-time windows-time>timestamp ; From 5c93d43aa124b4618be99afb29846ab70e3f6216 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 4 Mar 2008 22:32:42 -0600 Subject: [PATCH 11/36] add some more bit-twiddling words --- extra/math/functions/functions.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor index 59ade44365..85e07fe73f 100755 --- a/extra/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -34,6 +34,10 @@ M: real sqrt : set-bit ( x n -- y ) 2^ bitor ; foldable : bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable : bit-set? ( x n -- ? ) bit-clear? not ; foldable +: unmask ( x n -- ? ) bitnot bitand ; foldable +: unmask? ( x n -- ? ) unmask 0 > ; foldable +: mask ( x n -- ? ) bitand ; foldable +: mask? ( x n -- ? ) mask 0 > ; foldable GENERIC: (^) ( x y -- z ) foldable From 6282a4ec5d42c2ec4a1279b47309182352dce5ec Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 4 Mar 2008 22:35:45 -0600 Subject: [PATCH 12/36] add windows replacement for stat --- extra/io/windows/files/files.factor | 108 ++++++++++++++++++++++++++++ 1 file changed, 108 insertions(+) create mode 100644 extra/io/windows/files/files.factor diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor new file mode 100644 index 0000000000..fdd574d00e --- /dev/null +++ b/extra/io/windows/files/files.factor @@ -0,0 +1,108 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types io.files io.windows kernel +math windows windows.kernel32 combinators.cleave +windows.time calendar combinators math.functions +sequences combinators.lib namespaces words ; +IN: io.windows.files + +SYMBOL: +read-only+ +SYMBOL: +hidden+ +SYMBOL: +system+ +SYMBOL: +directory+ +SYMBOL: +archive+ +SYMBOL: +device+ +SYMBOL: +normal+ +SYMBOL: +temporary+ +SYMBOL: +sparse-file+ +SYMBOL: +reparse-point+ +SYMBOL: +compressed+ +SYMBOL: +offline+ +SYMBOL: +not-content-indexed+ +SYMBOL: +encrypted+ + +: expand-constants ( word/obj -- obj'/obj ) + dup word? [ execute ] when ; + +: get-flags ( n seq -- seq' ) + [ + [ + first2 expand-constants + [ swapd mask? [ , ] [ drop ] if ] 2curry + ] map call-with + ] { } make ; + +: win32-file-attributes ( n -- seq ) + { + { +read-only+ FILE_ATTRIBUTE_READONLY } + { +hidden+ FILE_ATTRIBUTE_HIDDEN } + { +system+ FILE_ATTRIBUTE_SYSTEM } + { +directory+ FILE_ATTRIBUTE_DIRECTORY } + { +archive+ FILE_ATTRIBUTE_ARCHIVE } + { +device+ FILE_ATTRIBUTE_DEVICE } + { +normal+ FILE_ATTRIBUTE_NORMAL } + { +temporary+ FILE_ATTRIBUTE_TEMPORARY } + { +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE } + { +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT } + { +compressed+ FILE_ATTRIBUTE_COMPRESSED } + { +offline+ FILE_ATTRIBUTE_OFFLINE } + { +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED } + { +encrypted+ FILE_ATTRIBUTE_ENCRYPTED } + } get-flags ; + +: WIN32_FIND_DATA>file-info + { + [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ] + [ + [ WIN32_FIND_DATA-nFileSizeLow ] + [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit + ] + [ WIN32_FIND_DATA-dwFileAttributes ] + [ + WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp + ] + } cleave + \ file-info construct-boa ; + +: find-first-file-stat ( path -- WIN32_FIND_DATA ) + "WIN32_FIND_DATA" [ + FindFirstFile + [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep + FindClose win32-error=0/f + ] keep ; + +: BY_HANDLE_FILE_INFORMATION>file-info + { + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes ] + [ + [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ] + [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit + ] + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes ] + [ + BY_HANDLE_FILE_INFORMATION-ftLastWriteTime + FILETIME>timestamp + ] + } cleave + \ file-info construct-boa ; + +: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION ) + [ + "BY_HANDLE_FILE_INFORMATION" + [ GetFileInformationByHandle win32-error=0/f ] keep + ] keep CloseHandle win32-error=0/f ; + +: get-file-information-stat ( path -- BY_HANDLE_FILE_INFORMATION ) + dup + GENERIC_READ FILE_SHARE_READ f + OPEN_EXISTING FILE_FLAG_BACKUP_SEMANTICS f + CreateFileW dup INVALID_HANDLE_VALUE = [ + drop find-first-file-stat WIN32_FIND_DATA>file-info + ] [ + nip + get-file-information BY_HANDLE_FILE_INFORMATION>file-info + ] if ; + +M: windows-nt-io file-info ( path -- info ) + get-file-information-stat ; + From c51ad0aa5a7af55782f0ae5aed8cce039b015b2a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 Mar 2008 22:44:46 -0600 Subject: [PATCH 13/36] Update modules for method changes --- extra/locals/locals.factor | 12 ++++++------ extra/tools/profiler/profiler.factor | 5 ++--- 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 2e6fd6485d..79af9e63f8 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -279,7 +279,7 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ; ! are unified : create-method ( class generic -- method ) 2dup method dup - [ 2nip method-word ] + [ 2nip ] [ drop 2dup [ ] -rot define-method create-method ] if ; : CREATE-METHOD ( -- class generic body ) @@ -369,14 +369,14 @@ M: lambda-method definition : method-stack-effect dup "lambda" word-prop lambda-vars - swap "method" word-prop method-generic stack-effect dup [ effect-out ] when + swap "method-generic" word-prop stack-effect + dup [ effect-out ] when ; M: lambda-method synopsis* - dup definer. - dup "method" word-prop dup - method-specializer pprint* - method-generic pprint* + dup dup definer. + "method-specializer" word-prop pprint* + "method-generic" word-prop pprint* method-stack-effect effect>string comment. ; PRIVATE> diff --git a/extra/tools/profiler/profiler.factor b/extra/tools/profiler/profiler.factor index 784c9e8da6..467fcc14f4 100755 --- a/extra/tools/profiler/profiler.factor +++ b/extra/tools/profiler/profiler.factor @@ -29,9 +29,8 @@ M: string (profile.) dup write-object ; M: method-body (profile.) - "method" word-prop - dup method-specializer over method-generic 2array synopsis - swap method-generic write-object ; + dup synopsis swap "method-generic" word-prop + write-object ; : counter. ( obj n -- ) [ From e933cf97fe035697209df546430393445c2b0ab3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 Mar 2008 22:46:01 -0600 Subject: [PATCH 14/36] Add $vocab-subsection --- core/vocabs/vocabs.factor | 2 ++ extra/help/markup/markup.factor | 26 ++++++++++++++----- extra/logging/insomniac/insomniac-docs.factor | 2 +- extra/logging/logging-docs.factor | 6 ++--- 4 files changed, 25 insertions(+), 11 deletions(-) mode change 100644 => 100755 extra/help/markup/markup.factor mode change 100644 => 100755 extra/logging/insomniac/insomniac-docs.factor mode change 100644 => 100755 extra/logging/logging-docs.factor diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 720a1ef645..1a3fecc3fb 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -55,6 +55,8 @@ M: f vocab-docs-loaded? ; M: f set-vocab-docs-loaded? 2drop ; +M: f vocab-help ; + : create-vocab ( name -- vocab ) dictionary get [ ] cache ; diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor old mode 100644 new mode 100755 index 5f1b027823..a866293bbe --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -144,20 +144,32 @@ M: f print-element drop ; : $link ( element -- ) first ($link) ; -: ($subsection) ( object -- ) - [ article-title ] keep >link write-object ; +: ($long-link) ( object -- ) + dup article-title swap >link write-link ; -: $subsection ( element -- ) +: ($subsection) ( element quot -- ) [ subsection-style get [ bullet get write bl - first ($subsection) + call ] with-style - ] ($block) ; + ] ($block) ; inline -: ($vocab-link) ( vocab -- ) dup f >vocab-link write-link ; +: $subsection ( element -- ) + [ first ($long-link) ] ($subsection) ; -: $vocab-link ( element -- ) first ($vocab-link) ; +: ($vocab-link) ( text vocab -- ) f >vocab-link write-link ; + +: $vocab-subsection ( element -- ) + [ + first2 dup vocab-help dup [ + 2nip ($long-link) + ] [ + drop ($vocab-link) + ] if + ] ($subsection) ; + +: $vocab-link ( element -- ) first dup ($vocab-link) ; : $vocabulary ( element -- ) first word-vocabulary [ diff --git a/extra/logging/insomniac/insomniac-docs.factor b/extra/logging/insomniac/insomniac-docs.factor old mode 100644 new mode 100755 index 64ac3b4ff6..93485e4c7c --- a/extra/logging/insomniac/insomniac-docs.factor +++ b/extra/logging/insomniac/insomniac-docs.factor @@ -27,7 +27,7 @@ HELP: schedule-insomniac { $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } } { $description "Starts a thread which e-mails log reports and rotates logs daily." } ; -ARTICLE: "logging.insomniac" "Automating log analysis and rotation" +ARTICLE: "logging.insomniac" "Automated log analysis" "The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary." $nl "Required configuration parameters:" diff --git a/extra/logging/logging-docs.factor b/extra/logging/logging-docs.factor old mode 100644 new mode 100755 index 939388026d..715b1551b9 --- a/extra/logging/logging-docs.factor +++ b/extra/logging/logging-docs.factor @@ -115,9 +115,9 @@ ARTICLE: "logging" "Logging framework" { $subsection "logging.levels" } { $subsection "logging.messages" } { $subsection "logging.rotation" } -{ $subsection "logging.parser" } -{ $subsection "logging.analysis" } -{ $subsection "logging.insomniac" } +{ $vocab-subsection "Log file parser" "logging.parser" } +{ $vocab-subsection "Log analysis" "logging.analysis" } +{ $vocab-subsection "Automated log analysis" "logging.insomniac" } { $subsection "logging.server" } ; ABOUT: "logging" From 4fd4882e024aabf424272208881ab170424d33b2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 13:51:31 -0600 Subject: [PATCH 15/36] fix unit tests --- extra/db/postgresql/postgresql-tests.factor | 259 -------------------- extra/db/sqlite/sqlite-tests.factor | 194 +-------------- 2 files changed, 12 insertions(+), 441 deletions(-) diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor index 250f98f73e..a6c2975c89 100755 --- a/extra/db/postgresql/postgresql-tests.factor +++ b/extra/db/postgresql/postgresql-tests.factor @@ -33,24 +33,6 @@ IN: db.postgresql.tests ] with-db ] unit-test -[ - { { "John" "America" } } -] [ - test-db [ - "select * from person where name = $1 and country = $2" - f f [ - { { "Jane" TEXT } { "New Zealand" TEXT } } - over do-bound-query - - { { "Jane" "New Zealand" } } = - [ "test fails" throw ] unless - - { { "John" TEXT } { "America" TEXT } } - swap do-bound-query - ] with-disposal - ] with-db -] unit-test - [ { { "John" "America" } @@ -111,244 +93,3 @@ IN: db.postgresql.tests : with-dummy-db ( quot -- ) >r T{ postgresql-db } db r> with-variable ; - -! TEST TUPLE DB - -TUPLE: puppy id name age ; -: ( name age -- puppy ) - { set-puppy-name set-puppy-age } puppy construct ; - -puppy "PUPPY" { - { "id" "ID" +native-id+ +not-null+ } - { "name" "NAME" { VARCHAR 256 } } - { "age" "AGE" INTEGER } -} define-persistent - -TUPLE: kitty id name age ; -: ( name age -- kitty ) - { set-kitty-name set-kitty-age } kitty construct ; - -kitty "KITTY" { - { "id" "ID" INTEGER +assigned-id+ } - { "name" "NAME" TEXT } - { "age" "AGE" INTEGER } -} define-persistent - -TUPLE: basket id puppies kitties ; -basket "BASKET" -{ - { "id" "ID" +native-id+ +not-null+ } - { "location" "LOCATION" TEXT } - { "puppies" { +has-many+ puppy } } - { "kitties" { +has-many+ kitty } } -} define-persistent - -! Create table -[ - "create table puppy(id serial primary key not null, name varchar 256, age integer);" -] [ - T{ postgresql-db } db [ - puppy dup db-columns swap db-table create-table-sql >lower - ] with-variable -] unit-test - -[ - "create table kitty(id integer primary key, name text, age integer);" -] [ - T{ postgresql-db } db [ - kitty dup db-columns swap db-table create-table-sql >lower - ] with-variable -] unit-test - -[ - "create table basket(id serial primary key not null, location text);" -] [ - T{ postgresql-db } db [ - basket dup db-columns swap db-table create-table-sql >lower - ] with-variable -] unit-test - -! Create function -[ - "create function add_puppy(varchar,integer) returns bigint as 'insert into puppy(name, age) values($1, $2); select currval(''puppy_id_seq'');' language sql;" -] [ - T{ postgresql-db } db [ - puppy dup db-columns swap db-table create-function-sql >lower - ] with-variable -] unit-test - -! Drop table - -[ - "drop table puppy;" -] [ - T{ postgresql-db } db [ - puppy db-table drop-table-sql >lower - ] with-variable -] unit-test - -[ - "drop table kitty;" -] [ - T{ postgresql-db } db [ - kitty db-table drop-table-sql >lower - ] with-variable -] unit-test - -[ - "drop table basket;" -] [ - T{ postgresql-db } db [ - basket db-table drop-table-sql >lower - ] with-variable -] unit-test - - -! Drop function -[ - "drop function add_puppy(varchar, integer);" -] [ - T{ postgresql-db } db [ - puppy dup db-columns swap db-table drop-function-sql >lower - ] with-variable -] unit-test - -! Insert -[ -] [ - T{ postgresql-db } db [ - puppy - ] with-variable -] unit-test - -[ - "insert into kitty(id, name, age) values($1, $2, $3);" - { - T{ - sql-spec - f - "id" - "ID" - INTEGER - { +assigned-id+ } - +assigned-id+ - } - T{ sql-spec f "name" "NAME" TEXT { } f } - T{ sql-spec f "age" "AGE" INTEGER { } f } - } - { } -] [ - T{ postgresql-db } db [ - kitty - ] with-variable -] unit-test - -! Update -[ - "update puppy set name = $1, age = $2 where id = $3" - { - T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } - T{ sql-spec f "age" "AGE" INTEGER { } f } - T{ - sql-spec - f - "id" - "ID" - +native-id+ - { +not-null+ } - +native-id+ - } - } - { } -] [ - T{ postgresql-db } db [ - puppy dup db-columns swap db-table >r >r >lower r> r> - ] with-variable -] unit-test - -[ - "update kitty set name = $1, age = $2 where id = $3" - { - T{ sql-spec f "name" "NAME" TEXT { } f } - T{ sql-spec f "age" "AGE" INTEGER { } f } - T{ - sql-spec - f - "id" - "ID" - INTEGER - { +assigned-id+ } - +assigned-id+ - } - } - { } -] [ - T{ postgresql-db } db [ - kitty dup db-columns swap db-table >r >r >lower r> r> - ] with-variable -] unit-test - -! Delete -[ - "delete from puppy where id = $1" - { - T{ - sql-spec - f - "id" - "ID" - +native-id+ - { +not-null+ } - +native-id+ - } - } - { } -] [ - T{ postgresql-db } db [ - puppy dup db-columns swap db-table >r >r >lower r> r> - ] with-variable -] unit-test - -[ - "delete from KITTY where ID = $1" - { - T{ - sql-spec - f - "id" - "ID" - INTEGER - { +assigned-id+ } - +assigned-id+ - } - } - { } -] [ - T{ postgresql-db } db [ - kitty dup db-columns swap db-table - ] with-variable -] unit-test - -! Select -[ - "select from PUPPY ID, NAME, AGE where NAME = $1;" - { T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } } - { - T{ - sql-spec - f - "id" - "ID" - +native-id+ - { +not-null+ } - +native-id+ - } - T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } - T{ sql-spec f "age" "AGE" INTEGER { } f } - } -] [ - T{ postgresql-db } db [ - T{ puppy f f "Mr. Clunkers" } - - ] with-variable -] unit-test diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor index 974fdb8782..08139610a0 100755 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -3,49 +3,34 @@ prettyprint tools.test db.sqlite db sequences continuations db.types db.tuples unicode.case ; IN: db.sqlite.tests -: test.db "extra/db/sqlite/test.db" resource-path ; +: db-path "extra/db/sqlite/test.db" resource-path ; +: test.db db-path sqlite-db ; -[ ] [ [ test.db delete-file ] ignore-errors ] unit-test +[ ] [ [ db-path delete-file ] ignore-errors ] unit-test [ ] [ test.db [ "create table person (name varchar(30), country varchar(30))" sql-command "insert into person values('John', 'America')" sql-command "insert into person values('Jane', 'New Zealand')" sql-command - ] with-sqlite + ] with-db ] unit-test [ { { "John" "America" } { "Jane" "New Zealand" } } ] [ test.db [ "select * from person" sql-query - ] with-sqlite -] unit-test - -[ { { "John" "America" } } ] [ - test.db [ - "select * from person where name = :name and country = :country" - [ - { { ":name" "Jane" TEXT } { ":country" "New Zealand" TEXT } } - over do-bound-query - - { { "Jane" "New Zealand" } } = - [ "test fails" throw ] unless - - { { ":name" "John" TEXT } { ":country" "America" TEXT } } - swap do-bound-query - ] with-disposal - ] with-sqlite + ] with-db ] unit-test [ { { "1" "John" "America" } { "2" "Jane" "New Zealand" } } ] -[ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test +[ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test [ ] [ test.db [ "insert into person(name, country) values('Jimmy', 'Canada')" sql-command - ] with-sqlite + ] with-db ] unit-test [ @@ -54,7 +39,7 @@ IN: db.sqlite.tests { "2" "Jane" "New Zealand" } { "3" "Jimmy" "Canada" } } -] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test +] [ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test [ test.db [ @@ -63,13 +48,13 @@ IN: db.sqlite.tests "insert into person(name, country) values('Jose', 'Mexico')" sql-command "oops" throw ] with-transaction - ] with-sqlite + ] with-db ] must-fail [ 3 ] [ test.db [ "select * from person" sql-query length - ] with-sqlite + ] with-db ] unit-test [ @@ -81,166 +66,11 @@ IN: db.sqlite.tests "insert into person(name, country) values('Jose', 'Mexico')" sql-command ] with-transaction - ] with-sqlite + ] with-db ] unit-test [ 5 ] [ test.db [ "select * from person" sql-query length - ] with-sqlite -] unit-test - -! TEST TUPLE DB - -TUPLE: puppy id name age ; -: ( name age -- puppy ) - { set-puppy-name set-puppy-age } puppy construct ; - -puppy "PUPPY" { - { "id" "ID" +native-id+ +not-null+ } - { "name" "NAME" { VARCHAR 256 } } - { "age" "AGE" INTEGER } -} define-persistent - -TUPLE: kitty id name age ; -: ( name age -- kitty ) - { set-kitty-name set-kitty-age } kitty construct ; - -kitty "KITTY" { - { "id" "ID" INTEGER +assigned-id+ } - { "name" "NAME" TEXT } - { "age" "AGE" INTEGER } -} define-persistent - -TUPLE: basket id puppies kitties ; -basket "BASKET" -{ - { "id" "ID" +native-id+ +not-null+ } - { "location" "LOCATION" TEXT } - { "puppies" { +has-many+ puppy } } - { "kitties" { +has-many+ kitty } } -} define-persistent - -! Create table -[ - "create table puppy(id integer primary key not null, name varchar, age integer);" -] [ - T{ sqlite-db } db [ - puppy dup db-columns swap db-table create-sql >lower - ] with-variable -] unit-test - -[ - "create table kitty(id integer primary key, name text, age integer);" -] [ - T{ sqlite-db } db [ - kitty dup db-columns swap db-table create-sql >lower - ] with-variable -] unit-test - -[ - "create table basket(id integer primary key not null, location text);" -] [ - T{ sqlite-db } db [ - basket dup db-columns swap db-table create-sql >lower - ] with-variable -] unit-test - -! Drop table -[ - "drop table puppy;" -] [ - T{ sqlite-db } db [ - puppy db-table drop-sql >lower - ] with-variable -] unit-test - -[ - "drop table kitty;" -] [ - T{ sqlite-db } db [ - kitty db-table drop-sql >lower - ] with-variable -] unit-test - -[ - "drop table basket;" -] [ - T{ sqlite-db } db [ - basket db-table drop-sql >lower - ] with-variable -] unit-test - -! Insert -[ - "insert into puppy(name, age) values(:name, :age);" -] [ - T{ sqlite-db } db [ - puppy dup db-columns swap db-table insert-sql* >lower - ] with-variable -] unit-test - -[ - "insert into kitty(id, name, age) values(:id, :name, :age);" -] [ - T{ sqlite-db } db [ - kitty dup db-columns swap db-table insert-sql* >lower - ] with-variable -] unit-test - -! Update -[ - "update puppy set name = :name, age = :age where id = :id" -] [ - T{ sqlite-db } db [ - puppy dup db-columns swap db-table update-sql* >lower - ] with-variable -] unit-test - -[ - "update kitty set name = :name, age = :age where id = :id" -] [ - T{ sqlite-db } db [ - kitty dup db-columns swap db-table update-sql* >lower - ] with-variable -] unit-test - -! Delete -[ - "delete from puppy where id = :id" -] [ - T{ sqlite-db } db [ - puppy dup db-columns swap db-table delete-sql* >lower - ] with-variable -] unit-test - -[ - "delete from kitty where id = :id" -] [ - T{ sqlite-db } db [ - kitty dup db-columns swap db-table delete-sql* >lower - ] with-variable -] unit-test - -! Select -[ - "select from puppy id, name, age where name = :name;" - { - T{ - sql-spec - f - "id" - "ID" - +native-id+ - { +not-null+ } - +native-id+ - } - T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } - T{ sql-spec f "age" "AGE" INTEGER { } f } - } -] [ - T{ sqlite-db } db [ - T{ puppy f f "Mr. Clunkers" } - select-sql >r >lower r> - ] with-variable + ] with-db ] unit-test From fa898aa8c6cfbb331f6141a28b0f8a331fc602d5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Mar 2008 15:02:02 -0600 Subject: [PATCH 16/36] Fixes --- extra/benchmark/sockets/sockets.factor | 123 ++++++++++----------- extra/bootstrap/image/upload/upload.factor | 2 +- 2 files changed, 59 insertions(+), 66 deletions(-) diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index c739bb787c..4927776575 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -1,65 +1,58 @@ -USING: io.sockets io kernel math threads -debugger tools.time prettyprint concurrency.count-downs -namespaces arrays continuations ; -IN: benchmark.sockets - -SYMBOL: counter - -: number-of-requests 1 ; - -: server-addr "127.0.0.1" 7777 ; - -: server-loop ( server -- ) - dup accept [ - [ - read1 CHAR: x = [ - "server" get dispose - ] [ - number-of-requests - [ read1 write1 flush ] times - counter get count-down - ] if - ] with-stream - ] curry "Client handler" spawn drop server-loop ; - -: simple-server ( -- ) - [ - server-addr dup "server" set [ - server-loop - ] with-disposal - ] ignore-errors ; - -: simple-client ( -- ) - server-addr [ - CHAR: b write1 flush - number-of-requests - [ CHAR: a dup write1 flush read1 assert= ] times - counter get count-down - ] with-stream ; - -: stop-server ( -- ) - server-addr [ - CHAR: x write1 - ] with-stream ; - -: clients ( n -- ) - dup pprint " clients: " write [ - dup 2 * counter set - [ simple-server ] "Simple server" spawn drop - yield yield - [ [ simple-client ] "Simple client" spawn drop ] times - counter get await - stop-server - yield yield - ] time ; - -: socket-benchmarks - 10 clients - 20 clients - 40 clients ; - ! 80 clients - ! 160 clients - ! 320 clients - ! 640 clients ; - -MAIN: socket-benchmarks +USING: io.sockets io kernel math threads +debugger tools.time prettyprint concurrency.count-downs +namespaces arrays continuations ; +IN: benchmark.sockets + +SYMBOL: counter + +: number-of-requests 1 ; + +: server-addr "127.0.0.1" 7777 ; + +: server-loop ( server -- ) + dup accept [ + [ + read1 CHAR: x = [ + "server" get dispose + ] [ + number-of-requests + [ read1 write1 flush ] times + counter get count-down + ] if + ] with-stream + ] curry "Client handler" spawn drop server-loop ; + +: simple-server ( -- ) + [ + server-addr dup "server" set [ + server-loop + ] with-disposal + ] ignore-errors ; + +: simple-client ( -- ) + server-addr [ + CHAR: b write1 flush + number-of-requests + [ CHAR: a dup write1 flush read1 assert= ] times + counter get count-down + ] with-stream ; + +: stop-server ( -- ) + server-addr [ + CHAR: x write1 + ] with-stream ; + +: clients ( n -- ) + dup pprint " clients: " write [ + dup 2 * counter set + [ simple-server ] "Simple server" spawn drop + yield yield + [ [ simple-client ] "Simple client" spawn drop ] times + counter get await + stop-server + yield yield + ] time ; + +: socket-benchmarks ; + +MAIN: socket-benchmarks diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index 084f30a103..3c0b464dbf 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -8,7 +8,7 @@ SYMBOL: upload-images-destination : destination ( -- dest ) upload-images-destination get - "slava@/var/www/factorcode.org/newsite/images/latest/" + "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/" or ; : checksums "checksums.txt" temp-file ; From 492d7bc6464bc4ba49c52b5fd2dd51ef7d87a8bb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Mar 2008 15:23:02 -0600 Subject: [PATCH 17/36] Fix load error --- extra/delegate/delegate.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 667805dcc3..33ac780caa 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -39,7 +39,7 @@ M: tuple-class group-words : define-mimic ( group mimicker mimicked -- ) >r >r group-words r> r> [ pick "methods" word-prop at dup - [ method-def spin define-method ] [ 3drop ] if + [ "method-def" word-prop spin define-method ] [ 3drop ] if ] 2curry each ; : MIMIC: From e96a4bd4507ea8004bb94d40a81a7ce8e995b691 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Mar 2008 15:24:13 -0600 Subject: [PATCH 18/36] Fix load error --- extra/delegate/delegate.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 667805dcc3..654d096b26 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -39,7 +39,8 @@ M: tuple-class group-words : define-mimic ( group mimicker mimicked -- ) >r >r group-words r> r> [ pick "methods" word-prop at dup - [ method-def spin define-method ] [ 3drop ] if + [ "method-def" word-prop spin define-method ] + [ 3drop ] if ] 2curry each ; : MIMIC: From 00acf627ef9d1f114681f7ce7ff6c0cd7f18c041 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Mar 2008 15:59:15 -0600 Subject: [PATCH 19/36] Markup fixes --- extra/benchmark/benchmark.factor | 2 +- extra/help/markup/markup.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index bd13455357..231c6edf50 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -21,7 +21,7 @@ IN: benchmark ] with-row [ [ - swap [ ($vocab-link) ] with-cell + swap [ dup ($vocab-link) ] with-cell first2 pprint-cell pprint-cell ] with-row ] assoc-each diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index a866293bbe..32e29db7db 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -173,7 +173,7 @@ M: f print-element drop ; : $vocabulary ( element -- ) first word-vocabulary [ - "Vocabulary" $heading nl ($vocab-link) + "Vocabulary" $heading nl dup ($vocab-link) ] when* ; : textual-list ( seq quot -- ) From 3c98385c11b566f9f7c20df6e1e227fd1ff30b6c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Mar 2008 16:00:34 -0600 Subject: [PATCH 20/36] Fixes for recent method tuple cleanup --- core/words/words.factor | 2 +- extra/db/sqlite/test.db | Bin 0 -> 2048 bytes extra/locals/locals.factor | 4 ++-- extra/tools/deploy/shaker/strip-cocoa.factor | 3 ++- 4 files changed, 5 insertions(+), 4 deletions(-) create mode 100644 extra/db/sqlite/test.db diff --git a/core/words/words.factor b/core/words/words.factor index c9505d3d1d..ce69c1ff2e 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -68,7 +68,7 @@ SYMBOL: bootstrapping? : crossref? ( word -- ? ) { { [ dup "forgotten" word-prop ] [ f ] } - { [ dup "method-definition" word-prop ] [ t ] } + { [ dup "method-def" word-prop ] [ t ] } { [ dup word-vocabulary ] [ t ] } { [ t ] [ f ] } } cond nip ; diff --git a/extra/db/sqlite/test.db b/extra/db/sqlite/test.db new file mode 100644 index 0000000000000000000000000000000000000000..e483c47cea528c95f10fcf66fcbb67ffa351ffd1 GIT binary patch literal 2048 zcmWFz^vNtqRY=P(%1ta$FlJz3U}R))P*7lCU|k literal 0 HcmV?d00001 diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 79af9e63f8..5f58f1464a 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -367,14 +367,14 @@ M: lambda-method definer drop \ M:: \ ; ; M: lambda-method definition "lambda" word-prop lambda-body ; -: method-stack-effect +: method-stack-effect ( method -- effect ) dup "lambda" word-prop lambda-vars swap "method-generic" word-prop stack-effect dup [ effect-out ] when ; M: lambda-method synopsis* - dup dup definer. + dup dup dup definer. "method-specializer" word-prop pprint* "method-generic" word-prop pprint* method-stack-effect effect>string comment. ; diff --git a/extra/tools/deploy/shaker/strip-cocoa.factor b/extra/tools/deploy/shaker/strip-cocoa.factor index 2eddce6475..b37e42f323 100755 --- a/extra/tools/deploy/shaker/strip-cocoa.factor +++ b/extra/tools/deploy/shaker/strip-cocoa.factor @@ -1,5 +1,6 @@ USING: cocoa cocoa.messages cocoa.application cocoa.nibs -assocs namespaces kernel words compiler sequences ui.cocoa ; +assocs namespaces kernel words compiler.units sequences +ui.cocoa ; "stop-after-last-window?" get global [ From 914456f31578965c0f07fcaa6c065e5f48bc6230 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 16:07:25 -0600 Subject: [PATCH 21/36] year month day > timestamp year month day hour minute second > timestamp --- extra/calendar/format/format.factor | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index 75ceea8ea2..d89afe615e 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -125,6 +125,35 @@ M: timestamp year. ( timestamp -- ) : rfc3339>timestamp ( str -- timestamp ) [ (rfc3339>timestamp) ] with-string-reader ; +: (ymdhms>timestamp) ( -- timestamp ) + read-0000 ! year + "-" expect + read-00 ! month + "-" expect + read-00 ! day + " " expect + read-00 ! hour + ":" expect + read-00 ! minute + ":" expect + read-00 ! second + 0 ! timezone + ; + +: ymdhms>timestamp ( str -- timestamp ) + [ (ymdhms>timestamp) ] with-string-reader ; + +: (ymd>timestamp) ( -- timestamp ) + read-0000 ! year + "-" expect + read-00 ! month + "-" expect + read-00 ! day + 0 0 0 0 ; + +: ymd>timestamp ( str -- timestamp ) + [ (ymd>timestamp) ] with-string-reader ; + : file-time-string ( timestamp -- string ) [ [ month>> month-abbreviations nth write ] keep bl From 82ed128f4733d1939bed9b4d64f0e4364c3aca94 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 16:10:29 -0600 Subject: [PATCH 22/36] make unknown elements f instead of 0 add hours:minutes:seconds --- extra/calendar/format/format.factor | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index d89afe615e..9b349fcc6c 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -143,13 +143,25 @@ M: timestamp year. ( timestamp -- ) : ymdhms>timestamp ( str -- timestamp ) [ (ymdhms>timestamp) ] with-string-reader ; +: (hms>timestamp) ( -- timestamp ) + f f f + read-00 ! hour + ":" expect + read-00 ! minute + ":" expect + read-00 ! second + f ; + +: hms>timestamp ( str -- timestamp ) + [ (hms>timestamp) ] with-string-reader ; + : (ymd>timestamp) ( -- timestamp ) read-0000 ! year "-" expect read-00 ! month "-" expect read-00 ! day - 0 0 0 0 ; + f f f f ; : ymd>timestamp ( str -- timestamp ) [ (ymd>timestamp) ] with-string-reader ; From 2c3b23286f823dde18effb55c5578adc066cac29 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 16:21:02 -0600 Subject: [PATCH 23/36] add timestamp>ymdhms and related code --- extra/calendar/format/format.factor | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index 9b349fcc6c..c1bd6427a7 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -166,6 +166,34 @@ M: timestamp year. ( timestamp -- ) : ymd>timestamp ( str -- timestamp ) [ (ymd>timestamp) ] with-string-reader ; + +: (timestamp>ymd) ( timestamp -- ) + dup timestamp-year number>string write + "-" write + dup timestamp-month write-00 + "-" write + timestamp-day write-00 ; + +: timestamp>ymd ( timestamp -- str ) + [ (timestamp>ymd) ] with-string-writer ; + +: (timestamp>hms) + dup timestamp-hour write-00 + ":" write + dup timestamp-minute write-00 + ":" write + timestamp-second >integer write-00 ; + +: timestamp>hms ( timestamp -- str ) + [ (timestamp>hms) ] with-string-writer ; + +: timestamp>ymdhms ( timestamp -- str ) + [ + dup (timestamp>ymd) + " " write + (timestamp>hms) + ] with-string-writer ; + : file-time-string ( timestamp -- string ) [ [ month>> month-abbreviations nth write ] keep bl From b6b8ab32b55b91ec59dccd9f388449502e4e75a8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Mar 2008 16:24:32 -0600 Subject: [PATCH 24/36] Fixing unit tests --- core/classes/classes-tests.factor | 4 ++-- core/generic/generic.factor | 2 -- core/words/words-tests.factor | 2 +- extra/tools/crossref/crossref-tests.factor | 2 +- 4 files changed, 4 insertions(+), 6 deletions(-) diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 38ca796384..640439312d 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -56,8 +56,8 @@ UNION: c a b ; [ t ] [ \ c \ tuple class< ] unit-test [ f ] [ \ tuple \ c class< ] unit-test -DEFER: bah -FORGET: bah +! DEFER: bah +! FORGET: bah UNION: bah fixnum alien ; [ bah ] [ \ bah? "predicating" word-prop ] unit-test diff --git a/core/generic/generic.factor b/core/generic/generic.factor index dbff82777f..f73579661d 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -25,8 +25,6 @@ GENERIC: make-default-method ( generic combination -- method ) PREDICATE: word generic "combination" word-prop >boolean ; -M: generic definer drop f f ; - M: generic definition drop f ; : make-generic ( word -- ) diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 97ce86d38a..06f3c7a782 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -141,7 +141,7 @@ SYMBOL: quot-uses-b [ { + } ] [ \ quot-uses-b uses ] unit-test -[ "IN: words.tests : undef-test ; << undef-test >>" eval ] +[ "IN: words.tests FORGET: undef-test : undef-test ; << undef-test >>" eval ] [ [ undefined? ] is? ] must-fail-with [ ] [ diff --git a/extra/tools/crossref/crossref-tests.factor b/extra/tools/crossref/crossref-tests.factor index a277a68ed7..0717763ed0 100755 --- a/extra/tools/crossref/crossref-tests.factor +++ b/extra/tools/crossref/crossref-tests.factor @@ -8,5 +8,5 @@ M: integer foo + ; "resource:extra/tools/crossref/test/foo.factor" run-file -[ t ] [ integer \ foo method method-word \ + usage member? ] unit-test +[ t ] [ integer \ foo method \ + usage member? ] unit-test [ t ] [ \ foo usage [ pathname? ] contains? ] unit-test From 2aabeb9bb3d16d021737c9ea28c8c1fc7a969cdc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 17:40:42 -0600 Subject: [PATCH 25/36] add failing unit test to farkup --- extra/farkup/farkup-tests.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor index 2e0d9832b0..f4b3025fcd 100755 --- a/extra/farkup/farkup-tests.factor +++ b/extra/farkup/farkup-tests.factor @@ -42,3 +42,7 @@ IN: farkup.tests [ "

foo\n

aheading

\n

adfasd

" ] [ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test + +[ "

=foo\n

" ] [ "=foo\n" convert-farkup ] unit-test +[ "

foo

\n" ] [ "=foo=\n" convert-farkup ] unit-test +[ "

lol

foo

\n" ] [ "lol=foo=\n" convert-farkup ] unit-test From f84761ae0c5c0a172787d71312a87d6be518af21 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 18:15:28 -0600 Subject: [PATCH 26/36] fix docs for delay --- extra/peg/peg-docs.factor | 3 ++- extra/peg/peg.factor | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor index 6dff95c829..9ad375ea04 100644 --- a/extra/peg/peg-docs.factor +++ b/extra/peg/peg-docs.factor @@ -135,9 +135,10 @@ HELP: hide HELP: delay { $values + { "quot" "a quotation" } { "parser" "a parser" } } { $description "Delays the construction of a parser until it is actually required to parse. This " "allows for calling a parser that results in a recursive call to itself. The quotation " - "should return the constructed parser." } ; \ No newline at end of file + "should return the constructed parser." } ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 01decc2c81..16cf40f884 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -358,7 +358,7 @@ MEMO: sp ( parser -- parser ) MEMO: hide ( parser -- parser ) [ drop ignore ] action ; -MEMO: delay ( parser -- parser ) +MEMO: delay ( quot -- parser ) delay-parser construct-boa init-parser ; : PEG: From 3eb7830d2c7c99aef369a7a3a5b1f5ec4deb0584 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 19:08:33 -0600 Subject: [PATCH 27/36] before major overhaul on return values --- extra/db/sqlite/lib/lib.factor | 32 +++++++++--- extra/db/sqlite/sqlite.factor | 8 ++- extra/db/tuples/tuples-tests.factor | 75 ++++++++++++++++++++++------- extra/db/types/types.factor | 28 ++++++----- 4 files changed, 105 insertions(+), 38 deletions(-) diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 648d8493dc..40486ba19f 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -2,7 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types arrays assocs kernel math math.parser namespaces sequences db.sqlite.ffi db combinators -continuations db.types ; +continuations db.types calendar.format serialize +io.streams.string byte-arrays ; +USE: tools.walker IN: db.sqlite.lib : sqlite-error ( n -- * ) @@ -55,6 +57,10 @@ IN: db.sqlite.lib : sqlite-bind-null ( handle i -- ) sqlite3_bind_null sqlite-check-result ; +: sqlite-bind-blob ( handle i byte-array -- ) + dup length SQLITE_TRANSIENT + sqlite3_bind_blob sqlite-check-result ; + : sqlite-bind-text-by-name ( handle name text -- ) parameter-index sqlite-bind-text ; @@ -67,20 +73,33 @@ IN: db.sqlite.lib : sqlite-bind-double-by-name ( handle name double -- ) parameter-index sqlite-bind-double ; +: sqlite-bind-blob-by-name ( handle name blob -- ) + parameter-index sqlite-bind-blob ; + : sqlite-bind-null-by-name ( handle name obj -- ) parameter-index drop sqlite-bind-null ; : sqlite-bind-type ( handle key value type -- ) + over [ drop NULL ] unless dup array? [ first ] when { { INTEGER [ sqlite-bind-int-by-name ] } - { BIG_INTEGER [ sqlite-bind-int64-by-name ] } + { BIG-INTEGER [ sqlite-bind-int64-by-name ] } { TEXT [ sqlite-bind-text-by-name ] } { VARCHAR [ sqlite-bind-text-by-name ] } { DOUBLE [ sqlite-bind-double-by-name ] } - { TIMESTAMP [ sqlite-bind-double-by-name ] } + { DATE [ sqlite-bind-text-by-name ] } + { TIME [ sqlite-bind-text-by-name ] } + { DATETIME [ sqlite-bind-text-by-name ] } + { TIMESTAMP [ sqlite-bind-text-by-name ] } + { BLOB [ sqlite-bind-blob-by-name ] } + { FACTOR-BLOB [ + break + [ serialize ] with-string-writer >byte-array + sqlite-bind-blob-by-name + ] } { +native-id+ [ sqlite-bind-int-by-name ] } - ! { NULL [ sqlite-bind-null-by-name ] } + { NULL [ sqlite-bind-null-by-name ] } [ no-sql-type ] } case ; @@ -93,21 +112,20 @@ IN: db.sqlite.lib : sqlite-#columns ( query -- int ) sqlite3_column_count ; -! TODO : sqlite-column ( handle index -- string ) sqlite3_column_text ; : sqlite-column-typed ( handle index type -- obj ) { { INTEGER [ sqlite3_column_int ] } - { BIG_INTEGER [ sqlite3_column_int64 ] } + { BIG-INTEGER [ sqlite3_column_int64 ] } { TEXT [ sqlite3_column_text ] } { DOUBLE [ sqlite3_column_double ] } { TIMESTAMP [ sqlite3_column_double ] } + ! { NULL [ 2drop f ] } [ no-sql-type ] } case ; -! TODO : sqlite-row ( handle -- seq ) dup sqlite-#columns [ sqlite-column ] with map ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index cfdcfc7750..1e55dc8331 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -179,8 +179,7 @@ M: sqlite-db ( tuple class -- statement ) " where " 0% [ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave - ";" 0% - ] if + ] if ";" 0% ] sqlite-make ; M: sqlite-db modifier-table ( -- hashtable ) @@ -209,8 +208,13 @@ M: sqlite-db type-table ( -- assoc ) { INTEGER "integer" } { TEXT "text" } { VARCHAR "text" } + { DATE "date" } + { TIME "time" } + { DATETIME "datetime" } { TIMESTAMP "timestamp" } { DOUBLE "real" } + { BLOB "blob" } + { FACTOR-BLOB "blob" } } ; M: sqlite-db create-type-table diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 517f8bcc36..e30b06411f 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -2,39 +2,45 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.files kernel tools.test db db.tuples db.types continuations namespaces db.postgresql math -prettyprint tools.walker db.sqlite ; +prettyprint tools.walker db.sqlite calendar ; IN: db.tuples.tests -TUPLE: person the-id the-name the-number the-real ; +TUPLE: person the-id the-name the-number the-real ts date time blob ; : ( name age real -- person ) { set-person-the-name set-person-the-number set-person-the-real + set-person-ts + set-person-date + set-person-time + set-person-blob } person construct ; : ( id name number the-real -- obj ) [ set-person-the-id ] keep ; -SYMBOL: the-person1 -SYMBOL: the-person2 +SYMBOL: person1 +SYMBOL: person2 +SYMBOL: person3 +SYMBOL: person4 : test-tuples ( -- ) [ person drop-table ] [ drop ] recover [ ] [ person create-table ] unit-test [ person create-table ] must-fail - [ ] [ the-person1 get insert-tuple ] unit-test + [ ] [ person1 get insert-tuple ] unit-test - [ 1 ] [ the-person1 get person-the-id ] unit-test + [ 1 ] [ person1 get person-the-id ] unit-test - 200 the-person1 get set-person-the-number + 200 person1 get set-person-the-number - [ ] [ the-person1 get update-tuple ] unit-test + [ ] [ person1 get update-tuple ] unit-test [ T{ person f 1 "billy" 200 3.14 } ] [ T{ person f 1 } select-tuple ] unit-test - [ ] [ the-person2 get insert-tuple ] unit-test + [ ] [ person2 get insert-tuple ] unit-test [ { T{ person f 1 "billy" 200 3.14 } @@ -49,8 +55,19 @@ SYMBOL: the-person2 ] [ T{ person f } select-tuples ] unit-test - [ ] [ the-person1 get delete-tuple ] unit-test + [ ] [ person1 get delete-tuple ] unit-test [ f ] [ T{ person f 1 } select-tuple ] unit-test + + [ ] [ person3 get insert-tuple ] unit-test + + [ + T{ person f 3 "teddy" 10 3.14 + T{ timestamp f 2008 3 5 16 24 11 0 } + T{ timestamp f 2008 11 22 f f f f } + T{ timestamp f f f f 12 34 56 f } + "storeinablob" } + ] [ T{ person f 3 } select-tuple ] unit-test + [ ] [ person drop-table ] unit-test ; : make-native-person-table ( -- ) @@ -67,9 +84,14 @@ SYMBOL: the-person2 { "the-name" "NAME" { VARCHAR 256 } +not-null+ } { "the-number" "AGE" INTEGER { +default+ 0 } } { "the-real" "REAL" DOUBLE { +default+ 0.3 } } + { "ts" "TS" TIMESTAMP } + { "date" "D" DATE } + { "time" "T" TIME } + { "blob" "B" BLOB } } define-persistent - "billy" 10 3.14 the-person1 set - "johnny" 10 3.14 the-person2 set ; + "billy" 10 3.14 f f f f person1 set + "johnny" 10 3.14 f f f f person2 set + "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } person3 set ; : assigned-person-schema ( -- ) person "PERSON" @@ -78,10 +100,14 @@ SYMBOL: the-person2 { "the-name" "NAME" { VARCHAR 256 } +not-null+ } { "the-number" "AGE" INTEGER { +default+ 0 } } { "the-real" "REAL" DOUBLE { +default+ 0.3 } } + { "ts" "TS" TIMESTAMP } + { "date" "D" DATE } + { "time" "T" TIME } + { "blob" "B" BLOB } } define-persistent - 1 "billy" 10 3.14 the-person1 set - 2 "johnny" 10 3.14 the-person2 set ; - + 1 "billy" 10 3.14 f f f f person1 set + 2 "johnny" 10 3.14 f f f f person2 set + 3 "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } person3 set ; TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: annotation n paste-id summary author mode contents ; @@ -125,7 +151,22 @@ TUPLE: annotation n paste-id summary author mode contents ; : test-postgresql ( -- ) >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; -[ native-person-schema test-tuples ] test-sqlite -[ assigned-person-schema test-tuples ] test-sqlite + +! [ native-person-schema test-tuples ] test-sqlite +! [ assigned-person-schema test-tuples ] test-sqlite + +TUPLE: serialize-me id data ; +[ + serialize-me "SERIALIZED" + { + { "id" "ID" +native-id+ } + { "data" "DATA" FACTOR-BLOB } + } define-persistent + [ serialize-me drop-table ] [ drop ] recover + [ ] [ serialize-me create-table ] unit-test + + [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test + [ ] [ T{ serialize-me f 1 } select-tuples ] unit-test +] test-sqlite ! [ make-native-person-table ] test-sqlite diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index c84b23c50f..89c26c1dd6 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -3,7 +3,8 @@ USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib words namespaces tools.walker slots slots.private classes -mirrors tuples combinators ; +mirrors tuples combinators calendar.format serialize +io.streams.string ; IN: db.types HOOK: modifier-table db ( -- hash ) @@ -60,14 +61,19 @@ SYMBOL: +has-many+ : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; SYMBOL: INTEGER -SYMBOL: BIG_INTEGER +SYMBOL: BIG-INTEGER SYMBOL: DOUBLE SYMBOL: REAL SYMBOL: BOOLEAN SYMBOL: TEXT SYMBOL: VARCHAR -SYMBOL: TIMESTAMP SYMBOL: DATE +SYMBOL: TIME +SYMBOL: DATETIME +SYMBOL: TIMESTAMP +SYMBOL: BLOB +SYMBOL: FACTOR-BLOB +SYMBOL: NULL : spec>tuple ( class spec -- tuple ) [ ?first3 ] keep 3 ?tail* @@ -80,15 +86,6 @@ SYMBOL: DATE } sql-spec construct dup normalize-spec ; -: sql-type-hash ( -- assoc ) - H{ - { INTEGER "integer" } - { TEXT "text" } - { VARCHAR "varchar" } - { DOUBLE "real" } - { TIMESTAMP "timestamp" } - } ; - TUPLE: no-sql-type ; : no-sql-type ( -- * ) T{ no-sql-type } throw ; @@ -212,13 +209,20 @@ TUPLE: no-slot-named ; ] curry { } map>assoc ; : sql-type>factor-type ( obj type -- obj ) +break dup array? [ first ] when { { +native-id+ [ string>number ] } { INTEGER [ string>number ] } { DOUBLE [ string>number ] } { REAL [ string>number ] } + { DATE [ dup [ ymd>timestamp ] when ] } + { TIME [ dup [ hms>timestamp ] when ] } + { DATETIME [ dup [ ymdhms>timestamp ] when ] } + { TIMESTAMP [ dup [ ymdhms>timestamp ] when ] } { TEXT [ ] } { VARCHAR [ ] } + { BLOB [ ] } + { FACTOR-BLOB [ break [ deserialize ] with-string-reader ] } [ "no conversion from sql type to factor type" throw ] } case ; From dfb3dac5fd50973af8c2f4bae99cfab90db5f071 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 19:59:29 -0600 Subject: [PATCH 28/36] sqlite now gets return types with the optimized native functions removed a hack in type conversion serialize arbitrary factor objects to db --- extra/db/db.factor | 10 +++++++--- extra/db/sqlite/lib/lib.factor | 21 +++++++++++++++++++-- extra/db/sqlite/sqlite.factor | 5 +++-- extra/db/tuples/tuples-tests.factor | 19 ++++++++++++++----- extra/db/tuples/tuples.factor | 11 ++++------- extra/db/types/types.factor | 19 ------------------- 6 files changed, 47 insertions(+), 38 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index e834144d0c..170d9a60f1 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -34,7 +34,7 @@ HOOK: db-close db ( handle -- ) TUPLE: statement handle sql in-params out-params bind-params bound? ; TUPLE: simple-statement ; TUPLE: prepared-statement ; -TUPLE: result-set sql params handle n max ; +TUPLE: result-set sql in-params out-params handle n max ; : ( sql in out -- statement ) { (>>sql) (>>in-params) (>>out-params) } statement construct ; @@ -47,6 +47,7 @@ GENERIC: query-results ( query -- result-set ) GENERIC: #rows ( result-set -- n ) GENERIC: #columns ( result-set -- n ) GENERIC# row-column 1 ( result-set n -- obj ) +GENERIC# row-column-typed 1 ( result-set n -- sql ) GENERIC: advance-row ( result-set -- ) GENERIC: more-rows? ( result-set -- ? ) @@ -67,13 +68,16 @@ GENERIC: more-rows? ( result-set -- ? ) 0 >>n drop ; : ( query handle tuple -- result-set ) - >r >r { sql>> in-params>> } get-slots r> - { (>>sql) (>>params) (>>handle) } result-set + >r >r { sql>> in-params>> out-params>> } get-slots r> + { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set construct r> construct-delegate ; : sql-row ( result-set -- seq ) dup #columns [ row-column ] with map ; +: sql-row-typed ( result-set -- seq ) + dup #columns [ row-column-typed ] with map ; + : query-each ( statement quot -- ) over more-rows? [ [ call ] 2keep over advance-row query-each diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 40486ba19f..f11f1e2ba6 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -94,7 +94,6 @@ IN: db.sqlite.lib { TIMESTAMP [ sqlite-bind-text-by-name ] } { BLOB [ sqlite-bind-blob-by-name ] } { FACTOR-BLOB [ - break [ serialize ] with-string-writer >byte-array sqlite-bind-blob-by-name ] } @@ -115,13 +114,31 @@ IN: db.sqlite.lib : sqlite-column ( handle index -- string ) sqlite3_column_text ; +: sqlite-column-blob ( handle index -- byte-array/f ) + [ sqlite3_column_bytes ] 2keep + pick zero? [ + 3drop f + ] [ + sqlite3_column_blob swap memory>byte-array + ] if ; + : sqlite-column-typed ( handle index type -- obj ) + dup array? [ first ] when { + { +native-id+ [ sqlite3_column_int64 ] } { INTEGER [ sqlite3_column_int ] } { BIG-INTEGER [ sqlite3_column_int64 ] } { TEXT [ sqlite3_column_text ] } + { VARCHAR [ sqlite3_column_text ] } { DOUBLE [ sqlite3_column_double ] } - { TIMESTAMP [ sqlite3_column_double ] } + { DATE [ sqlite3_column_text dup [ ymd>timestamp ] when ] } + { TIME [ sqlite3_column_text dup [ hms>timestamp ] when ] } + { TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] } + { DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] } + { BLOB [ sqlite-column-blob ] } + { FACTOR-BLOB [ + sqlite-column-blob [ deserialize ] with-string-reader + ] } ! { NULL [ 2drop f ] } [ no-sql-type ] } case ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 1e55dc8331..1524ee5a4f 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -80,8 +80,9 @@ M: sqlite-result-set #columns ( result-set -- n ) M: sqlite-result-set row-column ( result-set n -- obj ) >r result-set-handle r> sqlite-column ; -M: sqlite-result-set row-column-typed ( result-set n type -- obj ) - >r result-set-handle r> sqlite-column-typed ; +M: sqlite-result-set row-column-typed ( result-set n -- obj ) + dup pick result-set-out-params nth sql-spec-type + >r >r result-set-handle r> r> sqlite-column-typed ; M: sqlite-result-set advance-row ( result-set -- ) [ result-set-handle sqlite-next ] keep diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index e30b06411f..c9ceffe035 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -61,11 +61,18 @@ SYMBOL: person4 [ ] [ person3 get insert-tuple ] unit-test [ - T{ person f 3 "teddy" 10 3.14 + T{ + person + f + 3 + "teddy" + 10 + 3.14 T{ timestamp f 2008 3 5 16 24 11 0 } T{ timestamp f 2008 11 22 f f f f } T{ timestamp f f f f 12 34 56 f } - "storeinablob" } + B{ 115 116 111 114 101 105 110 97 98 108 111 98 } + } ] [ T{ person f 3 } select-tuple ] unit-test [ ] [ person drop-table ] unit-test ; @@ -152,8 +159,8 @@ TUPLE: annotation n paste-id summary author mode contents ; >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; -! [ native-person-schema test-tuples ] test-sqlite -! [ assigned-person-schema test-tuples ] test-sqlite +[ native-person-schema test-tuples ] test-sqlite +[ assigned-person-schema test-tuples ] test-sqlite TUPLE: serialize-me id data ; [ @@ -166,7 +173,9 @@ TUPLE: serialize-me id data ; [ ] [ serialize-me create-table ] unit-test [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test - [ ] [ T{ serialize-me f 1 } select-tuples ] unit-test + [ + { T{ serialize-me f 1 H{ { 1 2 } } } } + ] [ T{ serialize-me f 1 } select-tuples ] unit-test ] test-sqlite ! [ make-native-person-table ] test-sqlite diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index e7fe7e49c2..10a7c115ac 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -37,27 +37,24 @@ HOOK: db ( class -- obj ) HOOK: db ( tuple -- tuple ) -HOOK: row-column-typed db ( result-set n type -- sql ) HOOK: insert-tuple* db ( tuple statement -- ) : resulting-tuple ( row out-params -- tuple ) dup first sql-spec-class construct-empty [ [ - >r [ sql-spec-type sql-type>factor-type ] keep - sql-spec-slot-name r> set-slot-named + >r sql-spec-slot-name r> set-slot-named ] curry 2each ] keep ; : query-tuples ( statement -- seq ) [ statement-out-params ] keep query-results [ - [ sql-row swap resulting-tuple ] with query-map + [ sql-row-typed swap resulting-tuple ] with query-map ] with-disposal ; : query-modify-tuple ( tuple statement -- ) - [ query-results [ sql-row ] with-disposal ] keep + [ query-results [ sql-row-typed ] with-disposal ] keep statement-out-params rot [ - >r [ sql-spec-type sql-type>factor-type ] keep - sql-spec-slot-name r> set-slot-named + >r sql-spec-slot-name r> set-slot-named ] curry 2each ; : sql-props ( class -- columns table ) diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 89c26c1dd6..c2aa825db8 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -207,22 +207,3 @@ TUPLE: no-slot-named ; >r dup sql-spec-type swap sql-spec-slot-name r> get-slot-named swap ] curry { } map>assoc ; - -: sql-type>factor-type ( obj type -- obj ) -break - dup array? [ first ] when - { - { +native-id+ [ string>number ] } - { INTEGER [ string>number ] } - { DOUBLE [ string>number ] } - { REAL [ string>number ] } - { DATE [ dup [ ymd>timestamp ] when ] } - { TIME [ dup [ hms>timestamp ] when ] } - { DATETIME [ dup [ ymdhms>timestamp ] when ] } - { TIMESTAMP [ dup [ ymdhms>timestamp ] when ] } - { TEXT [ ] } - { VARCHAR [ ] } - { BLOB [ ] } - { FACTOR-BLOB [ break [ deserialize ] with-string-reader ] } - [ "no conversion from sql type to factor type" throw ] - } case ; From b8eb5abd13b84a068a33b30fb928d87ed83f569d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 20:56:40 -0600 Subject: [PATCH 29/36] before major query overhaul --- extra/db/sqlite/sqlite.factor | 12 +++----- extra/db/tuples/tuples-tests.factor | 48 +++++++++++++++++++++++------ 2 files changed, 44 insertions(+), 16 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 1524ee5a4f..643b42165d 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -142,6 +142,10 @@ M: sqlite-db ( tuple -- statement ) " where " 0% find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ; +: where-clause ( specs -- ) + " where " 0% + [ " and " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ; + M: sqlite-db ( class -- statement ) [ "update " 0% @@ -174,13 +178,7 @@ M: sqlite-db ( tuple class -- statement ) " from " 0% 0% [ sql-spec-slot-name swap get-slot-named ] with subset - dup empty? [ - drop - ] [ - " where " 0% - [ ", " 0% ] - [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave - ] if ";" 0% + dup empty? [ drop ] [ where-clause ] if ";" 0% ] sqlite-make ; M: sqlite-db modifier-table ( -- hashtable ) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index c9ceffe035..3a1e2c4f25 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -2,11 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.files kernel tools.test db db.tuples db.types continuations namespaces db.postgresql math -prettyprint tools.walker db.sqlite calendar ; +prettyprint tools.walker db.sqlite calendar +math.intervals ; IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real ts date time blob ; -: ( name age real -- person ) +: ( name age real ts date time blob -- person ) { set-person-the-name set-person-the-number @@ -17,7 +18,7 @@ TUPLE: person the-id the-name the-number the-real ts date time blob ; set-person-blob } person construct ; -: ( id name number the-real -- obj ) +: ( id name age real ts date time blob -- person ) [ set-person-the-id ] keep ; SYMBOL: person1 @@ -54,6 +55,12 @@ SYMBOL: person4 } ] [ T{ person f } select-tuples ] unit-test + [ + { + T{ person f 2 "johnny" 10 3.14 } + } + ] [ T{ person f f f 10 3.14 } select-tuples ] unit-test + [ ] [ person1 get delete-tuple ] unit-test [ f ] [ T{ person f 1 } select-tuple ] unit-test @@ -151,19 +158,18 @@ TUPLE: annotation n paste-id summary author mode contents ; ! [ ] [ annotation create-table ] unit-test ! ] with-db - : test-sqlite ( quot -- ) >r "tuples-test.db" resource-path sqlite-db r> with-db ; : test-postgresql ( -- ) >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; - [ native-person-schema test-tuples ] test-sqlite [ assigned-person-schema test-tuples ] test-sqlite TUPLE: serialize-me id data ; -[ + +: test-serialize ( -- ) serialize-me "SERIALIZED" { { "id" "ID" +native-id+ } @@ -175,7 +181,31 @@ TUPLE: serialize-me id data ; [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test [ { T{ serialize-me f 1 H{ { 1 2 } } } } - ] [ T{ serialize-me f 1 } select-tuples ] unit-test -] test-sqlite + ] [ T{ serialize-me f 1 } select-tuples ] unit-test ; -! [ make-native-person-table ] test-sqlite +! [ test-serialize ] test-sqlite + +TUPLE: exam id name score ; + +: test-ranges ( -- ) + exam "EXAM" + { + { "id" "ID" +native-id+ } + { "name" "NAME" TEXT } + { "score" "SCORE" INTEGER } + } define-persistent + [ exam drop-table ] [ drop ] recover + [ ] [ exam create-table ] unit-test + + [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test + [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test + [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test + [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test + + [ + T{ exam f 3 "Kenny" 60 } + T{ exam f 4 "Cartman" 41 } + ] [ T{ exam f 4 f T{ interval f { 0 t } { 70 t } } } select-tuples ] unit-test + ; + +! [ test-ranges ] test-sqlite From 6fe9e6f1ce7b69d1220fdb40183d2503fdb7b799 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 21:35:08 -0600 Subject: [PATCH 30/36] add singleton classes --- extra/singleton/authors.txt | 1 + extra/singleton/singleton-docs.factor | 14 ++++++++++++++ extra/singleton/singleton.factor | 9 +++++++++ 3 files changed, 24 insertions(+) create mode 100644 extra/singleton/authors.txt create mode 100644 extra/singleton/singleton-docs.factor create mode 100644 extra/singleton/singleton.factor diff --git a/extra/singleton/authors.txt b/extra/singleton/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/singleton/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/singleton/singleton-docs.factor b/extra/singleton/singleton-docs.factor new file mode 100644 index 0000000000..b87c557366 --- /dev/null +++ b/extra/singleton/singleton-docs.factor @@ -0,0 +1,14 @@ +USING: help.markup help.syntax ; +IN: singleton + +HELP: SINGLETON: +{ $syntax "SINGLETON: class" +} { $values + { "class" "a new tuple class to define" } +} { $description + "Defines a new tuple class with membership predicate name? and a default empty constructor that is the class name itself." +} { $examples + { $example "SINGLETON: foo\nfoo ." "T{ foo f }" } +} { $see-also + POSTPONE: TUPLE: +} ; diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor new file mode 100644 index 0000000000..3a9af90071 --- /dev/null +++ b/extra/singleton/singleton.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2007 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel parser quotations tuples words ; +IN: singleton + +: SINGLETON: + CREATE-CLASS + dup { } define-tuple-class + dup construct-empty 1quotation define ; parsing From 9f66ce692e76f48b23f411791efa8b5c7d9167df Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 21:37:25 -0600 Subject: [PATCH 31/36] begin work on regexp2 --- extra/regexp2/regexp2-tests.factor | 5 + extra/regexp2/regexp2.factor | 262 +++++++++++++++++++++++++++++ 2 files changed, 267 insertions(+) create mode 100644 extra/regexp2/regexp2-tests.factor create mode 100644 extra/regexp2/regexp2.factor diff --git a/extra/regexp2/regexp2-tests.factor b/extra/regexp2/regexp2-tests.factor new file mode 100644 index 0000000000..1fb3f61f29 --- /dev/null +++ b/extra/regexp2/regexp2-tests.factor @@ -0,0 +1,5 @@ +USING: kernel peg regexp2 sequences tools.test ; +IN: regexp2.tests + +[ T{ parse-result f T{ slice f 3 3 "056" } 46 } ] + [ "056" 'octal' parse ] unit-test diff --git a/extra/regexp2/regexp2.factor b/extra/regexp2/regexp2.factor new file mode 100644 index 0000000000..e62eb76cb1 --- /dev/null +++ b/extra/regexp2/regexp2.factor @@ -0,0 +1,262 @@ +USING: assocs combinators.lib kernel math math.parser +namespaces peg unicode.case sequences unicode.categories +memoize peg.parsers ; +USE: io +USE: tools.walker +IN: regexp2 + +upper [ swap ch>upper = ] ] [ [ = ] ] if + curry ; + +: char-between?-quot ( ch1 ch2 -- quot ) + ignore-case? get + [ [ ch>upper ] 2apply [ >r >r ch>upper r> r> between? ] ] + [ [ between? ] ] + if 2curry ; + +: or-predicates ( quots -- quot ) + [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ; + +: literal-action [ nip ] curry action ; + +: delay-action [ curry ] curry action ; + +PRIVATE> + +: ascii? ( n -- ? ) + 0 HEX: 7f between? ; + +: octal-digit? ( n -- ? ) + CHAR: 0 CHAR: 7 between? ; + +: hex-digit? ( n -- ? ) + { + [ dup digit? ] + [ dup CHAR: a CHAR: f between? ] + [ dup CHAR: A CHAR: F between? ] + } || nip ; + +: control-char? ( n -- ? ) + { [ dup 0 HEX: 1f between? ] [ dup HEX: 7f = ] } || nip ; + +: punct? ( n -- ? ) + "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ; + +: c-identifier-char? ( ch -- ? ) + { [ dup alpha? ] [ dup CHAR: _ = ] } || nip ; + +: java-blank? ( n -- ? ) + { + CHAR: \s + CHAR: \t CHAR: \n CHAR: \r + HEX: c HEX: 7 HEX: 1b + } member? ; + +: java-printable? ( n -- ? ) + { [ dup alpha? ] [ dup punct? ] } || nip ; + +MEMO: 'ordinary-char' ( -- parser ) + [ "\\^*+?|(){}[$" member? not ] satisfy + [ char=-quot ] action ; + +MEMO: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ; + +MEMO: 'octal' ( -- parser ) + "0" token hide 'octal-digit' 1 3 from-m-to-n 2seq + [ first oct> ] action ; + +MEMO: 'hex-digit' ( -- parser ) [ hex-digit? ] satisfy ; + +MEMO: 'hex' ( -- parser ) + "x" token hide 'hex-digit' 2 exactly-n 2seq + "u" token hide 'hex-digit' 6 exactly-n 2seq 2choice + [ first hex> ] action ; + +: satisfy-tokens ( assoc -- parser ) + [ >r token r> literal-action ] { } assoc>map choice ; + +MEMO: 'simple-escape-char' ( -- parser ) + { + { "\\" CHAR: \\ } + { "t" CHAR: \t } + { "n" CHAR: \n } + { "r" CHAR: \r } + { "f" HEX: c } + { "a" HEX: 7 } + { "e" HEX: 1b } + } [ char=-quot ] assoc-map satisfy-tokens ; + +MEMO: 'predefined-char-class' ( -- parser ) + { + { "d" [ digit? ] } + { "D" [ digit? not ] } + { "s" [ java-blank? ] } + { "S" [ java-blank? not ] } + { "w" [ c-identifier-char? ] } + { "W" [ c-identifier-char? not ] } + } satisfy-tokens ; + +MEMO: 'posix-character-class' ( -- parser ) + { + { "Lower" [ letter? ] } + { "Upper" [ LETTER? ] } + { "ASCII" [ ascii? ] } + { "Alpha" [ Letter? ] } + { "Digit" [ digit? ] } + { "Alnum" [ alpha? ] } + { "Punct" [ punct? ] } + { "Graph" [ java-printable? ] } + { "Print" [ java-printable? ] } + { "Blank" [ " \t" member? ] } + { "Cntrl" [ control-char? ] } + { "XDigit" [ hex-digit? ] } + { "Space" [ java-blank? ] } + } satisfy-tokens "p{" "}" surrounded-by ; + +MEMO: 'simple-escape' ( -- parser ) + [ + 'octal' , + 'hex' , + "c" token hide [ LETTER? ] satisfy 2seq , + any-char , + ] choice* [ char=-quot ] action ; + +MEMO: 'escape' ( -- parser ) + "\\" token hide [ + 'simple-escape-char' , + 'predefined-char-class' , + 'posix-character-class' , + 'simple-escape' , + ] choice* 2seq ; + +MEMO: 'any-char' ( -- parser ) + "." token [ drop t ] literal-action ; + +MEMO: 'char' ( -- parser ) + 'any-char' 'escape' 'ordinary-char' 3choice [ satisfy ] action ; + +DEFER: 'regexp' + +TUPLE: group-result str ; + +C: group-result + +MEMO: 'non-capturing-group' ( -- parser ) + "?:" token hide 'regexp' ; + +MEMO: 'positive-lookahead-group' ( -- parser ) + "?=" token hide 'regexp' [ ensure ] action ; + +MEMO: 'negative-lookahead-group' ( -- parser ) + "?!" token hide 'regexp' [ ensure-not ] action ; + +MEMO: 'simple-group' ( -- parser ) + 'regexp' [ [ ] action ] action ; + +MEMO: 'group' ( -- parser ) + [ + 'non-capturing-group' , + 'positive-lookahead-group' , + 'negative-lookahead-group' , + 'simple-group' , + ] choice* "(" ")" surrounded-by ; + +MEMO: 'range' ( -- parser ) + any-char "-" token hide any-char 3seq + [ first2 char-between?-quot ] action ; + +MEMO: 'character-class-term' ( -- parser ) + 'range' + 'escape' + [ "\\]" member? not ] satisfy [ char=-quot ] action + 3choice ; + +MEMO: 'positive-character-class' ( -- parser ) + ! todo + "]" token [ CHAR: ] = ] literal-action 'character-class-term' repeat0 2seq + 'character-class-term' repeat1 2choice [ or-predicates ] action ; + +MEMO: 'negative-character-class' ( -- parser ) + "^" token hide 'positive-character-class' 2seq + [ [ not ] append ] action ; + +MEMO: 'character-class' ( -- parser ) + 'negative-character-class' 'positive-character-class' 2choice + "[" "]" surrounded-by [ satisfy ] action ; + +MEMO: 'escaped-seq' ( -- parser ) + any-char repeat1 + [ ignore-case? get token ] action "\\Q" "\\E" surrounded-by ; + +MEMO: 'break' ( quot -- parser ) + satisfy ensure + epsilon just 2choice ; + +MEMO: 'break-escape' ( -- parser ) + "$" token [ "\r\n" member? ] 'break' literal-action + "\\b" token [ blank? ] 'break' literal-action + "\\B" token [ blank? not ] 'break' literal-action + "\\z" token epsilon just literal-action 4choice ; + +MEMO: 'simple' ( -- parser ) + [ + 'escaped-seq' , + 'break-escape' , + 'group' , + 'character-class' , + 'char' , + ] choice* ; + +MEMO: 'exactly-n' ( -- parser ) + 'integer' [ exactly-n ] delay-action ; + +MEMO: 'at-least-n' ( -- parser ) + 'integer' "," token hide 2seq [ at-least-n ] delay-action ; + +MEMO: 'at-most-n' ( -- parser ) + "," token hide 'integer' 2seq [ at-most-n ] delay-action ; + +MEMO: 'from-m-to-n' ( -- parser ) + 'integer' "," token hide 'integer' 3seq + [ first2 from-m-to-n ] delay-action ; + +MEMO: 'greedy-interval' ( -- parser ) + 'exactly-n' 'at-least-n' 'at-most-n' 'from-m-to-n' 4choice ; + +MEMO: 'interval' ( -- parser ) + 'greedy-interval' + 'greedy-interval' "?" token hide 2seq [ "reluctant {}" print ] action + 'greedy-interval' "+" token hide 2seq [ "possessive {}" print ] action + 3choice "{" "}" surrounded-by ; + +MEMO: 'repetition' ( -- parser ) + [ + ! Possessive + ! "*+" token [ ] literal-action , + ! "++" token [ ] literal-action , + ! "?+" token [ ] literal-action , + ! Reluctant + ! "*?" token [ <(*)> ] literal-action , + ! "+?" token [ <(+)> ] literal-action , + ! "??" token [ <(?)> ] literal-action , + ! Greedy + "*" token [ repeat0 ] literal-action , + "+" token [ repeat1 ] literal-action , + "?" token [ optional ] literal-action , + ] choice* ; + +MEMO: 'dummy' ( -- parser ) + epsilon [ ] literal-action ; + +! todo -- check the action +! MEMO: 'term' ( -- parser ) + ! 'simple' + ! 'repetition' 'interval' 'dummy' 3choice 2seq [ first2 call ] action + ! [ ] action ; + From 2feda7c5d7de3488cffa5e0904978fe0b3905616 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Mar 2008 21:38:15 -0600 Subject: [PATCH 32/36] http.server form validation --- extra/destructors/destructors-docs.factor | 4 +- extra/destructors/destructors-tests.factor | 2 +- extra/destructors/destructors.factor | 16 +- extra/furnace/authors.txt | 2 - extra/furnace/furnace-tests.factor | 47 ---- extra/furnace/furnace.factor | 217 ------------------ extra/furnace/sessions/authors.txt | 1 - extra/furnace/sessions/sessions.factor | 50 ---- extra/furnace/summary.txt | 1 - extra/furnace/tags.txt | 1 - extra/furnace/validator/authors.txt | 1 - .../furnace/validator/validator-tests.factor | 30 --- extra/furnace/validator/validator.factor | 43 ---- .../http/server/actions/actions-tests.factor | 16 +- extra/http/server/actions/actions.factor | 37 +-- .../http/server/components/components.factor | 129 +++++++++++ extra/http/server/crud/crud.factor | 13 ++ extra/http/server/db/db.factor | 12 +- extra/http/server/server.factor | 22 +- .../server/templating/{ => fhtml}/authors.txt | 0 .../fhtml-tests.factor} | 8 +- .../{templating.factor => fhtml/fhtml.factor} | 2 +- .../templating/{ => fhtml}/test/bug.fhtml | 0 .../templating/{ => fhtml}/test/bug.html | 0 .../templating/{ => fhtml}/test/example.fhtml | 0 .../templating/{ => fhtml}/test/example.html | 0 .../templating/{ => fhtml}/test/stack.fhtml | 0 .../templating/{ => fhtml}/test/stack.html | 0 .../server/validators/validators-tests.factor | 4 + .../http/server/validators/validators.factor | 64 ++++++ 30 files changed, 280 insertions(+), 442 deletions(-) delete mode 100644 extra/furnace/authors.txt delete mode 100755 extra/furnace/furnace-tests.factor delete mode 100755 extra/furnace/furnace.factor delete mode 100755 extra/furnace/sessions/authors.txt delete mode 100755 extra/furnace/sessions/sessions.factor delete mode 100755 extra/furnace/summary.txt delete mode 100644 extra/furnace/tags.txt delete mode 100755 extra/furnace/validator/authors.txt delete mode 100644 extra/furnace/validator/validator-tests.factor delete mode 100644 extra/furnace/validator/validator.factor create mode 100644 extra/http/server/components/components.factor create mode 100644 extra/http/server/crud/crud.factor rename extra/http/server/templating/{ => fhtml}/authors.txt (100%) rename extra/http/server/templating/{templating-tests.factor => fhtml/fhtml-tests.factor} (65%) rename extra/http/server/templating/{templating.factor => fhtml/fhtml.factor} (98%) rename extra/http/server/templating/{ => fhtml}/test/bug.fhtml (100%) rename extra/http/server/templating/{ => fhtml}/test/bug.html (100%) rename extra/http/server/templating/{ => fhtml}/test/example.fhtml (100%) rename extra/http/server/templating/{ => fhtml}/test/example.html (100%) rename extra/http/server/templating/{ => fhtml}/test/stack.fhtml (100%) rename extra/http/server/templating/{ => fhtml}/test/stack.html (100%) create mode 100644 extra/http/server/validators/validators-tests.factor create mode 100644 extra/http/server/validators/validators.factor diff --git a/extra/destructors/destructors-docs.factor b/extra/destructors/destructors-docs.factor index 4c51e7ddfb..f96931c412 100755 --- a/extra/destructors/destructors-docs.factor +++ b/extra/destructors/destructors-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax libc kernel ; +USING: help.markup help.syntax libc kernel continuations ; IN: destructors HELP: free-always @@ -23,7 +23,7 @@ HELP: close-later HELP: with-destructors { $values { "quot" "a quotation" } } -{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link destruct } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." } +{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." } { $notes "Destructors are not allowed to throw exceptions. No exceptions." } { $examples { $code "[ 10 malloc free-always ] with-destructors" } diff --git a/extra/destructors/destructors-tests.factor b/extra/destructors/destructors-tests.factor index 09b4ccc357..147e183688 100755 --- a/extra/destructors/destructors-tests.factor +++ b/extra/destructors/destructors-tests.factor @@ -9,7 +9,7 @@ TUPLE: dummy-destructor obj ; C: dummy-destructor -M: dummy-destructor destruct ( obj -- ) +M: dummy-destructor dispose ( obj -- ) dummy-destructor-obj t swap set-dummy-obj-destroyed? ; : destroy-always diff --git a/extra/destructors/destructors.factor b/extra/destructors/destructors.factor index 0f8ec3af84..b2561c7439 100755 --- a/extra/destructors/destructors.factor +++ b/extra/destructors/destructors.factor @@ -4,18 +4,16 @@ USING: continuations io.backend libc kernel namespaces sequences system vectors ; IN: destructors -GENERIC: destruct ( obj -- ) - SYMBOL: error-destructors SYMBOL: always-destructors TUPLE: destructor object destroyed? ; -M: destructor destruct +M: destructor dispose dup destructor-destroyed? [ drop ] [ - dup destructor-object destruct + dup destructor-object dispose t swap set-destructor-destroyed? ] if ; @@ -29,10 +27,10 @@ M: destructor destruct always-destructors get push ; : do-always-destructors ( -- ) - always-destructors get [ destruct ] each ; + always-destructors get [ dispose ] each ; : do-error-destructors ( -- ) - error-destructors get [ destruct ] each ; + error-destructors get [ dispose ] each ; : with-destructors ( quot -- ) [ @@ -47,7 +45,7 @@ TUPLE: memory-destructor alien ; C: memory-destructor -M: memory-destructor destruct ( obj -- ) +M: memory-destructor dispose ( obj -- ) memory-destructor-alien free ; : free-always ( alien -- ) @@ -63,7 +61,7 @@ C: handle-destructor HOOK: destruct-handle io-backend ( obj -- ) -M: handle-destructor destruct ( obj -- ) +M: handle-destructor dispose ( obj -- ) handle-destructor-alien destruct-handle ; : close-always ( handle -- ) @@ -79,7 +77,7 @@ C: socket-destructor HOOK: destruct-socket io-backend ( obj -- ) -M: socket-destructor destruct ( obj -- ) +M: socket-destructor dispose ( obj -- ) socket-destructor-alien destruct-socket ; : close-socket-always ( handle -- ) diff --git a/extra/furnace/authors.txt b/extra/furnace/authors.txt deleted file mode 100644 index f372b574ae..0000000000 --- a/extra/furnace/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Slava Pestov -Doug Coleman diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor deleted file mode 100755 index d8124d1f2b..0000000000 --- a/extra/furnace/furnace-tests.factor +++ /dev/null @@ -1,47 +0,0 @@ -USING: kernel sequences namespaces math tools.test furnace furnace.validator ; -IN: furnace.tests - -TUPLE: test-tuple m n ; - -[ H{ { "m" 3 } { "n" 2 } } ] -[ - [ T{ test-tuple f 3 2 } explode-tuple ] H{ } make-assoc -] unit-test - -[ - { 3 } -] [ - H{ { "n" "3" } } { { "n" v-number } } - [ action-param drop ] with map -] unit-test - -: foo ; - -\ foo { { "foo" "2" v-default } { "bar" v-required } } define-action - -[ t ] [ [ 1 2 foo ] action-call? ] unit-test -[ f ] [ [ 2 + ] action-call? ] unit-test - -[ - { "2" "hello" } -] [ - [ - H{ - { "bar" "hello" } - } \ foo query>seq - ] with-scope -] unit-test - -[ - H{ { "foo" "1" } { "bar" "2" } } -] [ - { "1" "2" } \ foo quot>query -] unit-test - -[ - "/responder/furnace.tests/foo?foo=3" -] [ - [ - [ "3" foo ] quot-link - ] with-scope -] unit-test diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor deleted file mode 100755 index 3bbd2d03da..0000000000 --- a/extra/furnace/furnace.factor +++ /dev/null @@ -1,217 +0,0 @@ -! Copyright (C) 2006, 2008 Slava Pestov, Doug Coleman -! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs calendar debugger furnace.sessions -furnace.validator hashtables heaps html.elements http -http.server.responders http.server.templating io.files kernel -math namespaces quotations sequences splitting words strings -vectors webapps.callback continuations tuples classes vocabs -html io ; -IN: furnace - -: code>quotation ( word/quot -- quot ) - dup word? [ 1quotation ] when ; - -SYMBOL: default-action -SYMBOL: template-path - -: render-template ( template -- ) - template-path get swap path+ - ".furnace" append resource-path - run-template-file ; - -: define-action ( word hash -- ) - over t "action" set-word-prop - "action-params" set-word-prop ; - -: define-form ( word1 word2 hash -- ) - dupd define-action - swap code>quotation "form-failed" set-word-prop ; - -: default-values ( word hash -- ) - "default-values" set-word-prop ; - -SYMBOL: request-params -SYMBOL: current-action -SYMBOL: validators-errored -SYMBOL: validation-errors - -: build-url ( str query-params -- newstr ) - [ - over % - dup assoc-empty? [ - 2drop - ] [ - CHAR: ? rot member? "&" "?" ? % - assoc>query % - ] if - ] "" make ; - -: action-link ( query action -- url ) - [ - "/responder/" % - dup word-vocabulary "webapps." ?head drop % - "/" % - word-name % - ] "" make swap build-url ; - -: action-param ( hash paramsepc -- obj error/f ) - unclip rot at swap >quotation apply-validators ; - -: query>seq ( hash word -- seq ) - "action-params" word-prop [ - dup first -rot - action-param [ - t validators-errored >session - rot validation-errors session> set-at - ] [ - nip - ] if* - ] with map ; - -: lookup-session ( hash -- session ) - "furnace-session-id" over at get-session - [ ] [ new-session "furnace-session-id" roll set-at ] ?if ; - -: quot>query ( seq action -- hash ) - >r >array r> "action-params" word-prop - [ first swap 2array ] 2map >hashtable ; - -PREDICATE: word action "action" word-prop ; - -: action-call? ( quot -- ? ) - >vector dup pop action? >r [ word? not ] all? r> and ; - -: unclip* dup 1 head* swap peek ; - -: quot-link ( quot -- url ) - dup action-call? [ - unclip* [ quot>query ] keep action-link - ] [ - t register-html-callback - ] if ; - -: replace-variables ( quot -- quot ) - [ dup string? [ request-params session> at ] when ] map ; - -: furnace-session-id ( -- hash ) - "furnace-session-id" request-params session> at - "furnace-session-id" associate ; - -: redirect-to-action ( -- ) - current-action session> - "form-failed" word-prop replace-variables - quot-link furnace-session-id build-url permanent-redirect ; - -: if-form-page ( if then -- ) - current-action session> "form-failed" word-prop -rot if ; - -: do-action - current-action session> [ query>seq ] keep add >quotation call ; - -: process-form ( -- ) - H{ } clone validation-errors >session - request-params session> current-action session> query>seq - validators-errored session> [ - drop redirect-to-action - ] [ - current-action session> add >quotation call - ] if ; - -: page-submitted ( -- ) - [ process-form ] [ request-params session> do-action ] if-form-page ; - -: action-first-time ( -- ) - request-params session> current-action session> - [ "default-values" word-prop swap union request-params >session ] keep - request-params session> do-action ; - -: page-not-submitted ( -- ) - [ redirect-to-action ] [ action-first-time ] if-form-page ; - -: setup-call-action ( hash word -- ) - over lookup-session session set - current-action >session - request-params session> swap union - request-params >session - f validators-errored >session ; - -: call-action ( hash word -- ) - setup-call-action - "furnace-form-submitted" request-params session> at - [ page-submitted ] [ page-not-submitted ] if ; - -: responder-vocab ( str -- newstr ) - "webapps." swap append ; - -: lookup-action ( str webapp -- word ) - responder-vocab lookup dup [ - dup "action" word-prop [ drop f ] unless - ] when ; - -: truncate-url ( str -- newstr ) - CHAR: / over index [ head ] when* ; - -: parse-action ( str -- word/f ) - dup empty? [ drop default-action get ] when - truncate-url "responder" get lookup-action ; - -: service-request ( hash str -- ) - parse-action [ - [ call-action ] [ 
 print-error
] recover - ] [ - "404 no such action: " "argument" get append httpd-error - ] if* ; - -: service-get - "query" get swap service-request ; - -: service-post - "response" get swap service-request ; - -: web-app ( name defaul path -- ) - [ - template-path set - default-action set - "responder" set - [ service-get ] "get" set - [ service-post ] "post" set - ] make-responder ; - -: explode-tuple ( tuple -- ) - dup tuple-slots swap class "slot-names" word-prop - [ set ] 2each ; - -SYMBOL: model - -: with-slots ( model quot -- ) - [ - >r [ dup model set explode-tuple ] when* r> call - ] with-scope ; - -: render-component ( model template -- ) - swap [ render-template ] with-slots ; - -: browse-webapp-source ( vocab -- ) - - "Browse source" write - ; - -: send-resource ( name -- ) - template-path get swap path+ resource-path - stdio get stream-copy ; - -: render-link ( quot name -- ) - write ; - -: session-var ( str -- newstr ) - request-params session> at ; - -: render ( str -- ) - request-params session> at [ write ] when* ; - -: render-error ( str error-str -- ) - swap validation-errors session> at validation-error? [ - write - ] [ - drop - ] if ; diff --git a/extra/furnace/sessions/authors.txt b/extra/furnace/sessions/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/extra/furnace/sessions/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor deleted file mode 100755 index cf03fee6b1..0000000000 --- a/extra/furnace/sessions/sessions.factor +++ /dev/null @@ -1,50 +0,0 @@ -USING: assocs calendar init kernel math.parser -namespaces random boxes alarms combinators.lib ; -IN: furnace.sessions - -SYMBOL: sessions - -: timeout ( -- dt ) 20 minutes ; - -[ - H{ } clone sessions set-global -] "furnace.sessions" add-init-hook - -: new-session-id ( -- str ) - [ 4 big-random >hex ] - [ sessions get-global key? not ] generate ; - -TUPLE: session id namespace alarm user-agent ; - -: cancel-timeout ( session -- ) - session-alarm ?box [ cancel-alarm ] [ drop ] if ; - -: delete-session ( session -- ) - sessions get-global delete-at* - [ cancel-timeout ] [ drop ] if ; - -: touch-session ( session -- ) - dup cancel-timeout - dup [ session-id delete-session ] curry timeout later - swap session-alarm >box ; - -: ( id -- session ) - H{ } clone f session construct-boa ; - -: new-session ( -- session id ) - new-session-id [ - dup [ - [ sessions get-global set-at ] keep - touch-session - ] keep - ] keep ; - -: get-session ( id -- session/f ) - sessions get-global at* - [ dup touch-session ] when ; - -: session> ( str -- obj ) - session get session-namespace at ; - -: >session ( value key -- ) - session get session-namespace set-at ; diff --git a/extra/furnace/summary.txt b/extra/furnace/summary.txt deleted file mode 100755 index 5696506f79..0000000000 --- a/extra/furnace/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Action-based web framework diff --git a/extra/furnace/tags.txt b/extra/furnace/tags.txt deleted file mode 100644 index 0aef4feca8..0000000000 --- a/extra/furnace/tags.txt +++ /dev/null @@ -1 +0,0 @@ -enterprise diff --git a/extra/furnace/validator/authors.txt b/extra/furnace/validator/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/extra/furnace/validator/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/furnace/validator/validator-tests.factor b/extra/furnace/validator/validator-tests.factor deleted file mode 100644 index e84e57be6a..0000000000 --- a/extra/furnace/validator/validator-tests.factor +++ /dev/null @@ -1,30 +0,0 @@ -IN: furnace.validator.tests -USING: kernel sequences tools.test furnace.validator furnace ; - -[ - 123 f -] [ - H{ { "foo" "123" } } { "foo" v-number } action-param -] unit-test - -: validation-fails - [ action-param nip not ] append [ f ] swap unit-test ; - -[ H{ { "foo" "12X3" } } { "foo" v-number } ] validation-fails - -[ H{ { "foo" "" } } { "foo" 4 v-min-length } ] validation-fails - -[ "ABCD" f ] -[ H{ { "foo" "ABCD" } } { "foo" 4 v-min-length } action-param ] -unit-test - -[ H{ { "foo" "ABCD" } } { "foo" 2 v-max-length } ] -validation-fails - -[ "AB" f ] -[ H{ { "foo" "AB" } } { "foo" 2 v-max-length } action-param ] -unit-test - -[ "AB" f ] -[ H{ { "foo" f } } { "foo" "AB" v-default } action-param ] -unit-test diff --git a/extra/furnace/validator/validator.factor b/extra/furnace/validator/validator.factor deleted file mode 100644 index 698c77fa9a..0000000000 --- a/extra/furnace/validator/validator.factor +++ /dev/null @@ -1,43 +0,0 @@ -! Copyright (C) 2006 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations sequences math namespaces math.parser ; -IN: furnace.validator - -TUPLE: validation-error reason ; - -: apply-validators ( string quot -- obj error/f ) - [ - call f - ] [ - dup validation-error? [ >r 2drop f r> ] [ rethrow ] if - ] recover ; - -: validation-error ( msg -- * ) - \ validation-error construct-boa throw ; - -: v-default ( obj value -- obj ) - over empty? [ nip ] [ drop ] if ; - -: v-required ( str -- str ) - dup empty? [ "required" validation-error ] when ; - -: v-min-length ( str n -- str ) - over length over < [ - [ "must be at least " % # " characters" % ] "" make - validation-error - ] [ - drop - ] if ; - -: v-max-length ( str n -- str ) - over length over > [ - [ "must be no more than " % # " characters" % ] "" make - validation-error - ] [ - drop - ] if ; - -: v-number ( str -- n ) - string>number [ - "must be a number" validation-error - ] unless* ; diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor index 2d74e92e86..13089ae6e8 100644 --- a/extra/http/server/actions/actions-tests.factor +++ b/extra/http/server/actions/actions-tests.factor @@ -1,11 +1,12 @@ IN: http.server.actions.tests USING: http.server.actions tools.test math math.parser multiline namespaces http io.streams.string http.server -sequences ; +sequences accessors ; -[ + ] -{ { "a" [ string>number ] } { "b" [ string>number ] } } -"GET" "action-1" set + + [ "a" get "b" get + ] >>get + { { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params +"action-1" set STRING: action-request-test-1 GET http://foo/bar?a=12&b=13 HTTP/1.1 @@ -19,9 +20,10 @@ blah "action-1" get call-responder ] unit-test -[ "X" concat append ] -{ { +path+ [ ] } { "xxx" [ string>number ] } } -"POST" "action-2" set + + [ +path+ get "xxx" get "X" concat append ] >>post + { { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params +"action-2" set STRING: action-request-test-2 POST http://foo/bar/baz HTTP/1.1 diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index feb16a4488..5e5b7a9563 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -1,14 +1,18 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors new-slots sequences kernel assocs combinators -http.server http hashtables namespaces ; +http.server http.server.validators http hashtables namespaces ; IN: http.server.actions SYMBOL: +path+ -TUPLE: action quot params method ; +TUPLE: action get get-params post post-params revalidate ; -C: action +: + action construct-empty + [ <400> ] >>get + [ <400> ] >>post + [ <400> ] >>revalidate ; : extract-params ( request path -- assoc ) >r dup method>> { @@ -16,15 +20,22 @@ C: action { "POST" [ post-data>> query>assoc ] } } case r> +path+ associate union ; -: push-params ( assoc action -- ... ) - params>> [ first2 >r swap at r> call ] with each ; +: action-params ( request path param -- error? ) + -rot extract-params validate-params ; + +: get-action ( request path -- response ) + action get get-params>> action-params + [ <400> ] [ action get get>> call ] if ; + +: post-action ( request path -- response ) + action get post-params>> action-params + [ action get revalidate>> ] [ action get post>> ] if call ; M: action call-responder ( request path action -- response ) - pick request set - pick method>> over method>> = [ - >r extract-params r> - [ push-params ] keep - quot>> call - ] [ - 3drop <400> - ] if ; + action set + over request set + over method>> + { + { "GET" [ get-action ] } + { "POST" [ post-action ] } + } case ; diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor new file mode 100644 index 0000000000..6fefb1b5dd --- /dev/null +++ b/extra/http/server/components/components.factor @@ -0,0 +1,129 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: new-slots html.elements http.server.validators +accessors namespaces kernel io farkup math.parser assocs +classes words tuples arrays sequences io.files +http.server.templating.fhtml splitting ; +IN: http.server.components + +SYMBOL: components + +TUPLE: component id ; + +: component ( name -- component ) + dup components get at + [ ] [ "No such component: " swap append throw ] ?if ; + +GENERIC: validate* ( string component -- result ) +GENERIC: render-view* ( value component -- ) +GENERIC: render-edit* ( value component -- ) +GENERIC: render-error* ( reason value component -- ) + +SYMBOL: values + +: value values get at ; + +: render-view ( component -- ) + dup id>> value swap render-view* ; + +: render-error ( error -- ) + write ; + +: render-edit ( component -- ) + dup id>> value dup validation-error? [ + dup reason>> swap value>> rot render-error* + ] [ + swap render-edit* + ] if ; + +: ( id string -- component ) + >r \ component construct-boa r> construct-delegate ; inline + +TUPLE: string min max ; + +: ( id -- component ) string ; + +M: string validate* + [ min>> v-min-length ] keep max>> v-max-length ; + +M: string render-view* + drop write ; + +: render-input + > dup =id =name =value input/> ; + +M: string render-edit* + render-input ; + +M: string render-error* + render-input render-error ; + +TUPLE: text ; + +: ( id -- component ) text construct-delegate ; + +: render-textarea + ; + +M: text render-edit* + render-textarea ; + +M: text render-error* + render-textarea render-error ; + +TUPLE: farkup ; + +: ( id -- component ) farkup construct-delegate ; + +M: farkup render-view* + drop string-lines "\n" join convert-farkup write ; + +TUPLE: number min max ; + +: ( id -- component ) number ; + +M: number validate* + >r v-number r> [ min>> v-min-value ] keep max>> v-max-value ; + +M: number render-view* + drop number>string write ; + +M: number render-edit* + >r number>string r> render-input ; + +M: number render-error* + render-input render-error ; + +: tuple>slots ( tuple -- alist ) + dup class "slot-names" word-prop swap tuple-slots + 2array flip ; + +: with-components ( tuple components quot -- ) + [ + >r components set + dup tuple>slots values set + tuple set + r> call + ] with-scope ; inline + +TUPLE: form view-template edit-template components ; + +:
( id view-template edit-template -- form ) + V{ } clone form construct-boa + swap \ component construct-boa + over set-delegate ; + +: add-field ( form component -- form ) + dup id>> pick components>> set-at ; + +M: form render-view* ( value form -- ) + dup components>> + swap view-template>> + [ resource-path run-template-file ] curry + with-components ; + +M: form render-edit* ( value form -- ) + dup components>> + swap edit-template>> + [ resource-path run-template-file ] curry + with-components ; diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor new file mode 100644 index 0000000000..099ded2f7f --- /dev/null +++ b/extra/http/server/crud/crud.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.crud +USING: kernel namespaces db.tuples math.parser +http.server.actions accessors ; + +: by-id ( class -- tuple ) + construct-empty "id" get >>id ; + +: ( class -- action ) + + { { "id" [ string>number ] } } >>post-params + swap [ by-id delete-tuple f ] curry >>post ; diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor index 4baee5f02b..511921ce06 100755 --- a/extra/http/server/db/db.factor +++ b/extra/http/server/db/db.factor @@ -1,14 +1,18 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: db http.server kernel new-slots accessors -continuations namespaces ; +continuations namespaces destructors ; IN: http.server.db TUPLE: db-persistence responder db params ; C: db-persistence +: connect-db ( db-persistence -- ) + dup db>> swap params>> make-db + dup db set + dup db-open + add-always-destructor ; + M: db-persistence call-responder - dup db>> over params>> make-db dup db-open [ - db set responder>> call-responder - ] with-disposal ; + dup connect-db responder>> call-responder ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index f397b280d0..990c77f71e 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -3,7 +3,8 @@ USING: assocs kernel namespaces io io.timeouts strings splitting threads http sequences prettyprint io.server logging calendar new-slots html.elements accessors math.parser combinators.lib -vocabs.loader debugger html continuations random combinators ; +vocabs.loader debugger html continuations random combinators +destructors ; IN: http.server GENERIC: call-responder ( request path responder -- response ) @@ -135,7 +136,7 @@ SYMBOL: development-mode swap method>> "HEAD" = [ drop ] [ write-response-body ] if ; -: do-request ( request -- request ) +: do-request ( request -- response ) [ dup dup path>> over host>> find-virtual-host call-responder @@ -149,13 +150,18 @@ LOG: httpd-hit NOTICE : log-request ( request -- ) { method>> host>> path>> } map-exec-with httpd-hit ; -: handle-client ( -- ) - default-timeout +: ?refresh-all ( -- ) development-mode get-global - [ global [ refresh-all ] bind ] when - read-request - dup log-request - do-request do-response ; + [ global [ refresh-all ] bind ] when ; + +: handle-client ( -- ) + [ + default-timeout + ?refresh-all + read-request + dup log-request + do-request do-response + ] with-destructors ; : httpd ( port -- ) internet-server "http.server" diff --git a/extra/http/server/templating/authors.txt b/extra/http/server/templating/fhtml/authors.txt similarity index 100% rename from extra/http/server/templating/authors.txt rename to extra/http/server/templating/fhtml/authors.txt diff --git a/extra/http/server/templating/templating-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor similarity index 65% rename from extra/http/server/templating/templating-tests.factor rename to extra/http/server/templating/fhtml/fhtml-tests.factor index ceb2ed95be..0ae3b41454 100644 --- a/extra/http/server/templating/templating-tests.factor +++ b/extra/http/server/templating/fhtml/fhtml-tests.factor @@ -1,9 +1,9 @@ -USING: io io.files io.streams.string http.server.templating kernel tools.test - sequences ; -IN: http.server.templating.tests +USING: io io.files io.streams.string +http.server.templating.fhtml kernel tools.test sequences ; +IN: http.server.templating.fhtml.tests : test-template ( path -- ? ) - "extra/http/server/templating/test/" swap append + "extra/http/server/templating/fhtml/test/" swap append [ ".fhtml" append resource-path [ run-template-file ] with-string-writer diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/fhtml/fhtml.factor similarity index 98% rename from extra/http/server/templating/templating.factor rename to extra/http/server/templating/fhtml/fhtml.factor index b298faca74..37f4b85c51 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -7,7 +7,7 @@ source-files debugger combinators math quotations generic strings splitting accessors http.server.static http.server assocs ; -IN: http.server.templating +IN: http.server.templating.fhtml : templating-vocab ( -- vocab-name ) "http.server.templating" ; diff --git a/extra/http/server/templating/test/bug.fhtml b/extra/http/server/templating/fhtml/test/bug.fhtml similarity index 100% rename from extra/http/server/templating/test/bug.fhtml rename to extra/http/server/templating/fhtml/test/bug.fhtml diff --git a/extra/http/server/templating/test/bug.html b/extra/http/server/templating/fhtml/test/bug.html similarity index 100% rename from extra/http/server/templating/test/bug.html rename to extra/http/server/templating/fhtml/test/bug.html diff --git a/extra/http/server/templating/test/example.fhtml b/extra/http/server/templating/fhtml/test/example.fhtml similarity index 100% rename from extra/http/server/templating/test/example.fhtml rename to extra/http/server/templating/fhtml/test/example.fhtml diff --git a/extra/http/server/templating/test/example.html b/extra/http/server/templating/fhtml/test/example.html similarity index 100% rename from extra/http/server/templating/test/example.html rename to extra/http/server/templating/fhtml/test/example.html diff --git a/extra/http/server/templating/test/stack.fhtml b/extra/http/server/templating/fhtml/test/stack.fhtml similarity index 100% rename from extra/http/server/templating/test/stack.fhtml rename to extra/http/server/templating/fhtml/test/stack.fhtml diff --git a/extra/http/server/templating/test/stack.html b/extra/http/server/templating/fhtml/test/stack.html similarity index 100% rename from extra/http/server/templating/test/stack.html rename to extra/http/server/templating/fhtml/test/stack.html diff --git a/extra/http/server/validators/validators-tests.factor b/extra/http/server/validators/validators-tests.factor new file mode 100644 index 0000000000..ff68dcfc64 --- /dev/null +++ b/extra/http/server/validators/validators-tests.factor @@ -0,0 +1,4 @@ +IN: http.server.validators.tests +USING: kernel sequences tools.test http.server.validators ; + +[ t t ] [ "foo" [ v-number ] with-validator >r validation-error? r> ] unit-test diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor new file mode 100644 index 0000000000..03beb8c3ff --- /dev/null +++ b/extra/http/server/validators/validators.factor @@ -0,0 +1,64 @@ +! Copyright (C) 2006, 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: kernel continuations sequences math namespaces +math.parser assocs new-slots ; +IN: http.server.validators + +TUPLE: validation-error value reason ; + +: validation-error ( value reason -- * ) + \ validation-error construct-boa throw ; + +: with-validator ( string quot -- result error? ) + [ f ] compose curry + [ dup validation-error? [ t ] [ rethrow ] if ] recover ; inline + +: validate-param ( name validator assoc -- error? ) + swap pick + >r >r at r> with-validator swap r> set ; + +: validate-params ( validators assoc -- error? ) + [ validate-param ] curry { } assoc>map [ ] contains? ; + +: v-default ( str def -- str ) + over empty? spin ? ; + +: v-required ( str -- str ) + dup empty? [ "required" validation-error ] when ; + +: v-min-length ( str n -- str ) + over length over < [ + [ "must be at least " % # " characters" % ] "" make + validation-error + ] [ + drop + ] if ; + +: v-max-length ( str n -- str ) + over length over > [ + [ "must be no more than " % # " characters" % ] "" make + validation-error + ] [ + drop + ] if ; + +: v-number ( str -- n ) + dup string>number [ ] [ + "must be a number" validation-error + ] ?if ; + +: v-min-value ( str n -- str ) + 2dup < [ + [ "must be at least " % # ] "" make + validation-error + ] [ + drop + ] if ; + +: v-max-value ( str n -- str ) + 2dup > [ + [ "must be no more than " % # ] "" make + validation-error + ] [ + drop + ] if ; From b3fcd179a04d397b05d11c390577eb4d9b380be2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 22:07:45 -0600 Subject: [PATCH 33/36] refactor conversions --- extra/calendar/format/format.factor | 55 +++++++++-------------------- 1 file changed, 17 insertions(+), 38 deletions(-) diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index c1bd6427a7..89e09e0d0c 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -36,8 +36,12 @@ M: timestamp year. ( timestamp -- ) : pad-00 number>string 2 CHAR: 0 pad-left ; +: pad-0000 number>string 4 CHAR: 0 pad-left ; + : write-00 pad-00 write ; +: write-0000 pad-0000 write ; + : (timestamp>string) ( timestamp -- ) dup day-of-week day-abbreviations3 nth write ", " write dup day>> number>string write bl @@ -107,18 +111,16 @@ M: timestamp year. ( timestamp -- ) 60 / + * ] if ; +: read-ymd ( -- y m d ) + read-0000 "-" expect read-00 "-" expect read-00 ; + +: read-hms ( -- h m s ) + read-00 ":" expect read-00 ":" expect read-00 ; + : (rfc3339>timestamp) ( -- timestamp ) - read-0000 ! year - "-" expect - read-00 ! month - "-" expect - read-00 ! day + read-ymd "Tt" expect - read-00 ! hour - ":" expect - read-00 ! minute - ":" expect - read-00 ! second + read-hms read-rfc3339-gmt-offset ! timezone ; @@ -126,49 +128,25 @@ M: timestamp year. ( timestamp -- ) [ (rfc3339>timestamp) ] with-string-reader ; : (ymdhms>timestamp) ( -- timestamp ) - read-0000 ! year - "-" expect - read-00 ! month - "-" expect - read-00 ! day - " " expect - read-00 ! hour - ":" expect - read-00 ! minute - ":" expect - read-00 ! second - 0 ! timezone - ; + read-ymd " " expect read-hms 0 ; : ymdhms>timestamp ( str -- timestamp ) [ (ymdhms>timestamp) ] with-string-reader ; : (hms>timestamp) ( -- timestamp ) - f f f - read-00 ! hour - ":" expect - read-00 ! minute - ":" expect - read-00 ! second - f ; + f f f read-hms f ; : hms>timestamp ( str -- timestamp ) [ (hms>timestamp) ] with-string-reader ; : (ymd>timestamp) ( -- timestamp ) - read-0000 ! year - "-" expect - read-00 ! month - "-" expect - read-00 ! day - f f f f ; + read-ymd f f f f ; : ymd>timestamp ( str -- timestamp ) [ (ymd>timestamp) ] with-string-reader ; - : (timestamp>ymd) ( timestamp -- ) - dup timestamp-year number>string write + dup timestamp-year write-0000 "-" write dup timestamp-month write-00 "-" write @@ -188,6 +166,7 @@ M: timestamp year. ( timestamp -- ) [ (timestamp>hms) ] with-string-writer ; : timestamp>ymdhms ( timestamp -- str ) + >gmt [ dup (timestamp>ymd) " " write From 955387f5b7e59292ac36166b7a4a15795b9d4515 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Mar 2008 03:00:10 -0600 Subject: [PATCH 34/36] HTTP authorization framework, first cut --- extra/http/server/auth/auth.factor | 25 +++++++ extra/http/server/auth/basic/basic.factor | 41 +++++++++++ extra/http/server/auth/login/login.factor | 69 +++++++++++++++++++ extra/http/server/auth/login/login.fhtml | 25 +++++++ .../auth/providers/assoc/assoc-tests.factor | 18 +++++ .../server/auth/providers/assoc/assoc.factor | 23 +++++++ .../server/auth/providers/db/db-tests.factor | 24 +++++++ extra/http/server/auth/providers/db/db.factor | 53 ++++++++++++++ .../server/auth/providers/null/null.factor | 14 ++++ .../server/auth/providers/providers.factor | 18 +++++ .../server/sessions/sessions-tests.factor | 9 ++- extra/http/server/sessions/sessions.factor | 2 + .../http/server/templating/fhtml/fhtml.factor | 2 +- 13 files changed, 320 insertions(+), 3 deletions(-) create mode 100755 extra/http/server/auth/auth.factor create mode 100755 extra/http/server/auth/basic/basic.factor create mode 100755 extra/http/server/auth/login/login.factor create mode 100755 extra/http/server/auth/login/login.fhtml create mode 100755 extra/http/server/auth/providers/assoc/assoc-tests.factor create mode 100755 extra/http/server/auth/providers/assoc/assoc.factor create mode 100755 extra/http/server/auth/providers/db/db-tests.factor create mode 100755 extra/http/server/auth/providers/db/db.factor create mode 100755 extra/http/server/auth/providers/null/null.factor create mode 100755 extra/http/server/auth/providers/providers.factor diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor new file mode 100755 index 0000000000..a53905bce1 --- /dev/null +++ b/extra/http/server/auth/auth.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.auth +USING: new-slots accessors http.server.auth.providers.null +http.server.auth.strategies.null ; + +TUPLE: authentication responder provider strategy ; + +: ( responder -- authentication ) + null-auth-provider null-auth-strategy + authentication construct-boa ; + +SYMBOL: current-user-id +SYMBOL: auth-provider +SYMBOL: auth-strategy + +M: authentication call-responder ( request path responder -- response ) + dup provider>> auth-provider set + dup strategy>> auth-strategy set + pick auth-provider get logged-in? dup current-user-id set + [ + responder>> call-responder + ] [ + 2drop auth-provider get require-login + ] if* ; diff --git a/extra/http/server/auth/basic/basic.factor b/extra/http/server/auth/basic/basic.factor new file mode 100755 index 0000000000..2ea74febba --- /dev/null +++ b/extra/http/server/auth/basic/basic.factor @@ -0,0 +1,41 @@ +! Copyright (c) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors new-slots quotations assocs kernel splitting +base64 html.elements io combinators http.server +http.server.auth.providers http.server.auth.providers.null +http sequences ; +IN: http.server.auth.basic + +TUPLE: basic-auth responder realm provider ; + +C: basic-auth + +: authorization-ok? ( provider header -- ? ) + #! Given the realm and the 'Authorization' header, + #! authenticate the user. + dup [ + " " split1 swap "Basic" = [ + base64> ":" split1 spin check-login + ] [ + 2drop f + ] if + ] [ + 2drop f + ] if ; + +: <401> ( realm -- response ) + 401 "Unauthorized" + "Basic realm=\"" rot "\"" 3append + "WWW-Authenticate" set-header + [ + + "Username or Password is invalid" write + + ] >>body ; + +: logged-in? ( request responder -- ? ) + provider>> swap "authorization" header authorization-ok? ; + +M: basic-auth call-responder ( request path responder -- response ) + pick over logged-in? + [ responder>> call-responder ] [ 2nip realm>> <401> ] if ; diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor new file mode 100755 index 0000000000..e2f9a3608a --- /dev/null +++ b/extra/http/server/auth/login/login.factor @@ -0,0 +1,69 @@ +! Copyright (c) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: accessors new-slots quotations assocs kernel splitting +base64 html.elements io combinators http.server +http.server.auth.providers http.server.actions +http.server.sessions http.server.templating.fhtml http sequences +io.files namespaces ; +IN: http.server.auth.login + +TUPLE: login-auth responder provider ; + +C: (login-auth) login-auth + +SYMBOL: logged-in? +SYMBOL: provider +SYMBOL: post-login-url + +: login-page ( -- response ) + "text/html" [ + "extra/http/server/auth/login/login.fhtml" + resource-path run-template-file + ] >>body ; + +: + + [ login-page ] >>get + + { + { "name" [ ] } + { "password" [ ] } + } >>post-params + [ + "password" get + "name" get + provider sget check-login [ + t logged-in? sset + post-login-url sget + ] [ + login-page + ] if + ] >>post ; + +: + + [ + f logged-in? sset + request get "login" + ] >>post ; + +M: login-auth call-responder ( request path responder -- response ) + logged-in? sget + [ responder>> call-responder ] [ + pick method>> "GET" = [ + nip + provider>> provider sset + dup request-url post-login-url sset + "login" f session-link + ] [ + 3drop <400> + ] if + ] if ; + +: ( responder provider -- auth ) + (login-auth) + + swap >>default + "login" add-responder + "logout" add-responder + ; diff --git a/extra/http/server/auth/login/login.fhtml b/extra/http/server/auth/login/login.fhtml new file mode 100755 index 0000000000..9bb1438588 --- /dev/null +++ b/extra/http/server/auth/login/login.fhtml @@ -0,0 +1,25 @@ + + +

Login required

+ + + + + + + + + + + + + + +
User name:
Password:
+ + + + + + + diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor new file mode 100755 index 0000000000..3270fe06e3 --- /dev/null +++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor @@ -0,0 +1,18 @@ +IN: http.server.auth.providers.assoc.tests +USING: http.server.auth.providers +http.server.auth.providers.assoc tools.test +namespaces ; + + "provider" set + +"slava" "provider" get new-user + +[ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with + +[ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test + +[ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with + +"fdasf" "slava" "provider" get set-password + +[ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/http/server/auth/providers/assoc/assoc.factor new file mode 100755 index 0000000000..d57be622c7 --- /dev/null +++ b/extra/http/server/auth/providers/assoc/assoc.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.auth.providers.assoc +USING: new-slots accessors assocs kernel +http.server.auth.providers ; + +TUPLE: assoc-auth-provider assoc ; + +: ( -- provider ) + H{ } clone assoc-auth-provider construct-boa ; + +M: assoc-auth-provider check-login + assoc>> at = ; + +M: assoc-auth-provider new-user + assoc>> + 2dup key? [ drop user-exists ] when + t -rot set-at ; + +M: assoc-auth-provider set-password + assoc>> + 2dup key? [ drop no-such-user ] unless + set-at ; diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor new file mode 100755 index 0000000000..384e094f39 --- /dev/null +++ b/extra/http/server/auth/providers/db/db-tests.factor @@ -0,0 +1,24 @@ +IN: http.server.auth.providers.db.tests +USING: http.server.auth.providers +http.server.auth.providers.db tools.test +namespaces db db.sqlite db.tuples continuations ; + +db-auth-provider "provider" set + +"auth-test.db" sqlite-db [ + + [ user drop-table ] ignore-errors + [ user create-table ] ignore-errors + + "slava" "provider" get new-user + + [ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with + + [ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test + + [ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with + + "fdasf" "slava" "provider" get set-password + + [ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test +] with-db diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor new file mode 100755 index 0000000000..9583122875 --- /dev/null +++ b/extra/http/server/auth/providers/db/db.factor @@ -0,0 +1,53 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: db db.tuples db.types new-slots accessors +http.server.auth.providers kernel ; +IN: http.server.auth.providers.db + +TUPLE: user name password ; + +: user construct-empty ; + +user "USERS" +{ + { "name" "NAME" { VARCHAR 256 } +assigned-id+ } + { "password" "PASSWORD" { VARCHAR 256 } +not-null+ } +} define-persistent + +: init-users-table ( -- ) + user create-table ; + +TUPLE: db-auth-provider ; + +: db-auth-provider T{ db-auth-provider } ; + +M: db-auth-provider check-login + drop + + swap >>name + swap >>password + select-tuple >boolean ; + +M: db-auth-provider new-user + drop + [ + + swap >>name + + dup select-tuple [ name>> user-exists ] when + + "unassigned" >>password + + insert-tuple + ] with-transaction ; + +M: db-auth-provider set-password + drop + [ + + swap >>name + + dup select-tuple [ ] [ no-such-user ] ?if + + swap >>password update-tuple + ] with-transaction ; diff --git a/extra/http/server/auth/providers/null/null.factor b/extra/http/server/auth/providers/null/null.factor new file mode 100755 index 0000000000..702111972e --- /dev/null +++ b/extra/http/server/auth/providers/null/null.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: http.server.auth.providers kernel ; +IN: http.server.auth.providers.null + +TUPLE: null-auth-provider ; + +: null-auth-provider T{ null-auth-provider } ; + +M: null-auth-provider check-login 3drop f ; + +M: null-auth-provider new-user 3drop f ; + +M: null-auth-provider set-password 3drop f ; diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor new file mode 100755 index 0000000000..1e0fd33a67 --- /dev/null +++ b/extra/http/server/auth/providers/providers.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel ; +IN: http.server.auth.providers + +GENERIC: check-login ( password user provider -- ? ) + +GENERIC: new-user ( user provider -- ) + +GENERIC: set-password ( password user provider -- ) + +TUPLE: user-exists name ; + +: user-exists ( name -- * ) \ user-exists construct-boa throw ; + +TUPLE: no-such-user name ; + +: no-such-user ( name -- * ) \ no-such-user construct-boa throw ; diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor index 4c21ba3c8d..d771737c73 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/http/server/sessions/sessions-tests.factor @@ -4,6 +4,12 @@ kernel accessors ; : with-session \ session swap with-variable ; inline +TUPLE: foo ; + +C: foo + +M: foo init-session drop 0 "x" sset ; + "1234" f [ [ ] [ 3 "x" sset ] unit-test @@ -18,8 +24,7 @@ kernel accessors ; [ t ] [ f cookie-sessions? ] unit-test [ ] [ - f - [ 0 "x" sset ] >>init + "manager" set ] unit-test diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index 2977e5938d..d7fed6bb64 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -11,6 +11,8 @@ IN: http.server.sessions GENERIC: init-session ( responder -- ) +M: dispatcher init-session drop ; + TUPLE: session-manager responder sessions ; : ( responder class -- responder' ) diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor index 37f4b85c51..e5770affc5 100755 --- a/extra/http/server/templating/fhtml/fhtml.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -9,7 +9,7 @@ assocs ; IN: http.server.templating.fhtml -: templating-vocab ( -- vocab-name ) "http.server.templating" ; +: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ; ! See apps/http-server/test/ or libs/furnace/ for template usage ! examples From 3c5a959ff4053997a9e4c5ee361a1f3f097f44be Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Mar 2008 03:02:01 -0600 Subject: [PATCH 35/36] Remove obsolete file --- extra/http/server/auth/auth.factor | 25 ------------------------- 1 file changed, 25 deletions(-) delete mode 100755 extra/http/server/auth/auth.factor diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor deleted file mode 100755 index a53905bce1..0000000000 --- a/extra/http/server/auth/auth.factor +++ /dev/null @@ -1,25 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -IN: http.server.auth -USING: new-slots accessors http.server.auth.providers.null -http.server.auth.strategies.null ; - -TUPLE: authentication responder provider strategy ; - -: ( responder -- authentication ) - null-auth-provider null-auth-strategy - authentication construct-boa ; - -SYMBOL: current-user-id -SYMBOL: auth-provider -SYMBOL: auth-strategy - -M: authentication call-responder ( request path responder -- response ) - dup provider>> auth-provider set - dup strategy>> auth-strategy set - pick auth-provider get logged-in? dup current-user-id set - [ - responder>> call-responder - ] [ - 2drop auth-provider get require-login - ] if* ; From 626334303c4d60501ffec5210aaebad7524f7dfb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Mar 2008 03:03:07 -0600 Subject: [PATCH 36/36] Fix build dir pollution in unit tests --- extra/db/sqlite/sqlite-tests.factor | 2 +- extra/db/sqlite/test.db | Bin 2048 -> 0 bytes extra/db/tuples/tuples-tests.factor | 2 +- .../server/auth/providers/db/db-tests.factor | 5 +++-- 4 files changed, 5 insertions(+), 4 deletions(-) delete mode 100644 extra/db/sqlite/test.db diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor index 08139610a0..b30cb4ba80 100755 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -3,7 +3,7 @@ prettyprint tools.test db.sqlite db sequences continuations db.types db.tuples unicode.case ; IN: db.sqlite.tests -: db-path "extra/db/sqlite/test.db" resource-path ; +: db-path "test.db" temp-file ; : test.db db-path sqlite-db ; [ ] [ [ db-path delete-file ] ignore-errors ] unit-test diff --git a/extra/db/sqlite/test.db b/extra/db/sqlite/test.db deleted file mode 100644 index e483c47cea528c95f10fcf66fcbb67ffa351ffd1..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2048 zcmWFz^vNtqRY=P(%1ta$FlJz3U}R))P*7lCU|k diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 3a1e2c4f25..7d72a644bf 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -159,7 +159,7 @@ TUPLE: annotation n paste-id summary author mode contents ; ! ] with-db : test-sqlite ( quot -- ) - >r "tuples-test.db" resource-path sqlite-db r> with-db ; + >r "tuples-test.db" temp-file sqlite-db r> with-db ; : test-postgresql ( -- ) >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor index 384e094f39..c4682c2051 100755 --- a/extra/http/server/auth/providers/db/db-tests.factor +++ b/extra/http/server/auth/providers/db/db-tests.factor @@ -1,11 +1,12 @@ IN: http.server.auth.providers.db.tests USING: http.server.auth.providers http.server.auth.providers.db tools.test -namespaces db db.sqlite db.tuples continuations ; +namespaces db db.sqlite db.tuples continuations +io.files ; db-auth-provider "provider" set -"auth-test.db" sqlite-db [ +"auth-test.db" temp-file sqlite-db [ [ user drop-table ] ignore-errors [ user create-table ] ignore-errors