Merge branch 'master' of factorcode.org:/git/factor

core/io/encodings/encodings.factor

@@ -28,23 +28,62 @@ ERROR: encode-error ;
 
 ! Decoding
 
-<PRIVATE
-
 M: object <decoder> f decoder boa ;
 
+<PRIVATE
+
+: cr+ t >>cr drop ; inline
+
+: cr- f >>cr drop ; inline
+
 : >decoder< ( decoder -- stream encoding )
-    [ stream>> ] [ code>> ] bi ;
+    [ stream>> ] [ code>> ] bi ; inline
 
-: cr+ t swap set-decoder-cr ; inline
+: fix-read1 ( stream char -- char )
+    over cr>> [
+        over cr-
+        dup CHAR: \n = [
+            drop dup stream-read1
+        ] when
+    ] when nip ; inline
 
-: cr- f swap set-decoder-cr ; inline
+M: decoder stream-read1
+    dup >decoder< decode-char fix-read1 ;
+
+: fix-read ( stream string -- string )
+    over cr>> [
+        over cr-
+        "\n" ?head [
+            over stream-read1 [ suffix ] when*
+        ] when
+    ] when nip ; inline
+
+: (read) ( n quot -- n string )
+    over 0 <string> [
+        [
+            >r call dup
+            [ swap r> set-nth-unsafe f ] [ r> 3drop t ] if
+        ] 2curry find-integer
+    ] keep ; inline
+
+: finish-read ( n string -- string/f )
+    {
+        { [ over 0 = ] [ 2drop f ] }
+        { [ over not ] [ nip ] }
+        [ swap head ]
+    } cond ; inline
+
+M: decoder stream-read
+    tuck >decoder< [ decode-char ] 2curry (read) finish-read fix-read ;
+
+M: decoder stream-read-partial stream-read ;
 
 : line-ends/eof ( stream str -- str ) f like swap cr- ; inline
 
 : line-ends\r ( stream str -- str ) swap cr+ ; inline
 
 : line-ends\n ( stream str -- str )
-    over decoder-cr over empty? and
+    over cr>> over empty? and
     [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline
 
 : handle-readln ( stream str ch -- str )
@@ -52,61 +91,30 @@ M: object <decoder> f decoder boa ;
         { f [ line-ends/eof ] }
         { CHAR: \r [ line-ends\r ] }
         { CHAR: \n [ line-ends\n ] }
-    } case ;
+    } case ; inline
 
-: fix-read ( stream string -- string )
+: ((read-until)) ( buf quot -- string/f sep/f )
-    over decoder-cr [
-        over cr-
-        "\n" ?head [
-            over stream-read1 [ suffix ] when*
-        ] when
-    ] when nip ;
-
-: read-loop ( n stream -- string )
-    SBUF" " clone [
-        [
-            >r nip stream-read1 dup
-            [ r> push f ] [ r> 2drop t ] if
-        ] 2curry find-integer drop
-    ] keep "" like f like ;
-
-M: decoder stream-read
-    tuck read-loop fix-read ;
-
-M: decoder stream-read-partial stream-read ;
-
-: (read-until) ( buf quot -- string/f sep/f )
     ! quot: -- char stop?
     dup call
     [ >r drop "" like r> ]
-    [ pick push (read-until) ] if ; inline
+    [ pick push ((read-until)) ] if ; inline
 
-M: decoder stream-read-until
+: (read-until) ( seps stream -- string/f sep/f )
     SBUF" " clone -rot >decoder<
-    [ decode-char [ dup rot memq? ] [ drop f t ] if* ] 3curry
+    [ decode-char dup [ dup rot member? ] [ 2drop f t ] if ] 3curry
-    (read-until) ;
+    ((read-until)) ; inline
 
-: fix-read1 ( stream char -- char )
+M: decoder stream-read-until (read-until) ;
-    over decoder-cr [
-        over cr-
-        dup CHAR: \n = [
-            drop dup stream-read1
-        ] when
-    ] when nip ;
 
-M: decoder stream-read1
+M: decoder stream-readln "\r\n" over (read-until) handle-readln ;
-    dup >decoder< decode-char fix-read1 ;
 
-M: decoder stream-readln ( stream -- str )
+M: decoder dispose stream>> dispose ;
-    "\r\n" over stream-read-until handle-readln ;
-
-M: decoder dispose decoder-stream dispose ;
 
 ! Encoding
 M: object <encoder> encoder boa ;
 
 : >encoder< ( encoder -- stream encoding )
-    [ stream>> ] [ code>> ] bi ;
+    [ stream>> ] [ code>> ] bi ; inline
 
 M: encoder stream-write1
     >encoder< encode-char ;

core/optimizer/known-words/known-words.factor

@@ -2,14 +2,14 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: optimizer.known-words
 USING: alien arrays generic hashtables inference.dataflow
-inference.class kernel assocs math math.private kernel.private
+inference.class kernel assocs math math.order math.private
-sequences words parser vectors strings sbufs io namespaces
+kernel.private sequences words parser vectors strings sbufs io
-assocs quotations sequences.private io.binary
+namespaces assocs quotations sequences.private io.binary
 io.streams.string layouts splitting math.intervals
 math.floats.private classes.tuple classes.tuple.private classes
 classes.algebra optimizer.def-use optimizer.backend
 optimizer.pattern-match optimizer.inlining float-arrays
-sequences.private combinators ;
+sequences.private combinators byte-arrays byte-vectors ;
 
 { <tuple> <tuple-boa> } [
     [
@@ -59,15 +59,59 @@ sequences.private combinators ;
     node-in-d peek dup value?
     [ value-literal sequence? ] [ drop f ] if ;
 
-: member-quot ( seq -- newquot )
+: expand-member ( #call quot -- )
-    [ literalize [ t ] ] { } map>assoc
+    >r dup node-in-d peek value-literal r> call f splice-quot ;
-    [ drop f ] suffix [ nip case ] curry ;
 
-: expand-member ( #call -- )
+: bit-member-n 256 ; inline
-    dup node-in-d peek value-literal member-quot f splice-quot ;
+
+: bit-member? ( seq -- ? )
+    #! Can we use a fast byte array test here?
+    {
+        { [ dup length 8 < ] [ f ] }
+        { [ dup [ integer? not ] contains? ] [ f ] }
+        { [ dup [ 0 < ] contains? ] [ f ] }
+        { [ dup [ bit-member-n >= ] contains? ] [ f ] }
+        [ t ]
+    } cond nip ;
+
+: bit-member-seq ( seq -- flags )
+    bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ;
+
+: exact-float? ( f -- ? )
+    dup float? [ dup >integer >float = ] [ drop f ] if ; inline
+
+: bit-member-quot ( seq -- newquot )
+    [
+        [ drop ] % ! drop the sequence itself; we don't use it at run time
+        bit-member-seq ,
+        [
+            {
+                { [ over fixnum? ] [ ?nth 1 eq? ] }
+                { [ over bignum? ] [ ?nth 1 eq? ] }
+                { [ over exact-float? ] [ ?nth 1 eq? ] }
+                [ 2drop f ]
+            } cond
+        ] %
+    ] [ ] make ;
+
+: member-quot ( seq -- newquot )
+    dup bit-member? [
+        bit-member-quot
+    ] [
+        [ literalize [ t ] ] { } map>assoc
+        [ drop f ] suffix [ nip case ] curry
+    ] if ;
 
 \ member? {
-    { [ dup literal-member? ] [ expand-member ] }
+    { [ dup literal-member? ] [ [ member-quot ] expand-member ] }
+} define-optimizers
+
+: memq-quot ( seq -- newquot )
+    [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
+    [ drop f ] suffix [ nip cond ] curry ;
+
+\ memq? {
+    { [ dup literal-member? ] [ [ memq-quot ] expand-member ] }
 } define-optimizers
 
 ! if the result of eq? is t and the second input is a literal,
@@ -97,7 +141,7 @@ sequences.private combinators ;
 ] each
 
 \ push-all
-{ { string sbuf } { array vector } }
+{ { string sbuf } { array vector } { byte-array byte-vector } }
 "specializer" set-word-prop
 
 \ append

extra/assocs/lib/lib-tests.factor

@@ -0,0 +1,4 @@
+IN: assocs.lib.tests
+USING: assocs.lib tools.test vectors ;
+
+{ 1 1 } [ [ ?push ] histogram ] must-infer-as

extra/assocs/lib/lib.factor

@@ -41,4 +41,4 @@ IN: assocs.lib
 : histogram ( assoc quot -- assoc' )
     H{ } clone [
         swap [ change-at ] 2curry assoc-each
-    ] keep ;
+    ] keep ; inline

extra/concurrency/distributed/distributed-tests.factor

@@ -1,9 +1,9 @@
 IN: concurrency.distributed.tests
 USING: tools.test concurrency.distributed kernel io.files
 arrays io.sockets system combinators threads math sequences
-concurrency.messaging continuations ;
+concurrency.messaging continuations accessors prettyprint ;
 
-: test-node
+: test-node ( -- addrspec )
     {
         { [ os unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
         { [ os windows? ] [ "127.0.0.1" 1238 <inet4> ] }
@@ -11,9 +11,9 @@ concurrency.messaging continuations ;
 
 [ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test
 
-[ ] [ test-node dup 1array swap (start-node) ] unit-test
+[ ] [ test-node dup (start-node) ] unit-test
 
-[ ] [ 100 sleep ] unit-test
+[ ] [ 1000 sleep ] unit-test
 
 [ ] [
     [
@@ -30,4 +30,6 @@ concurrency.messaging continuations ;
     receive
 ] unit-test
 
+[ ] [ 1000 sleep ] unit-test
+
 [ ] [ test-node stop-node ] unit-test

extra/concurrency/distributed/distributed.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005 Chris Double. All Rights Reserved.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: serialize sequences concurrency.messaging threads io
-io.server qualified arrays namespaces kernel io.encodings.binary
+io.servers.connection io.encodings.binary
-accessors ;
+qualified arrays namespaces kernel accessors ;
 FROM: io.sockets => host-name <inet> with-client ;
 IN: concurrency.distributed
 
@@ -10,21 +10,21 @@ SYMBOL: local-node
 
 : handle-node-client ( -- )
     deserialize
-    [ first2 get-process send ]
+    [ first2 get-process send ] [ stop-server ] if* ;
-    [ stop-server ] if* ;
 
-: (start-node) ( addrspecs addrspec -- )
+: (start-node) ( addrspec addrspec -- )
     local-node set-global
     [
-        "concurrency.distributed"
+        <threaded-server>
-        binary
+            swap >>insecure
-        [ handle-node-client ] with-server
+            binary >>encoding
+            "concurrency.distributed" >>name
+            [ handle-node-client ] >>handler
+        start-server
     ] curry "Distributed concurrency server" spawn drop ;
 
 : start-node ( port -- )
-    [ internet-server ]
+    host-name over <inet> (start-node) ;
-    [ host-name swap <inet> ] bi
-    (start-node) ;
 
 TUPLE: remote-process id node ;
 

extra/eval-server/eval-server.factor

@@ -1,11 +0,0 @@
-! Copyright (C) 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: listener io.server strings parser byte-arrays ;
-IN: eval-server
-
-: eval-server ( -- )
-    9998 local-server "eval-server" [
-        >string eval>string >byte-array
-    ] with-datagrams ;
-
-MAIN: eval-server

extra/eval-server/summary.txt

@@ -1 +0,0 @@
-Listens for UDP packets on localhost:9998, evaluates them and sends back result

extra/eval-server/tags.txt

@@ -1,4 +0,0 @@
-demos
-network
-tools
-applications

extra/ftp/server/server.factor

@@ -2,9 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators io io.encodings.8-bit
 io.encodings io.encodings.binary io.encodings.utf8 io.files
-io.server io.sockets kernel math.parser namespaces sequences
+io.sockets kernel math.parser namespaces sequences
 ftp io.unix.launcher.parser unicode.case splitting assocs
-classes io.server destructors calendar io.timeouts
+classes io.servers.connection destructors calendar io.timeouts
 io.streams.duplex threads continuations math
 concurrency.promises byte-arrays ;
 IN: ftp.server
@@ -305,7 +305,10 @@ ERROR: not-a-directory ;
         [ drop unrecognized-command t ]
     } case [ handle-client-loop ] when ;
 
-: handle-client ( -- )
+TUPLE: ftp-server < threaded-server ;
+
+M: ftp-server handle-client* ( server -- )
+    drop
     [
         "" [
             host-name <ftp-client> client set
@@ -313,9 +316,14 @@ ERROR: not-a-directory ;
         ] with-directory
     ] with-destructors ;
 
+: <ftp-server> ( port -- server )
+    ftp-server new-threaded-server
+        swap >>insecure
+        "ftp.server" >>name
+        latin1 >>encoding ;
+
 : ftpd ( port -- )
-    internet-server "ftp.server"
+    <ftp-server> start-server ;
-    latin1 [ handle-client ] with-server ;
 
 : ftpd-main ( -- ) 2100 ftpd ;
 

extra/furnace/asides/asides.factor

@@ -4,7 +4,7 @@ USING: accessors namespaces sequences arrays kernel
 assocs assocs.lib hashtables math.parser urls combinators
 html.elements html.templates.chloe.syntax db.types db.tuples
 http http.server http.server.filters 
-furnace furnace.cache furnace.sessions ;
+furnace furnace.cache furnace.sessions furnace.redirection ;
 IN: furnace.asides
 
 TUPLE: aside < server-state session method url post-data ;

extra/furnace/auth/auth.factor

@@ -1,7 +1,7 @@
 ! Copyright (c) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs namespaces kernel sequences sets
-destructors combinators
+destructors combinators fry
 io.encodings.utf8 io.encodings.string io.binary random
 checksums checksums.sha2
 html.forms
@@ -10,6 +10,7 @@ http.server.filters
 http.server.dispatchers
 furnace
 furnace.actions
+furnace.redirection
 furnace.boilerplate
 furnace.auth.providers
 furnace.auth.providers.db ;
@@ -54,7 +55,7 @@ V{ } clone capabilities set-global
 
 : define-capability ( word -- ) capabilities get adjoin ;
 
-TUPLE: realm < dispatcher name users checksum ;
+TUPLE: realm < dispatcher name users checksum secure ;
 
 GENERIC: login-required* ( realm -- response )
 
@@ -67,7 +68,8 @@ GENERIC: logged-in-username ( realm -- username )
         swap >>name
         swap >>default
         users-in-db >>users
-        sha-256 >>checksum ; inline
+        sha-256 >>checksum
+        t >>secure ; inline
 
 : users ( -- provider )
     realm get users>> ;
@@ -104,6 +106,16 @@ M: realm call-responder* ( path responder -- response )
 : check-login ( password username -- user/f )
     users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;
 
+: if-secure-realm ( quot -- )
+    realm get secure>> [ if-secure ] [ call ] if ; inline
+
+TUPLE: secure-realm-only < filter-responder ;
+
+C: <secure-realm-only> secure-realm-only
+
+M: secure-realm-only call-responder*
+    '[ , , call-next-method ] if-secure-realm ;
+
 TUPLE: protected < filter-responder description capabilities ;
 
 : <protected> ( responder -- protected )
@@ -118,9 +130,12 @@ TUPLE: protected < filter-responder description capabilities ;
     } cond ;
 
 M: protected call-responder* ( path responder -- response )
+    '[
+        , ,
         dup protected set
         dup logged-in-user get check-capabilities
-    [ call-next-method ] [ 2drop realm get login-required* ] if ;
+        [ call-next-method ] [ 2drop realm get login-required* ] if
+    ] if-secure-realm ;
 
 : <auth-boilerplate> ( responder -- responder' )
     <boilerplate> { realm "boilerplate" } >>template ;

extra/furnace/auth/features/deactivate-user/deactivate-user.factor

@@ -0,0 +1,24 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel assocs namespaces accessors db db.tuples urls
+http.server.dispatchers
+furnace.asides furnace.actions furnace.auth furnace.auth.providers ;
+IN: furnace.auth.features.deactivate-user
+
+: <deactivate-user-action> ( -- action )
+    <action>
+        [
+            logged-in-user get
+                1 >>deleted
+                t >>changed?
+            drop
+            URL" $realm" end-aside
+        ] >>submit ;
+    
+: allow-deactivation ( realm -- realm )
+    <deactivate-user-action> <protected>
+        "delete your profile" >>description
+    "deactivate-user" add-responder ;
+
+: allow-deactivation? ( -- ? )
+    realm get responders>> "deactivate-user" swap key? ;

extra/furnace/auth/features/edit-profile/edit-profile.xml

@@ -67,4 +67,7 @@
 
 	</t:form>
 	
+	<t:if t:code="furnace.auth.features.deactivate-user:allow-deactivation?">
+		<t:button t:action="$realm/deactivate-user">Delete User</t:button>
+	</t:if>
 </t:chloe>

extra/furnace/auth/features/recover-password/recover-1.xml

@@ -6,7 +6,7 @@
 
 	<p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
 
-	<t:form t:action="recover-password">
+	<t:form t:action="$realm/recover-password">
 
 		<table>
 

extra/furnace/auth/features/recover-password/recover-3.xml

@@ -6,7 +6,7 @@
 
 	<p>Choose a new password for your account.</p>
 
-	<t:form t:action="new-password">
+	<t:form t:action="$realm/recover-3">
 
 		<table>
 

extra/furnace/auth/features/recover-password/recover-4.xml

@@ -4,6 +4,6 @@
 
 	<t:title>Recover lost password: step 4 of 4</t:title>
 
-	<p>Your password has been reset. You may now <t:a t:href="login">log in</t:a>.</p>
+	<p>Your password has been reset. You may now <t:a t:href="$realm">proceed</t:a>.</p>
 
 </t:chloe>

extra/furnace/auth/features/recover-password/recover-password.factor

@@ -1,9 +1,11 @@
 ! Copyright (c) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces accessors kernel assocs arrays io.sockets threads
-fry urls smtp validators html.forms
+fry urls smtp validators html.forms present
-http http.server.responses http.server.dispatchers
+http http.server.responses http.server.redirection
-furnace furnace.actions furnace.auth furnace.auth.providers ;
+http.server.dispatchers
+furnace furnace.actions furnace.auth furnace.auth.providers
+furnace.redirection ;
 IN: furnace.auth.features.recover-password
 
 SYMBOL: lost-password-from
@@ -12,13 +14,12 @@ SYMBOL: lost-password-from
     request get url>> host>> host-name or ;
 
 : new-password-url ( user -- url )
-    "recover-3"
+    URL" recover-3" clone
-    swap [
+        swap
-        [ username>> "username" set ]
+        [ username>> "username" set-query-param ]
-        [ ticket>> "ticket" set ]
+        [ ticket>> "ticket" set-query-param ]
         bi
-    ] H{ } make-assoc
+    adjust-url relative-to-request ;
-    derive-url ;
 
 : password-email ( user -- email )
     <email>
@@ -34,7 +35,7 @@ SYMBOL: lost-password-from
             "If you believe that this request was legitimate, you may click the below link in\n" %
             "your browser to set a new password for your account:\n" %
             "\n" %
-            swap new-password-url %
+            swap new-password-url present %
             "\n\n" %
             "Love,\n" %
             "\n" %
@@ -47,7 +48,7 @@ SYMBOL: lost-password-from
 
 : <recover-action-1> ( -- action )
     <page-action>
-        { realm "recover-1" } >>template
+        { realm "features/recover-password/recover-1" } >>template
 
         [
             {
@@ -63,12 +64,12 @@ SYMBOL: lost-password-from
                 send-password-email
             ] when*
 
-            URL" $login/recover-2" <redirect>
+            URL" $realm/recover-2" <redirect>
         ] >>submit ;
 
 : <recover-action-2> ( -- action )
     <page-action>
-        { realm "recover-2" } >>template ;
+        { realm "features/recover-password/recover-2" } >>template ;
 
 : <recover-action-3> ( -- action )
     <page-action>
@@ -79,7 +80,7 @@ SYMBOL: lost-password-from
             } validate-params
         ] >>init
 
-        { realm "recover-3" } >>template
+        { realm "features/recover-password/recover-3" } >>template
 
         [
             {
@@ -99,7 +100,7 @@ SYMBOL: lost-password-from
                 "new-password" value >>encoded-password
                 users update-user
 
-                URL" $login/recover-4" <redirect>
+                URL" $realm/recover-4" <redirect>
             ] [
                 <403>
             ] if*
@@ -107,7 +108,7 @@ SYMBOL: lost-password-from
 
 : <recover-action-4> ( -- action )
     <page-action>
-        { realm "recover-4" } >>template ;
+        { realm "features/recover-password/recover-4" } >>template ;
 
 : allow-password-recovery ( login -- login )
     <recover-action-1> <auth-boilerplate>

extra/furnace/auth/features/registration/registration.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs kernel namespaces validators html.forms urls
 http.server.dispatchers
-furnace furnace.auth furnace.auth.providers furnace.actions ;
+furnace furnace.auth furnace.auth.providers furnace.actions
+furnace.redirection ;
 IN: furnace.auth.features.registration
 
 : <register-action> ( -- action )
@@ -34,10 +35,11 @@ IN: furnace.auth.features.registration
             realm get init-user-profile
 
             URL" $realm" <redirect>
-        ] >>submit ;
+        ] >>submit
+    <auth-boilerplate> ;
 
 : allow-registration ( login -- login )
-    <register-action> <auth-boilerplate> "register" add-responder ;
+    <register-action> "register" add-responder ;
 
 : allow-registration? ( -- ? )
     realm get responders>> "register" swap key? ;

extra/furnace/auth/login/login.factor

@@ -10,6 +10,7 @@ furnace.asides
 furnace.actions
 furnace.sessions
 furnace.utilities
+furnace.redirection
 furnace.auth.login.permits ;
 IN: furnace.auth.login
 
@@ -38,8 +39,11 @@ M: login-realm modify-form ( responder -- )
 : <permit-cookie> ( -- cookie )
     permit-id get realm get name>> permit-id-key <cookie>
         "$login-realm" resolve-base-path >>path
-        realm get timeout>> from-now >>expires
+        realm get
-        realm get domain>> >>domain ;
+        [ timeout>> from-now >>expires ]
+        [ domain>> >>domain ]
+        [ secure>> >>secure ]
+        tri ;
 
 : put-permit-cookie ( response -- response' )
     <permit-cookie> put-cookie ;
@@ -81,7 +85,9 @@ SYMBOL: capabilities
             "password" value
             "username" value check-login
             [ successful-login ] [ login-failed ] if*
-        ] >>submit ;
+        ] >>submit
+    <auth-boilerplate>
+    <secure-realm-only> ;
 
 : <logout-action> ( -- action )
     <action>
@@ -94,10 +100,10 @@ M: login-realm login-required*
     begin-aside
     protected get description>> description set
     protected get capabilities>> capabilities set
-    URL" $realm/login" flashed-variables <flash-redirect> ;
+    URL" $realm/login" >secure-url flashed-variables <flash-redirect> ;
 
 : <login-realm> ( responder name -- auth )
     login-realm new-realm
-        <login-action> <auth-boilerplate> "login" add-responder
+        <login-action> "login" add-responder
         <logout-action> "logout" add-responder
         20 minutes >>timeout ;

extra/furnace/boilerplate/boilerplate.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces
+USING: accessors kernel math.order namespaces combinators.lib
 html.forms
 html.templates
 html.templates.chloe
@@ -17,6 +17,12 @@ TUPLE: boilerplate < filter-responder template init ;
         swap >>responder
         [ ] >>init ;
 
+: wrap-boilerplate? ( response -- ? )
+    {
+        [ code>> { [ 200 = ] [ 400 499 between? ] } 1|| ]
+        [ content-type>> "text/html" = ]
+    } 1&& ;
+
 M:: boilerplate call-responder* ( path responder -- )
     begin-form
     path responder call-next-method

extra/furnace/flash/flash.factor

@@ -3,7 +3,7 @@
 USING: namespaces assocs assocs.lib kernel sequences accessors
 urls db.types db.tuples math.parser fry
 http http.server http.server.filters http.server.redirection
-furnace furnace.cache furnace.sessions ;
+furnace furnace.cache furnace.sessions furnace.redirection ;
 IN: furnace.flash
 
 TUPLE: flash-scope < server-state session namespace ;

extra/furnace/furnace.factor

@@ -63,13 +63,6 @@ M: url adjust-url
 
 M: string adjust-url ;
 
-: <redirect> ( url -- response )
-    adjust-url request get method>> {
-        { "GET" [ <temporary-redirect> ] }
-        { "HEAD" [ <temporary-redirect> ] }
-        { "POST" [ <permanent-redirect> ] }
-    } case ;
-
 GENERIC: modify-form ( responder -- )
 
 M: object modify-form drop ;

extra/furnace/redirection/redirection.factor

@@ -0,0 +1,41 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors combinators namespaces fry
+io.servers.connection
+http http.server http.server.redirection http.server.filters
+furnace ;
+IN: furnace.redirection
+
+: <redirect> ( url -- response )
+    adjust-url request get method>> {
+        { "GET" [ <temporary-redirect> ] }
+        { "HEAD" [ <temporary-redirect> ] }
+        { "POST" [ <permanent-redirect> ] }
+    } case ;
+
+: >secure-url ( url -- url' )
+    clone
+        "https" >>protocol
+        secure-port >>port ;
+
+: <secure-redirect> ( url -- response )
+    >secure-url <redirect> ;
+
+TUPLE: redirect-responder to ;
+
+: <redirect-responder> ( url -- responder )
+    redirect-responder boa ;
+
+M: redirect-responder call-responder* nip to>> <redirect> ;
+
+TUPLE: secure-only < filter-responder ;
+
+C: <secure-only> secure-only
+
+: if-secure ( quot -- )
+    >r request get url>> protocol>> "http" =
+    [ request get url>> <secure-redirect> ]
+    r> if ; inline
+
+M: secure-only call-responder*
+    '[ , , call-next-method ] if-secure ;

extra/furnace/sessions/sessions-tests.factor

@@ -1,7 +1,7 @@
 IN: furnace.sessions.tests
 USING: tools.test http furnace.sessions
 furnace.actions http.server http.server.responses
-math namespaces kernel accessors io.sockets io.server
+math namespaces kernel accessors io.sockets io.servers.connection
 prettyprint io.streams.string io.files splitting destructors
 sequences db db.tuples db.sqlite continuations urls math.parser
 furnace ;

extra/furnace/sessions/sessions.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2008 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs kernel math.intervals math.parser namespaces
-random accessors quotations hashtables sequences continuations
+strings random accessors quotations hashtables sequences continuations
-fry calendar combinators combinators.lib destructors alarms io.server
+fry calendar combinators combinators.lib destructors alarms
+io.servers.connection
 db db.tuples db.types
 http http.server http.server.dispatchers http.server.filters
 html.elements
@@ -109,7 +110,7 @@ M: session-saver dispose
 
 : request-session ( -- session/f )
     session-id-key
-    client-state dup [ string>number ] when
+    client-state dup string? [ string>number ] when
     get-session verify-session ;
 
 : <session-cookie> ( -- cookie )

extra/html/elements/elements.factor

@@ -5,7 +5,7 @@
 
 USING: io kernel namespaces prettyprint quotations
 sequences strings words xml.entities compiler.units effects
-urls math math.parser combinators present ;
+urls math math.parser combinators present fry ;
 
 IN: html.elements
 
@@ -70,7 +70,7 @@ SYMBOL: html
 : def-for-html-word-<foo> ( name -- )
     #! Return the name and code for the <foo> patterned
     #! word.
-    dup <foo> swap [ <foo> write-html ] curry
+    dup <foo> swap '[ , <foo> write-html ]
     (( -- )) html-word ;
 
 : <foo ( str -- <str ) "<" prepend ;
@@ -78,7 +78,7 @@ SYMBOL: html
 : def-for-html-word-<foo ( name -- )
     #! Return the name and code for the <foo patterned
     #! word.
-    <foo dup [ write-html ] curry
+    <foo dup '[ , write-html ]
     (( -- )) html-word ;
 
 : foo> ( str -- foo> ) ">" append ;
@@ -93,14 +93,14 @@ SYMBOL: html
 : def-for-html-word-</foo> ( name -- )
     #! Return the name and code for the </foo> patterned
     #! word.
-    </foo> dup [ write-html ] curry (( -- )) html-word ;
+    </foo> dup '[ , write-html ] (( -- )) html-word ;
 
 : <foo/> ( str -- <str/> ) "<" swap "/>" 3append ;
 
 : def-for-html-word-<foo/> ( name -- )
     #! Return the name and code for the <foo/> patterned
     #! word.
-    dup <foo/> swap [ <foo/> write-html ] curry
+    dup <foo/> swap '[ , <foo/> write-html ]
     (( -- )) html-word ;
 
 : foo/> ( str -- str/> ) "/>" append ;
@@ -134,7 +134,7 @@ SYMBOL: html
 
 : define-attribute-word ( name -- )
     dup "=" prepend swap
-    [ write-attr ] curry (( string -- )) html-word ;
+    '[ , write-attr ] (( string -- )) html-word ;
 
 ! Define some closed HTML tags
 [

extra/html/templates/chloe/chloe.factor

@@ -87,11 +87,10 @@ CHLOE: comment drop ;
 CHLOE: call-next-template drop call-next-template ;
 
 : attr>word ( value -- word/f )
-    dup ":" split1 swap lookup
+    ":" split1 swap lookup ;
-    [ ] [ "No such word: " swap append throw ] ?if ;
 
 : if-satisfied? ( tag -- ? )
-    [ "code" optional-attr [ attr>word execute ] [ t ] if* ]
+    [ "code" optional-attr [ attr>word dup [ execute ] when ] [ t ] if* ]
     [ "value" optional-attr [ value ] [ t ] if* ]
     bi and ;
 

extra/http/client/client.factor

@@ -79,13 +79,9 @@ ERROR: download-failed response body ;
 
 M: download-failed error.
     "HTTP download failed:" print nl
-    [
+    [ response>> write-response-line nl drop ]
-        response>>
+    [ body>> write ]
-            write-response-code
+    bi ;
-            write-response-message nl
-        drop
-    ]
-    [ body>> write ] bi ;
 
 : check-response ( response data -- response data )
     over code>> success? [ download-failed ] unless ;

extra/http/http-tests.factor

@@ -1,7 +1,8 @@
 USING: http tools.test multiline tuple-syntax
 io.streams.string io.encodings.utf8 io.encodings.string
 kernel arrays splitting sequences
-assocs io.sockets db db.sqlite continuations urls hashtables ;
+assocs io.sockets db db.sqlite continuations urls hashtables
+accessors ;
 IN: http.tests
 
 : lf>crlf "\n" split "\r\n" join ;
@@ -73,10 +74,21 @@ GET nested HTTP/1.0
 
 ;
 
-[ read-request-test-3 [ read-request ] with-string-reader ]
+[ read-request-test-3 lf>crlf [ read-request ] with-string-reader ]
 [ "Bad request: URL" = ]
 must-fail-with
 
+STRING: read-request-test-4
+GET /blah HTTP/1.0
+Host: "www.amazon.com"
+;
+
+[ "www.amazon.com" ]
+[
+    read-request-test-4 lf>crlf [ read-request ] with-string-reader
+    "host" header
+] unit-test
+
 STRING: read-response-test-1
 HTTP/1.1 404 not found
 Content-Type: text/html; charset=UTF-8
@@ -117,15 +129,46 @@ read-response-test-1' 1array [
 
 [ t ] [
     "rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT"
-    dup parse-cookies unparse-cookies =
+    dup parse-set-cookie first unparse-set-cookie =
+] unit-test
+
+[ t ] [
+    "a="
+    dup parse-set-cookie first unparse-set-cookie =
+] unit-test
+
+STRING: read-response-test-2
+HTTP/1.1 200 Content follows
+Set-Cookie: oo="bar; a=b"; httponly=yes; sid=123456
+
+
+;
+
+[ 2 ] [
+    read-response-test-2 lf>crlf
+    [ read-response ] with-string-reader
+    cookies>> length
+] unit-test
+
+STRING: read-response-test-3
+HTTP/1.1 200 Content follows
+Set-Cookie: oo="bar; a=b"; comment="your mom"; httponly=yes
+
+
+;
+
+[ 1 ] [
+    read-response-test-3 lf>crlf
+    [ read-response ] with-string-reader
+    cookies>> length
 ] unit-test
 
 ! Live-fire exercise
 USING: http.server http.server.static furnace.sessions furnace.alloy
 furnace.actions furnace.auth furnace.auth.login furnace.db http.client
-io.server io.files io io.encodings.ascii
+io.servers.connection io.files io io.encodings.ascii
 accessors namespaces threads
-http.server.responses http.server.redirection
+http.server.responses http.server.redirection furnace.redirection
 http.server.dispatchers db.tuples ;
 
 : add-quit-action

extra/http/http.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel combinators math namespaces
-
+assocs assocs.lib sequences splitting sorting sets debugger
-assocs sequences splitting sorting sets debugger
 strings vectors hashtables quotations arrays byte-arrays
 math.parser calendar calendar.format present
 
@@ -11,7 +10,9 @@ io.encodings.8-bit
 
 unicode.case unicode.categories qualified
 
-urls html.templates xml xml.data xml.writer ;
+urls html.templates xml xml.data xml.writer
+
+http.parsers ;
 
 EXCLUDE: fry => , ;
 
@@ -19,40 +20,20 @@ IN: http
 
 : 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 [
-            [ blank? ] left-trim
-            swap >lower dup "last-header" set
-            "header" get add-header
-        ] [
-            2drop
-        ] if
-    ] if ;
-
-: read-lf ( -- bytes )
-    "\n" read-until CHAR: \n assert= ;
-
 : read-crlf ( -- bytes )
     "\r" read-until
     [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
 
-: (read-header) ( -- )
+: (read-header) ( -- alist )
-    read-crlf dup
+    [ read-crlf dup f like ] [ parse-header-line ] [ drop ] unfold ;
-    empty? [ drop ] [ header-line (read-header) ] if ;
+
+: process-header ( alist -- assoc )
+    f swap [ [ swap or dup ] dip swap ] assoc-map nip
+    [ ?push ] histogram [ "; " join ] assoc-map
+    >hashtable ;
 
 : read-header ( -- assoc )
-    H{ } clone [
+    (read-header) process-header ;
-        "header" [ (read-header) ] with-variable
-    ] keep ;
 
 : header-value>string ( value -- string )
     {
@@ -63,47 +44,62 @@ IN: http
 
 : check-header-string ( str -- str )
     #! http://en.wikipedia.org/wiki/HTTP_Header_Injection
-    dup "\r\n" intersect empty?
+    dup "\r\n\"" intersect empty?
     [ "Header injection attack" throw ] unless ;
 
 : write-header ( assoc -- )
     >alist sort-keys [
-        swap
+        [ check-header-string write ": " write ]
-        check-header-string write ": " write
+        [ header-value>string check-header-string write crlf ] bi*
-        header-value>string check-header-string write crlf
     ] assoc-each crlf ;
 
-TUPLE: cookie name value path domain expires max-age http-only ;
+TUPLE: cookie name value version comment path domain expires max-age http-only secure ;
 
 : <cookie> ( value name -- cookie )
     cookie new
         swap >>name
         swap >>value ;
 
-: parse-cookies ( string -- seq )
+: parse-set-cookie ( string -- seq )
     [
         f swap
-
+        (parse-set-cookie)
-        ";" split [
+        [
-            [ blank? ] trim "=" split1 swap >lower {
+            swap {
+                { "version" [ >>version ] }
+                { "comment" [ >>comment ] }
                 { "expires" [ cookie-string>timestamp >>expires ] }
                 { "max-age" [ string>number seconds >>max-age ] }
                 { "domain" [ >>domain ] }
                 { "path" [ >>path ] }
                 { "httponly" [ drop t >>http-only ] }
-                { "" [ drop ] }
+                { "secure" [ drop t >>secure ] }
                 [ <cookie> dup , nip ]
             } case
-        ] each
+        ] assoc-each
+        drop
+    ] { } make ;
 
+: parse-cookie ( string -- seq )
+    [
+        f swap
+        (parse-cookie)
+        [
+            swap {
+                { "$version" [ >>version ] }
+                { "$domain" [ >>domain ] }
+                { "$path" [ >>path ] }
+                [ <cookie> dup , nip ]
+            } case
+        ] assoc-each
         drop
     ] { } make ;
 
 : check-cookie-string ( string -- string' )
-    dup "=;'\"" intersect empty?
+    dup "=;'\"\r\n" intersect empty?
     [ "Bad cookie name or value" throw ] unless ;
 
-: (unparse-cookie) ( key value -- )
+: unparse-cookie-value ( key value -- )
     {
         { f [ drop ] }
         { t [ check-cookie-string , ] }
@@ -118,20 +114,30 @@ TUPLE: cookie name value path domain expires max-age http-only ;
         ]
     } case ;
 
-: unparse-cookie ( cookie -- strings )
+: (unparse-cookie) ( cookie -- strings )
     [
         dup name>> check-cookie-string >lower
-        over value>> (unparse-cookie)
+        over value>> unparse-cookie-value
-        "path" over path>> (unparse-cookie)
+        "$path" over path>> unparse-cookie-value
-        "domain" over domain>> (unparse-cookie)
+        "$domain" over domain>> unparse-cookie-value
-        "expires" over expires>> (unparse-cookie)
-        "max-age" over max-age>> (unparse-cookie)
-        "httponly" over http-only>> (unparse-cookie)
         drop
     ] { } make ;
 
-: unparse-cookies ( cookies -- string )
+: unparse-cookie ( cookies -- string )
-    [ unparse-cookie ] map concat "; " join ;
+    [ (unparse-cookie) ] map concat "; " join ;
+
+: unparse-set-cookie ( cookie -- string )
+    [
+        dup name>> check-cookie-string >lower
+        over value>> unparse-cookie-value
+        "path" over path>> unparse-cookie-value
+        "domain" over domain>> unparse-cookie-value
+        "expires" over expires>> unparse-cookie-value
+        "max-age" over max-age>> unparse-cookie-value
+        "httponly" over http-only>> unparse-cookie-value
+        "secure" over secure>> unparse-cookie-value
+        drop
+    ] { } make "; " join ;
 
 TUPLE: request
 method
@@ -141,6 +147,13 @@ header
 post-data
 cookies ;
 
+: check-url ( string -- url )
+    >url dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
+
+: read-request-line ( request -- request )
+    read-crlf parse-request-line first3
+    [ >>method ] [ check-url >>url ] [ >>version ] tri* ;
+
 : set-header ( request/response value key -- request/response )
     pick header>> set-at ;
 
@@ -155,27 +168,9 @@ cookies ;
         "close" "connection" set-header
         "Factor http.client" "user-agent" set-header ;
 
-: read-method ( request -- request )
-    " " read-until [ "Bad request: method" throw ] unless
-    >>method ;
-
 : check-absolute ( url -- url )
     dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
 
-: read-url ( request -- request )
-    " " read-until [
-        dup empty? [ drop read-url ] [ >url check-absolute >>url ] if
-    ] [ "Bad request: URL" throw ] if ;
-
-: parse-version ( string -- version )
-    "HTTP/" ?head [ "Bad request: version" throw ] unless
-    dup { "1.0" "1.1" } member? [ "Bad request: version" throw ] unless ;
-
-: read-request-version ( request -- request )
-    read-crlf [ CHAR: \s = ] left-trim
-    parse-version
-    >>version ;
-
 : read-request-header ( request -- request )
     read-header >>header ;
 
@@ -210,7 +205,7 @@ TUPLE: post-data raw content content-type ;
     drop ;
 
 : extract-cookies ( request -- request )
-    dup "cookie" header [ parse-cookies >>cookies ] when* ;
+    dup "cookie" header [ parse-cookie >>cookies ] when* ;
 
 : parse-content-type-attributes ( string -- attributes )
     " " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
@@ -220,22 +215,18 @@ TUPLE: post-data raw content content-type ;
 
 : read-request ( -- request )
     <request>
-    read-method
+    read-request-line
-    read-url
-    read-request-version
     read-request-header
     read-post-data
     extract-host
     extract-cookies ;
 
-: write-method ( request -- request )
+: write-request-line ( request -- request )
-    dup method>> write bl ;
+    dup
-
+    [ method>> write bl ]
-: write-request-url ( request -- request )
+    [ url>> relative-url present write bl ]
-    dup url>> relative-url present write bl ;
+    [ "HTTP/" write version>> write crlf ]
-
+    tri ;
-: write-version ( request -- request )
-    "HTTP/" write dup request-version write crlf ;
 
 : url-host ( url -- string )
     [ host>> ] [ port>> ] bi dup "http" protocol-port =
@@ -249,7 +240,7 @@ TUPLE: post-data raw content content-type ;
         [ content-type>> "content-type" pick set-at ]
         bi
     ] when*
-    over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
+    over cookies>> f like [ unparse-cookie "cookie" pick set-at ] when*
     write-header ;
 
 GENERIC: >post-data ( object -- post-data )
@@ -274,9 +265,7 @@ M: f >post-data ;
 
 : write-request ( request -- )
     unparse-post-data
-    write-method
+    write-request-line
-    write-request-url
-    write-version
     write-request-header
     write-post-data
     flush
@@ -311,23 +300,13 @@ M: response clone
         [ clone ] change-header
         [ clone ] change-cookies ;
 
-: read-response-version ( response -- response )
+: read-response-line ( response -- response )
-    " \t" read-until
+    read-crlf parse-response-line first3
-    [ "Bad response: version" throw ] unless
+    [ >>version ] [ >>code ] [ >>message ] tri* ;
-    parse-version
-    >>version ;
-
-: read-response-code ( response -- response )
-    " \t" read-until [ "Bad response: code" throw ] unless
-    string>number [ "Bad response: code" throw ] unless*
-    >>code ;
-
-: read-response-message ( response -- response )
-    read-crlf >>message ;
 
 : read-response-header ( response -- response )
     read-header >>header
-    dup "set-cookie" header parse-cookies >>cookies
+    dup "set-cookie" header parse-set-cookie >>cookies
     dup "content-type" header [
         parse-content-type
         [ >>content-type ]
@@ -336,20 +315,15 @@ M: response clone
 
 : read-response ( -- response )
     <response>
-    read-response-version
+    read-response-line
-    read-response-code
-    read-response-message
     read-response-header ;
 
-: write-response-version ( response -- response )
+: write-response-line ( response -- response )
-    "HTTP/" write
+    dup
-    dup version>> write bl ;
+    [ "HTTP/" write version>> write bl ]
-
+    [ code>> present write bl ]
-: write-response-code ( response -- response )
+    [ message>> write crlf ]
-    dup code>> number>string write bl ;
+    tri ;
-
-: write-response-message ( response -- response )
-    dup message>> write crlf ;
 
 : unparse-content-type ( request -- content-type )
     [ content-type>> "application/octet-stream" or ]
@@ -357,19 +331,29 @@ M: response clone
     bi
     [ "; charset=" swap 3append ] when* ;
 
+: ensure-domain ( cookie -- cookie )
+    [
+        request get url>>
+        host>> dup "localhost" =
+        [ drop ] [ or ] if
+    ] change-domain ;
+
 : write-response-header ( response -- response )
-    dup header>> clone
+    #! We send one set-cookie header per cookie, because that's
-    over cookies>> f like [ unparse-cookies "set-cookie" pick set-at ] when*
+    #! what Firefox expects.
+    dup header>> >alist >vector
     over unparse-content-type "content-type" pick set-at
+    over cookies>> [
+        ensure-domain unparse-set-cookie
+        "set-cookie" swap 2array over push
+    ] each
     write-header ;
 
 : write-response-body ( response -- response )
     dup body>> call-template ;
 
 M: response write-response ( respose -- )
-    write-response-version
+    write-response-line
-    write-response-code
-    write-response-message
     write-response-header
     flush
     drop ;
@@ -403,9 +387,7 @@ body ;
         "1.1" >>version ;
 
 M: raw-response write-response ( respose -- )
-    write-response-version
+    write-response-line
-    write-response-code
-    write-response-message
     write-response-body
     drop ;
 

extra/http/parsers/parsers.factor

@@ -0,0 +1,166 @@
+USING: math math.order math.parser kernel combinators.lib
+sequences sequences.deep peg peg.parsers assocs arrays
+hashtables strings unicode.case namespaces ascii ;
+IN: http.parsers
+
+: except ( quot -- parser )
+    [ not ] compose satisfy ; inline
+
+: except-these ( quots -- parser )
+    [ 1|| ] curry except ; inline
+
+: ctl? ( ch -- ? )
+    { [ 0 31 between? ] [ 127 = ] } 1|| ;
+
+: tspecial? ( ch -- ? )
+    "()<>@,;:\\\"/[]?={} \t" member? ;
+
+: 'token' ( -- parser )
+    { [ ctl? ] [ tspecial? ] } except-these repeat1 ;
+
+: case-insensitive ( parser -- parser' )
+    [ flatten >string >lower ] action ;
+
+: case-sensitive ( parser -- parser' )
+    [ flatten >string ] action ;
+
+: 'space' ( -- parser )
+    [ " \t" member? ] satisfy repeat0 hide ;
+
+: one-of ( strings -- parser )
+    [ token ] map choice ;
+
+: 'http-method' ( -- parser )
+    { "OPTIONS" "GET" "HEAD" "POST" "PUT" "DELETE" "TRACE" "CONNECT" } one-of ;
+
+: 'url' ( -- parser )
+    [ " \t\r\n" member? ] except repeat1 case-sensitive ;
+
+: 'http-version' ( -- parser )
+    [
+        "HTTP" token hide ,
+        'space' ,
+        "/" token hide ,
+        'space' ,
+        "1" token ,
+        "." token ,
+        { "0" "1" } one-of ,
+    ] seq* [ concat >string ] action ;
+
+PEG: parse-request-line ( string -- triple )
+    #! Triple is { method url version }
+    [ 
+        'space' ,
+        'http-method' ,
+        'space' ,
+        'url' ,
+        'space' ,
+        'http-version' ,
+        'space' ,
+    ] seq* just ;
+
+: 'text' ( -- parser )
+    [ ctl? ] except ;
+
+: 'response-code' ( -- parser )
+    [ digit? ] satisfy 3 exactly-n [ string>number ] action ;
+
+: 'response-message' ( -- parser )
+    'text' repeat0 case-sensitive ;
+
+PEG: parse-response-line ( string -- triple )
+    #! Triple is { version code message }
+    [
+        'space' ,
+        'http-version' ,
+        'space' ,
+        'response-code' ,
+        'space' ,
+        'response-message' ,
+    ] seq* just ;
+
+: 'crlf' ( -- parser )
+    "\r\n" token ;
+
+: 'lws' ( -- parser )
+    [ " \t" member? ] satisfy repeat1 ;
+
+: 'qdtext' ( -- parser )
+    { [ CHAR: " = ] [ ctl? ] } except-these ;
+
+: 'quoted-char' ( -- parser )
+    "\\" token hide any-char 2seq ;
+
+: 'quoted-string' ( -- parser )
+    'quoted-char' 'qdtext' 2choice repeat0 "\"" "\"" surrounded-by ;
+
+: 'ctext' ( -- parser )
+    { [ ctl? ] [ "()" member? ] } except-these ;
+
+: 'comment' ( -- parser )
+    'ctext' 'comment' 2choice repeat0 "(" ")" surrounded-by ;
+
+: 'field-name' ( -- parser )
+    'token' case-insensitive ;
+
+: 'field-content' ( -- parser )
+    'quoted-string' case-sensitive
+    'text' repeat0 case-sensitive
+    2choice ;
+
+PEG: parse-header-line ( string -- pair )
+    #! Pair is either { name value } or { f value }. If f, its a
+    #! continuation of the previous header line.
+    [
+        'field-name' ,
+        'space' ,
+        ":" token hide ,
+        'space' ,
+        'field-content' ,
+    ] seq*
+    [
+        'lws' [ drop f ] action ,
+        'field-content' ,
+    ] seq*
+    2choice ;
+
+: 'word' ( -- parser )
+    'token' 'quoted-string' 2choice ;
+
+: 'value' ( -- parser )
+    'quoted-string'
+    [ ";" member? ] except repeat0
+    2choice case-sensitive ;
+
+: 'attr' ( -- parser )
+    'token' case-insensitive ;
+
+: 'av-pair' ( -- parser )
+    [
+        'space' ,
+        'attr' ,
+        'space' ,
+            [ "=" token , 'space' , 'value' , ] seq* [ peek ] action
+            epsilon [ drop f ] action
+        2choice ,
+        'space' ,
+    ] seq* ;
+
+: 'av-pairs' ( -- parser )
+    'av-pair' ";" token list-of optional ;
+
+PEG: (parse-set-cookie) ( string -- alist ) 'av-pairs' just ;
+
+: 'cookie-value' ( -- parser )
+    [
+        'space' ,
+        'attr' ,
+        'space' ,
+        "=" token hide ,
+        'space' ,
+        'value' ,
+        'space' ,
+    ] seq* ;
+
+PEG: (parse-cookie) ( string -- alist )
+    'cookie-value' [ ";," member? ] satisfy list-of optional just ;

extra/http/server/server.factor

@@ -4,7 +4,6 @@ USING: kernel accessors sequences arrays namespaces splitting
 vocabs.loader destructors assocs debugger continuations
 combinators tools.vocabs tools.time math
 io
-io.server
 io.sockets
 io.sockets.secure
 io.encodings
@@ -12,6 +11,7 @@ io.encodings.utf8
 io.encodings.ascii
 io.encodings.binary
 io.streams.limited
+io.servers.connection
 io.timeouts
 fry logging logging.insomniac calendar urls
 http
@@ -118,10 +118,6 @@ LOG: httpd-header NOTICE
 : ?refresh-all ( -- )
     development? get-global [ global [ refresh-all ] bind ] when ;
 
-: setup-limits ( -- )
-    1 minutes timeouts
-    64 1024 * limit-input ;
-
 LOG: httpd-benchmark DEBUG
 
 : ?benchmark ( quot -- )
@@ -130,25 +126,29 @@ LOG: httpd-benchmark DEBUG
         httpd-benchmark
     ] [ call ] if ; inline
 
-: handle-client ( -- )
+TUPLE: http-server < threaded-server ;
+
+M: http-server handle-client*
+    drop
     [
-        setup-limits
+        64 1024 * limit-input
-        ascii decode-input
-        ascii encode-output
         ?refresh-all
         read-request
         [ do-request ] ?benchmark
         [ do-response ] ?benchmark
     ] with-destructors ;
 
+: <http-server> ( -- server )
+    http-server new-threaded-server
+        "http.server" >>name
+        "http" protocol-port >>insecure
+        "https" protocol-port >>secure ;
+
 : httpd ( port -- )
-    dup integer? [ internet-server ] when
+    <http-server>
-    "http.server" binary [ handle-client ] with-server ;
+        swap >>insecure
+        f >>secure
+    start-server ;
 
-: httpd-main ( -- )
+: http-insomniac ( -- )
-    8888 httpd ;
+    "http.server" { "httpd-hit" } schedule-insomniac ;
-
-: httpd-insomniac ( -- )
-    "http.server" { httpd-hit } schedule-insomniac ;
-
-MAIN: httpd-main

extra/io/encodings/ascii/ascii.factor

@@ -5,12 +5,11 @@ IN: io.encodings.ascii
 
 <PRIVATE
 : encode-if< ( char stream encoding max -- )
-    nip 1- pick < [ encode-error ] [ stream-write1 ] if ;
+    nip 1- pick < [ encode-error ] [ stream-write1 ] if ; inline
 
 : decode-if< ( stream encoding max -- character )
-    nip swap stream-read1
+    nip swap stream-read1 dup
-    [ tuck > [ drop replacement-char ] unless ]
+    [ tuck > [ drop replacement-char ] unless ] [ 2drop f ] if ; inline
-    [ drop f ] if* ;
 PRIVATE>
 
 SINGLETON: ascii

extra/io/server/server-docs.factor

@@ -1,10 +0,0 @@
-USING: help help.syntax help.markup io ;
-IN: io.server
-
-HELP: with-server
-{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "encoding" "an encoding to use for client connections" } { "quot" "a quotation" } }
-{ $description "Starts a TCP/IP server. The quotation is called in a new thread for each client connection, with the client connection being both the " { $link input-stream } " and " { $link output-stream } "." } ;
-
-HELP: with-datagrams
-{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "quot" "a quotation" } }
-{ $description "Starts a UDP/IP server. The quotation is called for each datagram packet received." } ;

extra/io/server/server-tests.factor

@@ -1,7 +0,0 @@
-IN: io.server.tests
-USING: tools.test io.server io.server.private kernel ;
-
-{ 2 0 } [ [ ] server-loop ] must-infer-as
-{ 3 0 } [ [ ] with-connection ] must-infer-as
-{ 1 0 } [ [ ] swap datagram-loop ] must-infer-as
-{ 2 0 } [ [ ] with-datagrams ] must-infer-as

extra/io/server/server.factor

@@ -1,76 +0,0 @@
-! Copyright (C) 2003, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io io.sockets io.sockets.secure io.files
-io.streams.duplex logging continuations destructors kernel math
-math.parser namespaces parser sequences strings prettyprint
-debugger quotations calendar threads concurrency.combinators
-assocs fry accessors arrays ;
-IN: io.server
-
-SYMBOL: servers
-
-SYMBOL: remote-address
-
-<PRIVATE
-
-LOG: accepted-connection NOTICE
-
-: with-connection ( client remote local quot -- )
-    '[
-        , ,
-        [ [ remote-address set ] [ local-address set ] bi* ]
-        [ 2array accepted-connection ]
-        2bi
-        @
-    ] with-stream ; inline
-
-: accept-loop ( server quot -- )
-    [
-        [ [ accept ] [ addr>> ] bi ] dip
-        '[ , , , , with-connection ] "Client" spawn drop
-    ] 2keep accept-loop ; inline
-
-: server-loop ( addrspec encoding quot -- )
-    >r <server> dup servers get push r>
-    '[ , accept-loop ] with-disposal ; inline
-
-\ server-loop NOTICE add-error-logging
-
-PRIVATE>
-
-: local-server ( port -- seq )
-    "localhost" swap t resolve-host ;
-
-: internet-server ( port -- seq )
-    f swap t resolve-host ;
-
-: secure-server ( port -- seq )
-    internet-server [ <secure> ] map ;
-
-: with-server ( seq service encoding quot -- )
-    V{ } clone servers [
-        '[ , [ , , server-loop ] with-logging ] parallel-each
-    ] with-variable ; inline
-
-: stop-server ( -- )
-    servers get dispose-each ;
-
-<PRIVATE
-
-LOG: received-datagram NOTICE
-
-: datagram-loop ( quot datagram -- )
-    [
-        [ receive dup received-datagram [ swap call ] dip ] keep
-        pick [ send ] [ 3drop ] if
-    ] 2keep datagram-loop ; inline
-
-: spawn-datagrams ( quot addrspec -- )
-    <datagram> [ datagram-loop ] with-disposal ; inline
-
-\ spawn-datagrams NOTICE add-input-logging
-
-PRIVATE>
-
-: with-datagrams ( seq service quot -- )
-    '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline

extra/io/server/summary.txt

@@ -1 +0,0 @@
-TCP/IP and UDP/IP servers

extra/io/servers/connection/connection-docs.factor

@@ -0,0 +1,2 @@
+USING: help help.syntax help.markup io ;
+IN: io.servers.connection

extra/io/servers/connection/connection-tests.factor

@@ -0,0 +1,47 @@
+IN: io.servers.connection
+USING: tools.test io.servers.connection io.sockets namespaces
+io.servers.connection.private kernel accessors sequences
+concurrency.promises io.encodings.ascii io threads calendar ;
+
+[ t ] [ <threaded-server> listen-on empty? ] unit-test
+
+[ f ] [
+    <threaded-server>
+        25 internet-server >>insecure
+    listen-on
+    empty?
+] unit-test
+
+[ t ] [
+    T{ inet4 "1.2.3.4" 1234 } T{ inet4 "1.2.3.5" 1235 }
+    [ log-connection ] 2keep
+    [ remote-address get = ] [ local-address get = ] bi*
+    and
+] unit-test
+
+[ ] [ <threaded-server> init-server drop ] unit-test
+
+[ 10 ] [
+    <threaded-server>
+        10 >>max-connections
+    init-server semaphore>> count>> 
+] unit-test
+
+[ ] [ <promise> "p" set ] unit-test
+
+[ ] [
+    [
+        <threaded-server>
+            5 >>max-connections
+            1237 >>insecure
+            [ "Hello world." write stop-server ] >>handler
+        start-server
+        t "p" get fulfill
+    ] in-thread
+] unit-test
+
+[ ] [ 100 sleep ] unit-test
+
+[ "Hello world." ] [ "localhost" 1237 <inet> ascii <client> drop contents ] unit-test
+
+[ t ] [ "p" get 2 seconds ?promise-timeout ] unit-test

extra/io/servers/connection/connection.factor

@@ -0,0 +1,131 @@
+! Copyright (C) 2003, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: continuations destructors kernel math math.parser
+namespaces parser sequences strings prettyprint debugger
+quotations combinators combinators.lib logging calendar assocs
+fry accessors arrays io io.sockets io.encodings.ascii
+io.sockets.secure io.files io.streams.duplex io.timeouts
+io.encodings threads concurrency.combinators
+concurrency.semaphores ;
+IN: io.servers.connection
+
+TUPLE: threaded-server
+name
+secure insecure
+secure-config
+sockets
+max-connections
+semaphore
+timeout
+encoding
+handler ;
+
+: local-server ( port -- addrspec ) "localhost" swap <inet> ;
+
+: internet-server ( port -- addrspec ) f swap <inet> ;
+
+: new-threaded-server ( class -- threaded-server )
+    new
+        "server" >>name
+        ascii >>encoding
+        1 minutes >>timeout
+        V{ } clone >>sockets
+        <secure-config> >>secure-config
+        [ "No handler quotation" throw ] >>handler ; inline
+
+: <threaded-server> ( -- threaded-server )
+    threaded-server new-threaded-server ;
+
+SYMBOL: remote-address
+
+GENERIC: handle-client* ( server -- )
+
+<PRIVATE
+
+: >insecure ( addrspec -- addrspec' )
+    dup { [ integer? ] [ string? ] } 1|| [ internet-server ] when ;
+
+: >secure ( addrspec -- addrspec' )
+    >insecure
+    dup { [ secure? ] [ not ] } 1|| [ <secure> ] unless ;
+
+: listen-on ( threaded-server -- addrspecs )
+    [ secure>> >secure ] [ insecure>> >insecure ] bi
+    [ resolve-host ] bi@ append ;
+
+LOG: accepted-connection NOTICE
+
+: log-connection ( remote local -- )
+    [ [ remote-address set ] [ local-address set ] bi* ]
+    [ 2array accepted-connection ]
+    2bi ;
+
+M: threaded-server handle-client* handler>> call ;
+
+: handle-client ( client remote local -- )
+    '[
+        , , log-connection
+        threaded-server get
+        [ timeout>> timeouts ] [ handle-client* ] bi
+    ] with-stream ;
+
+: thread-name ( server-name addrspec -- string )
+    unparse " connection from " swap 3append ;
+
+: accept-connection ( server -- )
+    [ accept ] [ addr>> ] bi
+    [ '[ , , , handle-client ] ]
+    [ drop threaded-server get name>> swap thread-name ] 2bi
+    spawn drop ;
+
+: accept-loop ( server -- )
+    [
+        threaded-server get semaphore>>
+        [ [ accept-connection ] with-semaphore ]
+        [ accept-connection ]
+        if*
+    ] [ accept-loop ] bi ; inline
+
+: start-accept-loop ( server -- )
+    threaded-server get encoding>> <server>
+    [ threaded-server get sockets>> push ]
+    [ [ accept-loop ] with-disposal ]
+    bi ;
+
+\ start-accept-loop ERROR add-error-logging
+
+: init-server ( threaded-server -- threaded-server )
+    dup semaphore>> [
+        dup max-connections>> [
+            <semaphore> >>semaphore
+        ] when*
+    ] unless ;
+
+PRIVATE>
+
+: start-server ( threaded-server -- )
+    init-server
+    dup secure-config>> [
+        dup threaded-server [
+            dup name>> [
+                listen-on [
+                    start-accept-loop
+                ] parallel-each
+            ] with-logging
+        ] with-variable
+    ] with-secure-context ;
+
+: stop-server ( -- )
+    threaded-server get [ f ] change-sockets drop dispose-each ;
+
+GENERIC: port ( addrspec -- n )
+
+M: integer port ;
+
+M: object port port>> ;
+
+: secure-port ( -- n )
+    threaded-server get dup [ secure>> port ] when ;
+
+: insecure-port ( -- n )
+    threaded-server get dup [ insecure>> port ] when ;

extra/io/servers/connection/summary.txt

@@ -0,0 +1 @@
+Multi-threaded TCP/IP servers

extra/io/servers/packet/datagram.factor

@@ -0,0 +1,21 @@
+IN: io.servers.datagram
+
+<PRIVATE
+
+LOG: received-datagram NOTICE
+
+: datagram-loop ( quot datagram -- )
+    [
+        [ receive dup received-datagram [ swap call ] dip ] keep
+        pick [ send ] [ 3drop ] if
+    ] 2keep datagram-loop ; inline
+
+: spawn-datagrams ( quot addrspec -- )
+    <datagram> [ datagram-loop ] with-disposal ; inline
+
+\ spawn-datagrams NOTICE add-input-logging
+
+PRIVATE>
+
+: with-datagrams ( seq service quot -- )
+    '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline

extra/io/servers/packet/summary.txt

@@ -0,0 +1 @@
+Multi-threaded UDP/IP servers

extra/io/servers/packet/tags.txt

@@ -0,0 +1 @@
+network

extra/io/sockets/secure/secure-tests.factor

@@ -1 +1,4 @@
-! No unit tests here, until Windows SSL is implemented
+IN: io.sockets.secure.tests
+USING: accessors kernel io.sockets io.sockets.secure tools.test ;
+
+[ "hello" 24 ] [ "hello" 24 <inet> <secure> [ host>> ] [ port>> ] bi ] unit-test

extra/io/sockets/secure/secure.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel symbols namespaces continuations
-destructors io.sockets sequences inspector calendar ;
+destructors io.sockets sequences inspector calendar delegate ;
 IN: io.sockets.secure
 
 SYMBOL: secure-socket-timeout
@@ -42,8 +42,10 @@ TUPLE: secure addrspec ;
 
 C: <secure> secure
 
-: resolve-secure-host ( host port passive? -- seq )
+CONSULT: inet secure addrspec>> ;
-    resolve-host [ <secure> ] map ;
+
+M: secure resolve-host ( secure -- seq )
+    addrspec>> resolve-host [ <secure> ] map ;
 
 HOOK: check-certificate secure-socket-backend ( host handle -- )
 
@@ -53,9 +55,8 @@ PREDICATE: secure-inet < secure addrspec>> inet? ;
 
 M: secure-inet (client)
     [
-        addrspec>>
+        [ resolve-host (client) [ |dispose ] dip ] keep
-        [ [ host>> ] [ port>> ] bi f resolve-secure-host (client) >r |dispose r> ] keep
+        addrspec>> host>> pick handle>> check-certificate
-        host>> pick handle>> check-certificate
     ] with-destructors ;
 
 PRIVATE>

extra/io/sockets/sockets-docs.factor

@@ -27,7 +27,7 @@ $nl
     { { $link inet4 } " - a TCP/IP connection to an IPv4 address and port number; no name lookup is performed" }
     { { $link inet6 } " - a TCP/IP connection to an IPv6 address and port number; no name lookup is performed" }
 }
-"The " { $vocab-link "io.server" } " library defines a nice high-level wrapper around " { $link <server> } " which makes it easy to listen for IPv4 and IPv6 connections simultaneously, perform logging, and optionally only allow connections from the loopback interface."
+"The " { $vocab-link "io.servers.connection" } " library defines high-level wrappers around " { $link <server> } " which makes it easy to listen for IPv4, IPv6 and secure socket connections simultaneously, perform logging, and optionally only allow connections from the loopback interface."
 { $see-also "io.sockets.secure" } ;
 
 ARTICLE: "network-packet" "Packet-oriented networking"
@@ -79,7 +79,7 @@ HELP: inet
 HELP: inet4
 { $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link <inet4> } "." }
 { $notes
-"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible."
+"Most applications do not operate on IPv4 addresses directly, and instead should use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible."
 }
 { $examples
     { $code "\"127.0.0.1\" 8080 <inet4>" }
@@ -88,7 +88,7 @@ HELP: inet4
 HELP: inet6
 { $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link <inet6> } "." }
 { $notes
-"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name." }
+"Most applications do not operate on IPv6 addresses directly, and instead should use " { $link resolve-host } " to look up the address associated to a host name." }
 { $examples
     { $code "\"::1\" 8080 <inet6>" }
 } ;
@@ -118,10 +118,10 @@ HELP: <server>
 }
 { $notes
     "To start a TCP/IP server which listens for connections from any host, use an address specifier returned by the following code, where 1234 is the desired port number:"
-    { $code "f 1234 t resolve-host" }
+    { $code "f 1234 <inet> resolve-host" }
     "To start a server which listens for connections from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:"
-    { $code "\"localhost\" 1234 t resolve-host" }
+    { $code "\"localhost\" 1234 <inet> resolve-host" }
-    "Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.server" } " vocabulary can be used to help with this."
+    "Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.servers.connection" } " vocabulary can be used to help with this."
     $nl
     "To start a TCP/IP server which listens for connections on a randomly-assigned port, set the port number in the address specifier to 0, and then read the " { $snippet "addr" } " slot of the server instance to obtain the actual port number it is listening on:"
     { $unchecked-example
@@ -148,9 +148,9 @@ HELP: <datagram>
 }
 { $notes
     "To accept UDP/IP packets from any host, use an address specifier returned by the following code, where 1234 is the desired port number:"
-    { $code "f 1234 t resolve-host" }
+    { $code "f 1234 <inet> resolve-host" }
     "To accept UDP/IP packets from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:"
-    { $code "\"localhost\" 1234 t resolve-host" }
+    { $code "\"localhost\" 1234 <inet> resolve-host" }
     "Since " { $link resolve-host } " can return multiple address specifiers, your code must create a datagram socket for each one and co-ordinate packet sending accordingly."
     "Datagrams are low-level binary ports that don't map onto streams, so the constructor does not use an encoding"
 }
@@ -165,3 +165,7 @@ HELP: send
 { $values { "packet" byte-array } { "addrspec" "an address specifier" } { "datagram" "a datagram socket" } }
 { $description "Sends a packet to the given address." }
 { $errors "Throws an error if the packet could not be sent." } ;
+
+HELP: resolve-host
+{ $values { "addrspec" "an address specifier" } { "seq" "a sequence of address specifiers" } }
+{ $description "Resolves host names to IP addresses." } ;

extra/io/sockets/sockets-tests.factor

@@ -45,7 +45,7 @@ concurrency.promises threads io.streams.string ;
 [ "1:2:0:0:0:0:3:4" ]
 [ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test
 
-[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test
+[ t ] [ "localhost" 80 <inet> resolve-host length 1 >= ] unit-test
 
 ! Smoke-test UDP
 [ ] [ "127.0.0.1" 0 <inet4> <datagram> "datagram1" set ] unit-test

extra/io/sockets/sockets.factor

@@ -259,20 +259,26 @@ HOOK: (send) io-backend ( packet addrspec datagram -- )
     [ addrinfo>addrspec ] map
     sift ;
 
-: prepare-resolve-host ( host serv passive? -- host' serv' flags )
+: prepare-resolve-host ( addrspec -- host' serv' flags )
     #! If the port is a number, we resolve for 'http' then
     #! change it later. This is a workaround for a FreeBSD
     #! getaddrinfo() limitation -- on Windows, Linux and Mac,
     #! we can convert a number to a string and pass that as the
     #! service name, but on FreeBSD this gives us an unknown
     #! service error.
-    >r
+    [ host>> ]
-    dup integer? [ port-override set "http" ] when
+    [ port>> dup integer? [ port-override set "http" ] when ] bi
-    r> AI_PASSIVE 0 ? ;
+    over 0 AI_PASSIVE ? ;
 
 HOOK: addrinfo-error io-backend ( n -- )
 
-: resolve-host ( host serv passive? -- seq )
+GENERIC: resolve-host ( addrspec -- seq )
+
+TUPLE: inet host port ;
+
+C: <inet> inet
+
+M: inet resolve-host
     [
         prepare-resolve-host
         "addrinfo" <c-object>
@@ -284,17 +290,16 @@ HOOK: addrinfo-error io-backend ( n -- )
         freeaddrinfo
     ] with-scope ;
 
+M: f resolve-host drop { } ;
+
+M: object resolve-host 1array ;
+
 : host-name ( -- string )
     256 <byte-array> dup dup length gethostname
     zero? [ "gethostname failed" throw ] unless
     ascii alien>string ;
 
-TUPLE: inet host port ;
+M: inet (client) resolve-host (client) ;
-
-C: <inet> inet
-
-M: inet (client)
-    [ host>> ] [ port>> ] bi f resolve-host (client) ;
 
 ERROR: invalid-inet-server addrspec ;
 

extra/io/streams/limited/limited-tests.factor

@@ -30,3 +30,11 @@ namespaces tools.test strings kernel ;
 [ "abc" CHAR: \n ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
 
 [ "\n" "limited" get stream-read-until ] [ limit-exceeded? ] must-fail-with
+
+[ "he" CHAR: l ] [
+    B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o }
+    ascii <byte-reader> [
+        5 limit-input
+        "l" read-until
+    ] with-input-stream
+] unit-test

extra/io/streams/limited/limited.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math io destructors accessors sequences
+USING: kernel math io io.encodings destructors accessors
-namespaces ;
+sequences namespaces ;
 IN: io.streams.limited
 
 TUPLE: limited-stream stream count limit ;
@@ -12,8 +12,13 @@ TUPLE: limited-stream stream count limit ;
         swap >>stream
         0 >>count ;
 
-: limit-input ( limit -- )
+GENERIC# limit 1 ( stream limit -- stream' )
-    input-stream [ swap <limited-stream> ] change ;
+
+M: decoder limit [ clone ] dip [ limit ] curry change-stream ;
+
+M: object limit <limited-stream> ;
+
+: limit-input ( limit -- ) input-stream [ swap limit ] change ;
 
 ERROR: limit-exceeded ;
 

extra/io/unix/launcher/launcher.factor

@@ -31,7 +31,7 @@ USE: unix
     ] when* ;
 
 : redirect-fd ( oldfd fd -- )
-    2dup = [ 2drop ] [ dupd dup2 io-error close-file ] if ;
+    2dup = [ 2drop ] [ dup2 io-error ] if ;
 
 : reset-fd ( fd -- )
     #! We drop the error code because on *BSD, fcntl of

extra/io/unix/sockets/secure/secure-tests.factor

@@ -14,7 +14,7 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
         "resource:extra/openssl/test/server.pem" >>key-file
         "resource:extra/openssl/test/dh1024.pem" >>dh-file
         "password" >>password
-    swap with-secure-context ;
+    swap with-secure-context ; inline
 
 :: server-test ( quot -- )
     [

extra/peg/parsers/parsers.factor

@@ -24,11 +24,9 @@ MEMO: just ( parser -- parser )
 
 : 1token ( ch -- parser ) 1string token ;
 
-<PRIVATE
 : (list-of) ( items separator repeat1? -- parser )
   >r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
   [ unclip 1vector swap first append ] action ;
-PRIVATE>
 
 : list-of ( items separator -- parser )
   hide f (list-of) ;

extra/peg/peg.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007, 2008 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences strings fry namespaces math assocs shuffle 
+USING: kernel sequences strings fry namespaces math assocs shuffle debugger io
        vectors arrays math.parser math.order
        unicode.categories compiler.units parser
        words quotations effects memoize accessors locals effects splitting ;
@@ -563,11 +563,24 @@ PRIVATE>
   #! to fix boxes so this isn't needed...
   box-parser boa next-id f <parser> over set-delegate [ ] action ;
 
+ERROR: parse-failed input word ;
+
+M: parse-failed error.
+  "The " write dup word>> pprint " word could not parse the following input:" print nl
+  input>> . ;
+
 : PEG:
-  (:) [
+  (:)
+  [let | def [ ] word [ ] |
     [
-        call compile [ compiled-parse ] curry
+      [
-        [ dup [ parse-result-ast ] [ "Parse failed" throw ] if ]
+        [let | compiled-def [ def call compile ] |
-        append define
+          [
+            dup compiled-def compiled-parse
+            [ ast>> ] [ word parse-failed ] ?if
+          ]
+          word swap define
+        ]
       ] with-compilation-unit
-  ] 2curry over push-all ; parsing
+    ] over push-all
+  ] ; parsing

extra/smtp/server/server.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007 Elie CHAFTARI
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel prettyprint io io.timeouts io.server
+USING: combinators kernel prettyprint io io.timeouts
 sequences namespaces io.sockets continuations calendar
 io.encodings.ascii io.streams.duplex destructors ;
 IN: smtp.server

extra/tty-server/tty-server.factor

@@ -1,11 +1,15 @@
-USING: listener io.server io.encodings.utf8 ;
+USING: listener io.servers.connection io.encodings.utf8
+accessors kernel ;
 IN: tty-server
 
-: tty-server ( port -- )
+: <tty-server> ( port -- )
-    local-server
+    <threaded-server>
-    "tty-server"
+        "tty-server" >>name
-    utf8 [ listener ] with-server ;
+        utf8 >>encoding
+        swap local-server >>insecure
+        [ listener ] >>handler
+    start-server ;
 
-: default-tty-server ( -- ) 9999 tty-server ;
+: tty-server ( -- ) 9999 <tty-server> ;
 
-MAIN: default-tty-server
+MAIN: tty-server

extra/webapps/blogs/blogs.factor

@@ -7,6 +7,7 @@ html.components
 http.server.dispatchers
 furnace
 furnace.actions
+furnace.redirection
 furnace.auth
 furnace.auth.login
 furnace.boilerplate

extra/webapps/counter/counter.factor

@@ -1,5 +1,5 @@
 USING: math kernel accessors http.server http.server.dispatchers
-furnace furnace.actions furnace.sessions
+furnace furnace.actions furnace.sessions furnace.redirection
 html.components html.forms html.templates.chloe
 fry urls ;
 IN: webapps.counter

extra/webapps/pastebin/pastebin.factor

@@ -12,6 +12,7 @@ http.server.dispatchers
 http.server.redirection
 furnace
 furnace.actions
+furnace.redirection
 furnace.auth
 furnace.auth.login
 furnace.boilerplate

extra/webapps/planet/planet.factor

@@ -10,6 +10,7 @@ http.server
 http.server.dispatchers
 furnace
 furnace.actions
+furnace.redirection
 furnace.boilerplate
 furnace.auth.login
 furnace.auth

extra/webapps/todo/todo.factor

@@ -11,6 +11,7 @@ furnace
 furnace.boilerplate
 furnace.auth
 furnace.actions
+furnace.redirection
 furnace.db
 furnace.auth.login ;
 IN: webapps.todo

extra/webapps/user-admin/user-admin.factor

@@ -12,6 +12,7 @@ furnace.auth.providers.db
 furnace.auth.login
 furnace.auth
 furnace.actions
+furnace.redirection
 furnace.utilities
 http.server
 http.server.dispatchers ;
@@ -138,7 +139,7 @@ TUPLE: user-admin < dispatcher ;
     <action>
         [
             validate-username
-            <user> select-tuple 1 >>deleted update-tuple
+            "username" value <user> delete-tuples
             URL" $user-admin" <redirect>
         ] >>submit ;
 

extra/webapps/wee-url/wee-url.factor

@@ -4,7 +4,7 @@
 USING: math.ranges sequences random accessors combinators.lib
 kernel namespaces fry db.types db.tuples urls validators
 html.components html.forms http http.server.dispatchers furnace
-furnace.actions furnace.boilerplate ;
+furnace.actions furnace.boilerplate furnace.redirection ;
 IN: webapps.wee-url
 
 TUPLE: wee-url < dispatcher ;

extra/webapps/wiki/wiki.factor

@@ -8,6 +8,7 @@ http.server
 http.server.dispatchers
 furnace
 furnace.actions
+furnace.redirection
 furnace.auth
 furnace.auth.login
 furnace.boilerplate

extra/websites/concatenative/concatenative.factor

@@ -1,18 +1,21 @@
 ! Copyright (c) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences assocs io.files io.sockets
-io.server
+io.sockets.secure io.servers.connection
-namespaces db db.tuples db.sqlite smtp
+namespaces db db.tuples db.sqlite smtp urls
 logging.insomniac
 http.server
 http.server.dispatchers
+http.server.redirection
 furnace.alloy
 furnace.auth.login
 furnace.auth.providers.db
 furnace.auth.features.edit-profile
 furnace.auth.features.recover-password
 furnace.auth.features.registration
+furnace.auth.features.deactivate-user
 furnace.boilerplate
+furnace.redirection
 webapps.blogs
 webapps.pastebin
 webapps.planet
@@ -20,7 +23,7 @@ webapps.todo
 webapps.wiki
 webapps.wee-url
 webapps.user-admin ;
-IN: webapps.factor-website
+IN: websites.concatenative
 
 : test-db ( -- db params ) "resource:test.db" sqlite-db ;
 
@@ -49,25 +52,53 @@ TUPLE: factor-website < dispatcher ;
         <wiki> "wiki" add-responder
         <wee-url> "wee-url" add-responder
         <user-admin> "user-admin" add-responder
+        URL" /wiki/view/Front Page" <redirect-responder> "" add-responder
     "Factor website" <login-realm>
         "Factor website" >>name
         allow-registration
         allow-password-recovery
         allow-edit-profile
+        allow-deactivation
     <boilerplate>
         { factor-website "page" } >>template
     test-db <alloy> ;
 
-: init-factor-website ( -- )
+SYMBOL: key-password
-    "factorcode.org" 25 <inet> smtp-server set-global
+SYMBOL: key-file
-    "todo@factorcode.org" lost-password-from set-global
+SYMBOL: dh-file
-    "website@factorcode.org" insomniac-sender set-global
-    "slava@factorcode.org" insomniac-recipients set-global
-    init-factor-db
-    <factor-website> main-responder set-global ;
 
-: start-factor-website ( -- )
+: common-configuration ( -- )
+    "concatenative.org" 25 <inet> smtp-server set-global
+    "noreply@concatenative.org" lost-password-from set-global
+    "website@concatenative.org" insomniac-sender set-global
+    "slava@factorcode.org" insomniac-recipients set-global
+    <factor-website> main-responder set-global
+    init-factor-db ;
+
+: init-testing ( -- )
+    "resource:extra/openssl/test/dh1024.pem" dh-file set-global
+    "resource:extra/openssl/test/server.pem" key-file set-global
+    "password" key-password set-global
+    common-configuration ;
+
+: init-production ( -- )
+    "/home/slava/cert/host.pem" key-file set-global
+    common-configuration ;
+
+: <factor-secure-config> ( -- config )
+    <secure-config>
+        key-file get >>key-file
+        dh-file get >>dh-file
+        key-password get >>password ;
+
+: <factor-website-server> ( -- threaded-server )
+    <http-server>
+        <factor-secure-config> >>secure-config
+        8080 >>insecure
+        8431 >>secure ;
+
+: start-website ( -- )
     test-db start-expiring
     test-db start-update-task
-    httpd-insomniac
+    http-insomniac
-    8812 httpd ;
+    <factor-website-server> start-server ;

extra/websites/concatenative/page.xml

@@ -12,7 +12,7 @@
 
 			<t:style t:include="resource:extra/xmode/code2html/stylesheet.css" />
 
-			<t:style t:include="resource:extra/webapps/factor-website/page.css" />
+			<t:style t:include="resource:extra/websites/concatenative/page.css" />
 
 			<t:write-style />