Fix UI hang, add if-box combinator

core/boxes/boxes.factor

@@ -19,3 +19,6 @@ TUPLE: box value full? ;
 
 : ?box ( box -- value/f ? )
     dup box-full? [ box> t ] [ drop f f ] if ;
+
+: if-box? ( box quot -- )
+    >r ?box r> [ drop ] if ; inline

core/vocabs/loader/loader.factor

@@ -4,7 +4,7 @@ USING: namespaces sequences io.files kernel assocs words vocabs
 definitions parser continuations inspector debugger io io.styles
 io.streams.lines hashtables sorting prettyprint source-files
 arrays combinators strings system math.parser compiler.errors
-splitting ;
+splitting init ;
 IN: vocabs.loader
 
 SYMBOL: vocab-roots
@@ -175,7 +175,13 @@ SYMBOL: failures
 
 : refresh ( prefix -- ) to-refresh do-refresh ;
 
-: refresh-all ( -- ) "" refresh ;
+SYMBOL: sources-changed?
+
+[ t sources-changed? set-global ] "vocabs.loader" add-init-hook
+
+: refresh-all ( -- )
+    sources-changed? get-global
+    [ "" refresh f sources-changed? set-global ] when ;
 
 GENERIC: (load-vocab) ( name -- vocab )
 

extra/alarms/alarms.factor

@@ -87,5 +87,4 @@ PRIVATE>
     from-now f add-alarm ;
 
 : cancel-alarm ( alarm -- )
-    alarm-entry ?box
+    alarm-entry [ alarms get-global heap-delete ] if-box? ;
-    [ alarms get-global heap-delete ] [ drop ] if ;

extra/concurrency/flags/flags-tests.factor

@@ -0,0 +1,46 @@
+IN: temporary
+USING: tools.test concurrency.flags kernel threads locals ;
+
+:: flag-test-1 ( -- )
+    [let | f [ <flag> ] |
+        [ f raise-flag ] "Flag test" spawn drop
+        f lower-flag
+        f flag-value?
+    ] ;
+
+[ f ] [ flag-test-1 ] unit-test
+
+:: flag-test-2 ( -- )
+    [let | f [ <flag> ] |
+        [ 1000 sleep f raise-flag ] "Flag test" spawn drop
+        f lower-flag
+        f flag-value?
+    ] ;
+
+[ f ] [ flag-test-2 ] unit-test
+
+:: flag-test-3 ( -- )
+    [let | f [ <flag> ] |
+        f raise-flag
+        f flag-value?
+    ] ;
+
+[ t ] [ flag-test-3 ] unit-test
+
+:: flag-test-4 ( -- )
+    [let | f [ <flag> ] |
+        [ f raise-flag ] "Flag test" spawn drop
+        f wait-for-flag
+        f flag-value?
+    ] ;
+
+[ t ] [ flag-test-4 ] unit-test
+
+:: flag-test-5 ( -- )
+    [let | f [ <flag> ] |
+        [ 1000 sleep f raise-flag ] "Flag test" spawn drop
+        f wait-for-flag
+        f flag-value?
+    ] ;
+
+[ t ] [ flag-test-5 ] unit-test

extra/concurrency/flags/flags.factor

@@ -9,8 +9,8 @@ TUPLE: flag value? thread ;
 
 : raise-flag ( flag -- )
     dup flag-value? [
-        dup flag-thread ?box
+        t over set-flag-value?
-        [ resume ] [ drop t over set-flag-value? ] if
+        dup flag-thread [ resume ] if-box?
     ] unless drop ;
 
 : wait-for-flag ( flag -- )
@@ -19,8 +19,4 @@ TUPLE: flag value? thread ;
     ] if ;
 
 : lower-flag ( flag -- )
-    dup flag-value? [
+    dup wait-for-flag f swap set-flag-value? ;
-        f swap set-flag-value?
-    ] [
-        wait-for-flag
-    ] if ;

extra/help/help.factor

@@ -132,13 +132,13 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
     nl
     "Debugger commands:" print
     nl
-    ":help - documentation for this error" print
+    ":s    - data stack at error time" print
-    ":s    - data stack at exception time" print
+    ":r    - retain stack at error time" print
-    ":r    - retain stack at exception time" print
+    ":c    - call stack at error time" print
-    ":c    - call stack at exception time" print
     ":edit - jump to source location (parse errors only)" print
 
-    ":get  ( var -- value ) accesses variables at time of the error" print ;
+    ":get  ( var -- value ) accesses variables at time of the error" print
+    ":vars - list all variables at error time";
 
 : :help ( -- )
     error get delegates [ error-help ] map [ ] subset

extra/http.good/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/http.good/basic-authentication/authors.txt

@@ -0,0 +1 @@
+Chris Double

extra/http.good/basic-authentication/basic-authentication-docs.factor

@@ -0,0 +1,69 @@
+! 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" }

extra/http.good/basic-authentication/basic-authentication-tests.factor

@@ -0,0 +1,66 @@
+! 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 

extra/http.good/basic-authentication/basic-authentication.factor

@@ -0,0 +1,65 @@
+! 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 ;

extra/http.good/basic-authentication/summary.txt

@@ -0,0 +1 @@
+HTTP Basic Authentication implementation

extra/http.good/basic-authentication/tags.txt

@@ -0,0 +1 @@
+web

extra/http.good/client/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/http.good/client/client-tests.factor

@@ -0,0 +1,26 @@
+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
+[ "/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

extra/http.good/client/client.factor

@@ -0,0 +1,96 @@
+! Copyright (C) 2005, 2008 Slava Pestov.
+! 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
+accessors ;
+IN: http.client
+
+: parse-url ( url -- resource host port )
+    "http://" ?head [ "Only http:// supported" throw ] unless
+    "/" split1 [ "/" swap append ] [ "/" ] if*
+    swap parse-host ;
+
+<PRIVATE
+
+: store-path ( request path -- request )
+    "?" split1 >r >>path r> dup [ query>assoc ] when >>query ;
+
+! 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 ;
+
+DEFER: (http-request)
+
+: absolute-redirect ( url -- request )
+    "request" get request-with-url ;
+
+: relative-redirect ( path -- request )
+    "request" get swap store-path ;
+
+: 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 ;
+
+: (http-request) ( request -- response stream )
+    dup host>> over port>> <inet> <client> stdio set
+    write-request flush read-response
+    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 ( response stream -- stream )
+    swap code>> success?
+    [ dispose "HTTP download failed" throw ] unless ;
+
+: http-get ( url -- string )
+    http-get-stream check-response contents ;
+
+: download-name ( url -- name )
+    file-name "?" split1 drop "/" ?tail drop ;
+
+: download-to ( url file -- )
+    #! Downloads the contents of a URL to a file.
+    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 -- request )
+    request construct-empty
+    "POST" >>method
+    swap >>post-data
+    swap >>post-data-type ;
+
+: http-post ( content-type content url -- response string )
+    #! The content is URL encoded for you.
+    -rot url-encode <post-request> http-request contents ;

extra/http.good/client/summary.txt

@@ -0,0 +1 @@
+HTTP client

extra/http.good/client/tags.txt

@@ -0,0 +1,2 @@
+web
+network

extra/http.good/http-tests.factor

@@ -0,0 +1,115 @@
+USING: http tools.test multiline tuple-syntax
+io.streams.string kernel arrays splitting sequences     ;
+IN: temporary
+
+[ "hello%20world" ] [ "hello world" url-encode ] unit-test
+[ "hello world" ] [ "hello%20world" url-decode ] unit-test
+[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
+[ "" ] [ "%XX%XX%XX" url-decode ] unit-test
+[ "" ] [ "%XX%XX%X" url-decode ] unit-test
+
+[ "hello world"   ] [ "hello+world"    url-decode ] unit-test
+[ "hello world"   ] [ "hello%20world"  url-decode ] unit-test
+[ " ! "           ] [ "%20%21%20"      url-decode ] unit-test
+[ "hello world"   ] [ "hello world%"   url-decode ] unit-test
+[ "hello world"   ] [ "hello world%x"  url-decode ] unit-test
+[ "hello%20world" ] [ "hello world"    url-encode ] unit-test
+[ "%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

extra/http.good/http.factor

@@ -0,0 +1,277 @@
+! Copyright (C) 2003, 2008 Slava Pestov.
+! 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 ;
+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?
+    dup letter?
+    over LETTER? or
+    over digit? or
+    swap "/_-." member? or ; foldable
+
+: push-utf8 ( ch -- )
+    1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
+
+: url-encode ( str -- str )
+    [ [
+        dup url-quotable? [ , ] [ push-utf8 ] if
+    ] each ] "" make ;
+
+: url-decode-hex ( index str -- )
+    2dup length 2 - >= [
+        2drop
+    ] [
+        >r 1+ dup 2 + r> subseq  hex> [ , ] when*
+    ] if ;
+
+: url-decode-% ( index str -- index str )
+    2dup url-decode-hex >r 3 + r> ;
+
+: url-decode-+-or-other ( index str ch -- index str )
+    dup CHAR: + = [ drop CHAR: \s ] when , >r 1+ r> ;
+
+: url-decode-iter ( index str -- )
+    2dup length >= [
+        2drop
+    ] [
+        2dup nth dup CHAR: % = [
+            drop url-decode-%
+        ] [
+            url-decode-+-or-other
+        ] if url-decode-iter
+    ] if ;
+
+: url-decode ( str -- str )
+    [ 0 swap url-decode-iter ] "" make decode-utf8 ;
+
+: 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 ;
+
+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 )
+    [
+        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 ;

extra/http.good/mime/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/http.good/mime/mime.factor

@@ -0,0 +1,34 @@
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io assocs kernel sequences math namespaces splitting ;
+
+IN: http.mime
+
+: file-extension ( filename -- extension )
+    "." split dup length 1 <= [ drop f ] [ peek ] if ;
+
+: mime-type ( filename -- mime-type )
+    file-extension "mime-types" get at "application/octet-stream" or ;
+
+H{
+    { "html"   "text/html"                        }
+    { "txt"    "text/plain"                       }
+    { "xml"    "text/xml"                         }
+    { "css"    "text/css"                         }
+                                                    
+    { "gif"    "image/gif"                        }
+    { "png"    "image/png"                        }
+    { "jpg"    "image/jpeg"                       }
+    { "jpeg"   "image/jpeg"                       }
+                                                    
+    { "jar"    "application/octet-stream"         }
+    { "zip"    "application/octet-stream"         }
+    { "tgz"    "application/octet-stream"         }
+    { "tar.gz" "application/octet-stream"         }
+    { "gz"     "application/octet-stream"         }
+
+    { "pdf"    "application/pdf"                  }
+
+    { "factor" "text/plain"                       }
+    { "fhtml"  "application/x-factor-server-page" }
+} "mime-types" set-global

extra/http.good/server/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/http.good/server/server-tests.factor

@@ -0,0 +1,45 @@
+USING: http.server tools.test kernel namespaces accessors
+new-slots assocs.lib io http math sequences ;
+IN: temporary
+
+TUPLE: mock-responder ;
+
+: <mock-responder> ( path -- responder )
+    <responder> mock-responder construct-delegate ;
+
+M: mock-responder do-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 ;
+
+[
+    "" <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
+
+    [ 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
+
+    [ 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

extra/http.good/server/server.factor

@@ -0,0 +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 sequences prettyprint io.server logging calendar
+new-slots html.elements accessors math.parser combinators.lib ;
+IN: http.server
+
+TUPLE: responder path directory ;
+
+: <responder> ( path -- responder )
+    "/" ?tail responder construct-boa ;
+
+GENERIC: do-responder ( request path responder -- quot response )
+
+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>> ;
+
+: trivial-response-body ( code message -- )
+    <html>
+        <body>
+            <h1> swap number>string write bl write </h1>
+        </body>
+    </html> ;
+
+: <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" [
+        default-timeout
+        read-request dup log-request handle-request
+    ] with-server ;
+
+: httpd-main ( -- ) 8888 httpd ;
+
+MAIN: httpd-main

extra/http.good/server/summary.txt

@@ -0,0 +1 @@
+HTTP server

extra/http.good/server/tags.txt

@@ -0,0 +1,3 @@
+enterprise
+network
+web

extra/http.good/server/templating/authors.txt

@@ -0,0 +1,2 @@
+Slava Pestov
+Matthew Willis

extra/http.good/server/templating/templating-tests.factor

@@ -0,0 +1,17 @@
+USING: io io.files io.streams.string http.server.templating kernel tools.test
+    sequences ;
+IN: temporary
+
+: test-template ( path -- ? )
+    "extra/http/server/templating/test/" swap append
+    [
+        ".fhtml" append resource-path
+        [ run-template-file ] with-string-writer
+    ] keep
+    ".html" append resource-path file-contents = ;
+
+[ t ] [ "example" test-template ] unit-test
+[ t ] [ "bug" test-template ] unit-test
+[ t ] [ "stack" test-template ] unit-test
+
+[ ] [ "<%\n%>" parse-template drop ] unit-test

extra/http.good/server/templating/templating.factor

@@ -0,0 +1,96 @@
+! Copyright (C) 2005 Alex Chapman
+! Copyright (C) 2006, 2007 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+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 ;
+
+IN: http.server.templating
+
+: templating-vocab ( -- vocab-name ) "http.server.templating" ;
+
+! See apps/http-server/test/ or libs/furnace/ for template usage
+! examples
+
+! We use a custom lexer so that %> ends a token even if not
+! followed by whitespace
+TUPLE: template-lexer ;
+
+: <template-lexer> ( lines -- lexer )
+    <lexer> template-lexer construct-delegate ;
+
+M: template-lexer skip-word
+    [
+        {
+            { [ 2dup nth CHAR: " = ] [ drop 1+ ] }
+            { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
+            { [ t ] [ f skip ] }
+        } cond
+    ] change-column ;
+
+DEFER: <% delimiter
+
+: check-<% ( lexer -- col )
+    "<%" over lexer-line-text rot lexer-column start* ;
+
+: found-<% ( accum lexer col -- accum )
+    [
+        over lexer-line-text
+        >r >r lexer-column r> r> subseq parsed
+        \ write-html parsed
+    ] 2keep 2 + swap set-lexer-column ;
+
+: still-looking ( accum lexer -- accum )
+    [
+        dup lexer-line-text swap lexer-column tail
+        parsed \ print-html parsed
+    ] keep next-line ;
+
+: parse-%> ( accum lexer -- accum )
+    dup still-parsing? [
+        dup check-<%
+        [ found-<% ] [ [ still-looking ] keep parse-%> ] if*
+    ] [
+        drop
+    ] if ;
+
+: %> lexer get parse-%> ; parsing
+
+: parse-template-lines ( lines -- quot )
+    <template-lexer> [
+        V{ } clone lexer get parse-%> f (parse-until)
+    ] with-parser ;
+
+: parse-template ( string -- quot )
+    [
+        use [ clone ] change
+        templating-vocab use+
+        string-lines parse-template-lines
+    ] with-scope ;
+
+: eval-template ( string -- ) parse-template call ;
+
+: html-error. ( error -- )
+    <pre> error. </pre> ;
+
+: run-template-file ( filename -- )
+    [
+        [
+            "quiet" on
+            parser-notes off
+            templating-vocab use+
+            dup source-file file set ! so that reload works properly
+            [
+                ?resource-path file-contents
+                [ eval-template ] [ html-error. drop ] recover
+            ] keep
+        ] with-file-vocabs
+    ] assert-depth drop ;
+
+: run-relative-template-file ( filename -- )
+    file get source-file-path parent-directory
+    swap path+ run-template-file ;
+
+: template-convert ( infile outfile -- )
+    [ run-template-file ] with-file-writer ;

extra/http.good/server/templating/test/bug.fhtml

@@ -0,0 +1,5 @@
+<%
+    USING: prettyprint ;
+    ! Hello world
+    5 pprint
+%>

extra/http.good/server/templating/test/bug.html

@@ -0,0 +1,2 @@
+5
+

extra/http.good/server/templating/test/example.fhtml

@@ -0,0 +1,8 @@
+<% USING: math ; %>
+
+<html>
+    <head><title>Simple Embedded Factor Example</title></head>
+    <body>
+        <% 5 [ %><p>I like repetition</p><% ] times %>
+    </body>
+</html>

extra/http.good/server/templating/test/example.html

@@ -0,0 +1,9 @@
+
+
+<html>
+    <head><title>Simple Embedded Factor Example</title></head>
+    <body>
+        <p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p>
+    </body>
+</html>
+

extra/http.good/server/templating/test/stack.fhtml

@@ -0,0 +1 @@
+The stack: <% USING: prettyprint ;  .s %>

extra/http.good/server/templating/test/stack.html

@@ -0,0 +1,2 @@
+The stack: 
+

extra/http.good/summary.txt

@@ -0,0 +1 @@
+Common code shared by HTTP client and server

extra/http.good/tags.txt

@@ -0,0 +1,2 @@
+web
+network

extra/io/monitors/monitors.factor

@@ -49,7 +49,7 @@ M: simple-monitor set-timeout set-simple-monitor-timeout ;
     >r <simple-monitor> r> construct-delegate ; inline
 
 : notify-callback ( simple-monitor -- )
-    simple-monitor-callback ?box [ resume ] [ drop ] if ;
+    simple-monitor-callback [ resume ] if-box? ;
 
 M: simple-monitor timed-out
     notify-callback ;

extra/ui/windows/windows.factor

@@ -358,7 +358,6 @@ M: windows-ui-backend (close-window)
         { [ t ] [
             dup TranslateMessage drop
             dup DispatchMessage drop
-            yield
             event-loop
         ] }
     } cond ;
@@ -454,12 +453,11 @@ M: windows-ui-backend raise-window* ( world -- )
         win-hWnd SetFocus drop
     ] when* ;
 
-M: windows-ui-backend set-title ( string world -- )
+M: windows-ui-backend set-title ( string handle -- )
-    world-handle [ nip win-hWnd WM_SETTEXT 0 ] 2keep
     dup win-title [ free ] when*
-    >r malloc-u16-string dup r>
+    >r malloc-u16-string r>
-    set-win-title alien-address
+    2dup set-win-title
-    SendMessage drop ;
+    win-hWnd WM_SETTEXT 0 roll alien-address SendMessage drop ;
 
 M: windows-ui-backend ui
     [

extra/vocabs/monitor/monitor.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: threads io.files io.monitors init kernel
-tools.browser namespaces continuations ;
+tools.browser namespaces continuations vocabs.loader ;
 IN: vocabs.monitor
 
 ! Use file system change monitoring to flush the tags/authors
@@ -9,7 +9,9 @@ IN: vocabs.monitor
 SYMBOL: vocab-monitor
 
 : monitor-thread ( -- )
-    vocab-monitor get-global next-change 2drop reset-cache ;
+    vocab-monitor get-global
+    next-change 2drop
+    t sources-changed? set-global reset-cache ;
 
 : start-monitor-thread
     #! Silently ignore errors during monitor creation since