From 6260cd3e5afdbca83f7433b836de9ed4142a0e5c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 25 Feb 2008 14:53:18 -0600
Subject: [PATCH 01/17] 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"
+ <get-request>
+ 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* ;
+<PRIVATE
-: read-response ( -- code header )
- #! After sending a GET or POST we read a response line and
- #! header.
- flush readln parse-response read-header ;
+: store-path ( request path -- request )
+ "?" split1 >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>> <inet> <client> 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 <inet> <client> [
- [ [ 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 ;
+
+: <get-request> ( -- request )
+ request construct-empty
+ "GET" >>method ;
+
+: http-get-stream ( url -- response stream )
+ <get-request> 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> <file-writer> stream-copy ;
+ swap http-get-stream check-response
+ [ swap <file-writer> 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 ;
+: <post-request> ( 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 <inet> <client> [
- 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 <post-request> 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>
+ 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 )
+ <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>
+ 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 )
+ <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
+: <mock-responder> ( path -- responder )
+ <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" <content> ;
-[ "foo/bar" ]
-[ "http://www.jedit.org/foo/bar" url>path ] unit-test
+: check-dispatch ( tag path -- ? )
+ over off
+ <request> swap default-host get call-responder
+ write-response call get ;
-[ "" ]
-[ "http://www.jedit.org/" url>path ] unit-test
+[
+ "" <dispatcher>
+ "foo" <mock-responder> add-responder
+ "bar" <mock-responder> add-responder
+ "baz/" <dispatcher>
+ "123" <mock-responder> add-responder
+ "default" <mock-responder> >>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 ] [
+ <request>
+ "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 ;
+: <responder> ( 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 ;
+: <trivial-responder> ( quot response -- responder )
+ trivial-responder construct-boa
+ "" <responder> 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 -- )
+ <html>
+ <body>
+ <h1> swap number>string write bl write </h1>
+ </body>
+ </html> ;
-\ parse-request NOTICE add-input-logging
+: <trivial-response> ( code message -- quot response )
+ [ [ trivial-response-body ] 2curry ] 2keep <response>
+ "text/html" set-content-type
+ swap >>message
+ swap >>code ;
+
+: <404> ( -- quot response )
+ 404 "Not Found" <trivial-response> ;
+
+: <redirect> ( to code message -- quot response )
+ <trivial-response>
+ rot "location" set-response-header ;
+
+: <permanent-redirect> ( to -- quot response )
+ 301 "Moved Permanently" <redirect> ;
+
+: <temporary-redirect> ( to -- quot response )
+ 307 "Temporary Redirect" <redirect> ;
+
+: <content> ( content-type -- response )
+ <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 <permanent-redirect> ;
+
+: <no-/-responder> ( -- responder )
+ "" <responder> no-/-responder construct-delegate ;
+
+<no-/-responder> 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> <trivial-responder> 404-responder set-global
+
+M: dispatcher do-responder
+ find-responder call-responder ;
+
+: <dispatcher> ( path -- dispatcher )
+ <responder>
+ 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 <slava@factorcode.org>
Date: Mon, 25 Feb 2008 15:40:40 -0600
Subject: [PATCH 02/17] 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 -- )
- <html> <body> <h1> write </h1> </body> </html> ;
-
-: 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 <slava@factorcode.org>
Date: Fri, 29 Feb 2008 00:57:38 -0600
Subject: [PATCH 03/17] 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 \"<html><body>Success!</body></html>\" 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
- <html> <body>
- "Username or Password is invalid" write
- </body> </html> ;
-
-: 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>> <inet> <client> 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 ;
: <get-request> ( -- request )
- request construct-empty
- "GET" >>method ;
+ <request> "GET" >>method ;
: http-get-stream ( url -- response stream )
<get-request> http-request ;
@@ -86,7 +85,7 @@ PRIVATE>
dup download-name download-to ;
: <post-request> ( content-type content -- request )
- request construct-empty
+ <request>
"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 ;
+
+: <cookie> ( 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 ] }
+ [ <cookie> 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>
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 )
<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>
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 )
<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 ;
+
+: <raw-response> ( -- 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> 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" <trivial-response>
+ "Basic realm=\"" rot name>> "\"" 3append
+ "WWW-Authenticate" set-header
+ [
+ <html> <body>
+ "Username or Password is invalid" write
+ </body> </html>
+ ] >>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 ;
+
+: <callback-responder> ( 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 ;
+
+: <callback> ( 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 )
+ <callback>
+ 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.
+ <temporary-redirect> 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 )
+ <raw-response>
+ 200 >>code
+ "CGI output follows" >>message
+ swap [
+ stdio get swap cgi-descriptor <process-stream> [
+ 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 ;
-: <mock-responder> ( path -- responder )
- <responder> mock-responder construct-delegate ;
+C: <mock-responder> mock-responder
-M: mock-responder do-responder
+M: mock-responder call-responder
2nip
path>> on
- [ "Hello world" print ]
"text/plain" <content> ;
: check-dispatch ( tag path -- ? )
over off
<request> swap default-host get call-responder
- write-response call get ;
+ write-response get ;
[
- "" <dispatcher>
- "foo" <mock-responder> add-responder
- "bar" <mock-responder> add-responder
- "baz/" <dispatcher>
- "123" <mock-responder> add-responder
+ <dispatcher>
+ "foo" <mock-responder> "foo" add-responder
+ "bar" <mock-responder> "bar" add-responder
+ <dispatcher>
+ "123" <mock-responder> "123" add-responder
"default" <mock-responder> >>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 ] [
<request>
"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 )
-: <responder> ( path -- responder )
- "/" ?tail responder construct-boa ;
+TUPLE: trivial-responder response ;
-GENERIC: do-responder ( request path responder -- quot response )
+C: <trivial-responder> trivial-responder
-TUPLE: trivial-responder quot response ;
-
-: <trivial-responder> ( quot response -- responder )
- trivial-responder construct-boa
- "" <responder> 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 -- )
<html>
@@ -28,23 +21,30 @@ M: trivial-responder do-responder
</body>
</html> ;
-: <trivial-response> ( code message -- quot response )
- [ [ trivial-response-body ] 2curry ] 2keep <response>
+: <trivial-response> ( code message -- response )
+ <response>
+ 2over [ trivial-response-body ] 2curry >>body
"text/html" set-content-type
swap >>message
swap >>code ;
-: <404> ( -- quot response )
+: <404> ( -- response )
404 "Not Found" <trivial-response> ;
-: <redirect> ( to code message -- quot response )
- <trivial-response>
- rot "location" set-response-header ;
+SYMBOL: 404-responder
-: <permanent-redirect> ( to -- quot response )
+[ <404> ] <trivial-responder> 404-responder set-global
+
+: <redirect> ( to code message -- response )
+ <trivial-response>
+ swap "location" set-header ;
+
+\ <redirect> DEBUG add-input-logging
+
+: <permanent-redirect> ( to -- response )
301 "Moved Permanently" <redirect> ;
-: <temporary-redirect> ( to -- quot response )
+: <temporary-redirect> ( to -- response )
307 "Temporary Redirect" <redirect> ;
: <content> ( 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 <permanent-redirect> ;
-: <no-/-responder> ( -- responder )
- "" <responder> no-/-responder construct-delegate ;
+M: dispatcher call-responder
+ over [
+ find-responder call-responder
+ ] [
+ 2drop redirect-with-/
+ ] if ;
-<no-/-responder> no-/-responder set-global
+: <dispatcher> ( -- 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> <trivial-responder> 404-responder set-global
-
-M: dispatcher do-responder
- find-responder call-responder ;
-
-: <dispatcher> ( path -- dispatcher )
- <responder>
- 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" <trivial-response>
+ 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 <session> [
+ [ ] [ 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> url-sessions? ] unit-test
+[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
+
+[ ] [
+ f <url-sessions>
+ [ 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 ;
+
+: <session-manager> ( responder class -- responder' )
+ >r [ ] H{ } clone session-manager construct-boa r>
+ construct-delegate ; inline
+
+TUPLE: session id manager namespace alarm ;
+
+: <session> ( id manager -- session )
+ H{ } clone <box> \ 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
+ [ <session> 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 ;
+
+: <url-sessions> ( responder -- responder' )
+ url-sessions <session-manager> ;
+
+: 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 <temporary-redirect>
+ ] 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 ;
+
+: <cookie-sessions> ( responder -- responder' )
+ cookie-sessions <session-manager> ;
+
+: get-session-cookie ( request -- cookie )
+ sess-id get-cookie ;
+
+: <session-cookie> ( id -- cookie )
+ sess-id <cookie> ;
+
+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
+ <session-cookie> 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" <trivial-response> ;
+
+: <file-responder> ( root hook -- responder )
+ H{ } clone file-responder construct-boa ;
+
+: <static> ( root -- responder )
+ [
+ <content>
+ over file-length "content-length" set-header
+ over file-http-date "last-modified" set-header
+ swap [ <file-reader> stdio get stream-copy ] curry >>body
+ ] <file-responder> ;
+
+: 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 <a =href a> write </a> ;
+
+: directory. ( path -- )
+ dup file-name [
+ <h1> dup file-name write </h1>
+ <ul>
+ directory sort-keys
+ [ <li> file. </li> ] assoc-each
+ </ul>
+ ] simple-html-document ;
+
+: list-directory ( directory -- response )
+ "text/html" <content>
+ 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" <content>
+ 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 <process-stream> [
- 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
- <file-reader> 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 <a =href a> write </a> ;
-
-: directory. ( path request -- )
- dup [
- <h1> write </h1>
- <ul>
- directory sort-keys
- [ <li> file. </li> ] assoc-each
- </ul>
- ] 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 <file-reader> 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
+
+: <sources> ( root -- responder )
+ [
+ drop
+ "text/html" <content>
+ over file-http-date "last-modified" set-header
+ swap [
+ dup file-name swap <file-reader> htmlize-stream
+ ] curry >>body
+ ] <file-responder> ;
From 24b4fb0df9da74f086a572fc987aab658d78c58b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 29 Feb 2008 10:37:39 -0600
Subject: [PATCH 04/17] 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 <slava@factorcode.org>
Date: Mon, 3 Mar 2008 02:19:36 -0600
Subject: [PATCH 05/17] 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> 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.
- <temporary-redirect> exit-with ;
+ request get swap <temporary-redirect> 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> 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
+
+[
+ <dispatcher>
+ "default" <mock-responder> >>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> trivial-responder
-M: trivial-responder call-responder 2nip response>> call ;
+M: trivial-responder call-responder nip response>> call ;
: trivial-response-body ( code message -- )
<html>
@@ -33,18 +33,26 @@ M: trivial-responder call-responder 2nip response>> call ;
SYMBOL: 404-responder
-[ <404> ] <trivial-responder> 404-responder set-global
+[ drop <404> ] <trivial-responder> 404-responder set-global
-: <redirect> ( 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 ;
+
+: <redirect> ( request to code message -- response )
<trivial-response>
- swap "location" set-header ;
+ -rot modify-for-redirect
+ "location" set-header ;
\ <redirect> DEBUG add-input-logging
-: <permanent-redirect> ( to -- response )
+: <permanent-redirect> ( request to -- response )
301 "Moved Permanently" <redirect> ;
-: <temporary-redirect> ( to -- response )
+: <temporary-redirect> ( request to -- response )
307 "Temporary Redirect" <redirect> ;
: <content> ( 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> ( -- dispatcher )
+ 404-responder H{ } clone dispatcher construct-boa ;
+
+: set-main ( dispatcher name -- dispatcher )
+ [ <temporary-redirect> ] curry
+ <trivial-responder> >>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 <permanent-redirect> ;
+ dup path>> "/" append <permanent-redirect> ;
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> ( -- 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 ;
+
+: <webapp> ( class -- dispatcher )
+ <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" <trivial-response>
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 <session> [
[ ] [ 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 ;
: <session-manager> ( 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
[ <session> 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 <temporary-redirect>
+ dup request-url <temporary-redirect>
] if* ;
M: url-sessions session-link*
@@ -96,14 +95,15 @@ TUPLE: cookie-sessions ;
: <cookie-sessions> ( responder -- responder' )
cookie-sessions <session-manager> ;
-: 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 ;
: <session-cookie> ( id -- cookie )
sess-id <cookie> ;
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" <trivial-response> ;
+
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 <slava@factorcode.org>
Date: Mon, 3 Mar 2008 05:40:29 -0500
Subject: [PATCH 06/17] 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> "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" <repetition> concat append ]
+{ { +path+ [ ] } { "xxx" [ string>number ] } }
+"POST" <action> "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> 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> 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" <trivial-response> ;
+
: <404> ( -- response )
404 "Not Found" <trivial-response> ;
@@ -66,7 +69,7 @@ TUPLE: dispatcher default responders ;
404-responder H{ } clone dispatcher construct-boa ;
: set-main ( dispatcher name -- dispatcher )
- [ <temporary-redirect> ] curry
+ [ <permanent-redirect> ] curry
<trivial-responder> >>default ;
: split-path ( path -- rest first )
@@ -102,6 +105,7 @@ M: dispatcher call-responder
: <webapp> ( class -- dispatcher )
<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" <trivial-response> ;
-
M: file-responder call-responder ( request path responder -- response )
over [
".." pick subseq? [
From a350a91232ad6fd4179c3c39717a234be27886eb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 3 Mar 2008 05:40:50 -0500
Subject: [PATCH 07/17] 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 <select-by-slots-statement> ( 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 [ <delete-tuple-statement> ] cache
[ bind-tuple ] keep execute-statement ;
-: select-tuples ( tuple -- tuple )
+: select-tuples ( tuple -- tuples )
dup dup class <select-by-slots-statement> [
[ bind-tuple ] keep query-tuples
] with-disposal ;
From 27dd4f17019d5287d1d9ab524694e7cd81bbddd4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 4 Mar 2008 22:04:56 -0600
Subject: [PATCH 08/17] 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 <process-stream> } " 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 <process-stream> } " 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 <void*> [ ! 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 <slava@factorcode.org>
Date: Tue, 4 Mar 2008 22:13:30 -0600
Subject: [PATCH 09/17] 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: <method>
{ $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 ;
-: <method-word> ( quot class generic -- word )
- [ make-method-def ] 2keep
- method-word-name f <word>
- dup rot define
- dup xref ;
+: method-word-props ( quot class generic -- assoc )
+ [
+ "method-generic" set
+ "method-class" set
+ "method-def" set
+ ] H{ } make-assoc ;
-: <method> ( quot class generic -- method )
+: <method> ( quot class generic -- word )
check-method
- [ <method-word> ] 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 <word>
+ 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 <reversed> ?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 <repetition>
- 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 <repetition> 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 <reversed> ?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 <repetition>
+ 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 <repetition> 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 <tuple> with a non-literal class failed
-: <tuple>-regression <tuple> ;
-
-[ t ] [ \ <tuple>-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 [ <array> 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 <flat-slice>
- [ [ - ] 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
-
-[ ] [ [ <tuple> ] 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 <tuple> with a non-literal class failed
+: <tuple>-regression <tuple> ;
+
+[ t ] [ \ <tuple>-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 [ <array> 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 <flat-slice>
+ [ [ - ] 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
+
+[ ] [ [ <tuple> ] 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 c51ad0aa5a7af55782f0ae5aed8cce039b015b2a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 4 Mar 2008 22:44:46 -0600
Subject: [PATCH 10/17] 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
<effect> ;
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 <vocab-profile> write-object ;
M: method-body (profile.)
- "method" word-prop
- dup method-specializer over method-generic 2array synopsis
- swap method-generic <usage-profile> write-object ;
+ dup synopsis swap "method-generic" word-prop
+ <usage-profile> write-object ;
: counter. ( obj n -- )
[
From e933cf97fe035697209df546430393445c2b0ab3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 4 Mar 2008 22:46:01 -0600
Subject: [PATCH 11/17] 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 [ <vocab> ] 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 fa898aa8c6cfbb331f6141a28b0f8a331fc602d5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 5 Mar 2008 15:02:02 -0600
Subject: [PATCH 12/17] 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 <inet4> ;
-
-: 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 <server> dup "server" set [
- server-loop
- ] with-disposal
- ] ignore-errors ;
-
-: simple-client ( -- )
- server-addr <client> [
- 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 <client> [
- CHAR: x write1
- ] with-stream ;
-
-: clients ( n -- )
- dup pprint " clients: " write [
- dup 2 * <count-down> 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 <inet4> ;
+
+: 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 <server> dup "server" set [
+ server-loop
+ ] with-disposal
+ ] ignore-errors ;
+
+: simple-client ( -- )
+ server-addr <client> [
+ 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 <client> [
+ CHAR: x write1
+ ] with-stream ;
+
+: clients ( n -- )
+ dup pprint " clients: " write [
+ dup 2 * <count-down> 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 <slava@oberon.internal.stack-effects.com>
Date: Wed, 5 Mar 2008 15:23:02 -0600
Subject: [PATCH 13/17] 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 <slava@factorcode.org>
Date: Wed, 5 Mar 2008 15:24:13 -0600
Subject: [PATCH 14/17] 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 <slava@factorcode.org>
Date: Wed, 5 Mar 2008 15:59:15 -0600
Subject: [PATCH 15/17] 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 <slava@oberon.internal.stack-effects.com>
Date: Wed, 5 Mar 2008 16:00:34 -0600
Subject: [PATCH 16/17] 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|<DeWWWgIfG`XovteRbX<ncxBl9W-
zAQ}auAut*OWQ9NoBfGeyBx56UNn%n?YC&pIaef|zWO5F2bqsM;2yt}saaDkbDQM&+
z=B6r?B^D)TBo=8H8))h%B<Gjrl@wJX3u=P$CM)wg2IddUcbLyG?*%eP!DtAKhQOc<
z0bW*SQAw}-;#A+%ip=DEUKSKCA2YMKq*rEcZl!Z#USdk35EHYgvR7hWs$XikLR4yE
YPGVjPA0xA<v{!yco?~umQD$-?0FFaGg8%>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
<effect> ;
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 b6b8ab32b55b91ec59dccd9f388449502e4e75a8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Wed, 5 Mar 2008 16:24:32 -0600
Subject: [PATCH 17/17] 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