diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 4a9f90cb32..942476616f 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -28,23 +28,62 @@ ERROR: encode-error ; ! Decoding - f decoder boa ; +>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 [ + [ + >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 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 ) - 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 ) +: ((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 - (read-until) ; + [ decode-char dup [ dup rot member? ] [ 2drop f t ] if ] 3curry + ((read-until)) ; inline -: fix-read1 ( stream char -- char ) - over decoder-cr [ - over cr- - dup CHAR: \n = [ - drop dup stream-read1 - ] when - ] when nip ; +M: decoder stream-read-until (read-until) ; -M: decoder stream-read1 - dup >decoder< decode-char fix-read1 ; +M: decoder stream-readln "\r\n" over (read-until) handle-readln ; -M: decoder stream-readln ( stream -- str ) - "\r\n" over stream-read-until handle-readln ; - -M: decoder dispose decoder-stream dispose ; +M: decoder dispose stream>> dispose ; ! Encoding M: object encoder boa ; : >encoder< ( encoder -- stream encoding ) - [ stream>> ] [ code>> ] bi ; + [ stream>> ] [ code>> ] bi ; inline M: encoder stream-write1 >encoder< encode-char ; diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index d1dbefe26b..d69a2f94bc 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/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 -sequences words parser vectors strings sbufs io namespaces -assocs quotations sequences.private io.binary +inference.class kernel assocs math math.order math.private +kernel.private sequences words parser vectors strings sbufs io +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 ; { } [ [ @@ -59,15 +59,59 @@ sequences.private combinators ; node-in-d peek dup value? [ value-literal sequence? ] [ drop f ] if ; -: member-quot ( seq -- newquot ) - [ literalize [ t ] ] { } map>assoc - [ drop f ] suffix [ nip case ] curry ; +: expand-member ( #call quot -- ) + >r dup node-in-d peek value-literal r> call f splice-quot ; -: expand-member ( #call -- ) - dup node-in-d peek value-literal member-quot f splice-quot ; +: bit-member-n 256 ; inline + +: 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 diff --git a/extra/assocs/lib/lib-tests.factor b/extra/assocs/lib/lib-tests.factor new file mode 100644 index 0000000000..0bf8270088 --- /dev/null +++ b/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 diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 1c89c1eb16..14632df771 100755 --- a/extra/assocs/lib/lib.factor +++ b/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 diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor index ca1da0deaa..dc20e7ad5c 100755 --- a/extra/concurrency/distributed/distributed-tests.factor +++ b/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 ] } { [ os windows? ] [ "127.0.0.1" 1238 ] } @@ -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 diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor index c637f4baa3..9ae2627505 100755 --- a/extra/concurrency/distributed/distributed.factor +++ b/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 -accessors ; +io.servers.connection io.encodings.binary +qualified arrays namespaces kernel accessors ; FROM: io.sockets => host-name with-client ; IN: concurrency.distributed @@ -10,21 +10,21 @@ SYMBOL: local-node : handle-node-client ( -- ) deserialize - [ first2 get-process send ] - [ stop-server ] if* ; + [ first2 get-process send ] [ stop-server ] if* ; -: (start-node) ( addrspecs addrspec -- ) +: (start-node) ( addrspec addrspec -- ) local-node set-global [ - "concurrency.distributed" - binary - [ handle-node-client ] with-server + + swap >>insecure + binary >>encoding + "concurrency.distributed" >>name + [ handle-node-client ] >>handler + start-server ] curry "Distributed concurrency server" spawn drop ; : start-node ( port -- ) - [ internet-server ] - [ host-name swap ] bi - (start-node) ; + host-name over (start-node) ; TUPLE: remote-process id node ; diff --git a/extra/eval-server/eval-server.factor b/extra/eval-server/eval-server.factor deleted file mode 100644 index 3bfae616a2..0000000000 --- a/extra/eval-server/eval-server.factor +++ /dev/null @@ -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 diff --git a/extra/eval-server/summary.txt b/extra/eval-server/summary.txt deleted file mode 100644 index b75930ac9f..0000000000 --- a/extra/eval-server/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Listens for UDP packets on localhost:9998, evaluates them and sends back result diff --git a/extra/eval-server/tags.txt b/extra/eval-server/tags.txt deleted file mode 100644 index f628c95985..0000000000 --- a/extra/eval-server/tags.txt +++ /dev/null @@ -1,4 +0,0 @@ -demos -network -tools -applications diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor index cce69dde0f..c71eadb72f 100644 --- a/extra/ftp/server/server.factor +++ b/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 client set @@ -313,9 +316,14 @@ ERROR: not-a-directory ; ] with-directory ] with-destructors ; +: ( port -- server ) + ftp-server new-threaded-server + swap >>insecure + "ftp.server" >>name + latin1 >>encoding ; + : ftpd ( port -- ) - internet-server "ftp.server" - latin1 [ handle-client ] with-server ; + start-server ; : ftpd-main ( -- ) 2100 ftpd ; diff --git a/extra/furnace/asides/asides.factor b/extra/furnace/asides/asides.factor index 15d1c1df0b..9f1411188c 100644 --- a/extra/furnace/asides/asides.factor +++ b/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 ; diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor index d9f517aaf4..ae042f05bd 100755 --- a/extra/furnace/auth/auth.factor +++ b/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 + +M: secure-realm-only call-responder* + '[ , , call-next-method ] if-secure-realm ; + TUPLE: protected < filter-responder description capabilities ; : ( 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 ; + '[ + , , + dup protected set + dup logged-in-user get check-capabilities + [ call-next-method ] [ 2drop realm get login-required* ] if + ] if-secure-realm ; : ( responder -- responder' ) { realm "boilerplate" } >>template ; diff --git a/extra/furnace/auth/features/deactivate-user/deactivate-user.factor b/extra/furnace/auth/features/deactivate-user/deactivate-user.factor new file mode 100644 index 0000000000..cf6a56c2d4 --- /dev/null +++ b/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 + +: ( -- action ) + + [ + logged-in-user get + 1 >>deleted + t >>changed? + drop + URL" $realm" end-aside + ] >>submit ; + +: allow-deactivation ( realm -- realm ) + + "delete your profile" >>description + "deactivate-user" add-responder ; + +: allow-deactivation? ( -- ? ) + realm get responders>> "deactivate-user" swap key? ; diff --git a/extra/furnace/auth/features/edit-profile/edit-profile.xml b/extra/furnace/auth/features/edit-profile/edit-profile.xml index 011cc2bdf8..a9d7994e97 100644 --- a/extra/furnace/auth/features/edit-profile/edit-profile.xml +++ b/extra/furnace/auth/features/edit-profile/edit-profile.xml @@ -67,4 +67,7 @@ + + Delete User + diff --git a/extra/furnace/auth/features/recover-password/recover-1.xml b/extra/furnace/auth/features/recover-password/recover-1.xml index 21fbe6fd39..46e52d5319 100644 --- a/extra/furnace/auth/features/recover-password/recover-1.xml +++ b/extra/furnace/auth/features/recover-password/recover-1.xml @@ -6,7 +6,7 @@

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.

- + diff --git a/extra/furnace/auth/features/recover-password/recover-3.xml b/extra/furnace/auth/features/recover-password/recover-3.xml index 2e412d1f18..a71118ea31 100644 --- a/extra/furnace/auth/features/recover-password/recover-3.xml +++ b/extra/furnace/auth/features/recover-password/recover-3.xml @@ -6,7 +6,7 @@

Choose a new password for your account.

- +
diff --git a/extra/furnace/auth/features/recover-password/recover-4.xml b/extra/furnace/auth/features/recover-password/recover-4.xml index f5d02fa858..d71a01bc25 100755 --- a/extra/furnace/auth/features/recover-password/recover-4.xml +++ b/extra/furnace/auth/features/recover-password/recover-4.xml @@ -4,6 +4,6 @@ Recover lost password: step 4 of 4 -

Your password has been reset. You may now log in.

+

Your password has been reset. You may now proceed.

diff --git a/extra/furnace/auth/features/recover-password/recover-password.factor b/extra/furnace/auth/features/recover-password/recover-password.factor index 1e8d163e99..93b3a7ad73 100644 --- a/extra/furnace/auth/features/recover-password/recover-password.factor +++ b/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 -http http.server.responses http.server.dispatchers -furnace furnace.actions furnace.auth furnace.auth.providers ; +fry urls smtp validators html.forms present +http http.server.responses http.server.redirection +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" - swap [ - [ username>> "username" set ] - [ ticket>> "ticket" set ] + URL" recover-3" clone + swap + [ username>> "username" set-query-param ] + [ ticket>> "ticket" set-query-param ] bi - ] H{ } make-assoc - derive-url ; + adjust-url relative-to-request ; : password-email ( user -- 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 : ( -- 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" + URL" $realm/recover-2" ] >>submit ; : ( -- action ) - { realm "recover-2" } >>template ; + { realm "features/recover-password/recover-2" } >>template ; : ( -- 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" + URL" $realm/recover-4" ] [ <403> ] if* @@ -107,7 +108,7 @@ SYMBOL: lost-password-from : ( -- action ) - { realm "recover-4" } >>template ; + { realm "features/recover-password/recover-4" } >>template ; : allow-password-recovery ( login -- login ) diff --git a/extra/furnace/auth/features/registration/registration.factor b/extra/furnace/auth/features/registration/registration.factor index 2bc7688b10..20a48d07d2 100644 --- a/extra/furnace/auth/features/registration/registration.factor +++ b/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 : ( -- action ) @@ -34,10 +35,11 @@ IN: furnace.auth.features.registration realm get init-user-profile URL" $realm" - ] >>submit ; + ] >>submit + ; : allow-registration ( login -- login ) - "register" add-responder ; + "register" add-responder ; : allow-registration? ( -- ? ) realm get responders>> "register" swap key? ; diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index e2b208de3a..68161382c1 100755 --- a/extra/furnace/auth/login/login.factor +++ b/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 -- ) : ( -- cookie ) permit-id get realm get name>> permit-id-key "$login-realm" resolve-base-path >>path - realm get timeout>> from-now >>expires - realm get domain>> >>domain ; + realm get + [ timeout>> from-now >>expires ] + [ domain>> >>domain ] + [ secure>> >>secure ] + tri ; : put-permit-cookie ( response -- response' ) put-cookie ; @@ -81,7 +85,9 @@ SYMBOL: capabilities "password" value "username" value check-login [ successful-login ] [ login-failed ] if* - ] >>submit ; + ] >>submit + + ; : ( -- 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 ; + URL" $realm/login" >secure-url flashed-variables ; : ( responder name -- auth ) login-realm new-realm - "login" add-responder + "login" add-responder "logout" add-responder 20 minutes >>timeout ; diff --git a/extra/furnace/boilerplate/boilerplate.factor b/extra/furnace/boilerplate/boilerplate.factor index a976199661..0e2a673d9b 100644 --- a/extra/furnace/boilerplate/boilerplate.factor +++ b/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 diff --git a/extra/furnace/flash/flash.factor b/extra/furnace/flash/flash.factor index e06cdac090..2149e4fcd7 100644 --- a/extra/furnace/flash/flash.factor +++ b/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 ; diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 521f8a3bc1..90b529e385 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -63,13 +63,6 @@ M: url adjust-url M: string adjust-url ; -: ( url -- response ) - adjust-url request get method>> { - { "GET" [ ] } - { "HEAD" [ ] } - { "POST" [ ] } - } case ; - GENERIC: modify-form ( responder -- ) M: object modify-form drop ; diff --git a/extra/furnace/redirection/redirection.factor b/extra/furnace/redirection/redirection.factor new file mode 100644 index 0000000000..88d621b573 --- /dev/null +++ b/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 + +: ( url -- response ) + adjust-url request get method>> { + { "GET" [ ] } + { "HEAD" [ ] } + { "POST" [ ] } + } case ; + +: >secure-url ( url -- url' ) + clone + "https" >>protocol + secure-port >>port ; + +: ( url -- response ) + >secure-url ; + +TUPLE: redirect-responder to ; + +: ( url -- responder ) + redirect-responder boa ; + +M: redirect-responder call-responder* nip to>> ; + +TUPLE: secure-only < filter-responder ; + +C: secure-only + +: if-secure ( quot -- ) + >r request get url>> protocol>> "http" = + [ request get url>> ] + r> if ; inline + +M: secure-only call-responder* + '[ , , call-next-method ] if-secure ; diff --git a/extra/furnace/sessions/sessions-tests.factor b/extra/furnace/sessions/sessions-tests.factor index a97ba091c0..98d1bbdfc9 100755 --- a/extra/furnace/sessions/sessions-tests.factor +++ b/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 ; diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 863b8f87cb..6e50417ea1 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/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 -fry calendar combinators combinators.lib destructors alarms io.server +strings random accessors quotations hashtables sequences continuations +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 ; : ( -- cookie ) diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index 5fc4bd19ae..35e01227b5 100644 --- a/extra/html/elements/elements.factor +++ b/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- ( name -- ) #! Return the name and code for the patterned #! word. - dup swap [ write-html ] curry + dup swap '[ , write-html ] (( -- )) html-word ; : ( str -- foo> ) ">" append ; @@ -93,14 +93,14 @@ SYMBOL: html : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. - dup [ write-html ] curry (( -- )) html-word ; + dup '[ , write-html ] (( -- )) html-word ; : ( str -- ) "<" swap "/>" 3append ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. - dup swap [ write-html ] curry + dup swap '[ , 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 [ diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor index 32fe954178..103020ee0f 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/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 - [ ] [ "No such word: " swap append throw ] ?if ; + ":" split1 swap lookup ; : 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 ; diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 56957b021c..0b9224f171 100755 --- a/extra/http/client/client.factor +++ b/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-code - write-response-message nl - drop - ] - [ body>> write ] bi ; + [ response>> write-response-line nl drop ] + [ body>> write ] + bi ; : check-response ( response data -- response data ) over code>> success? [ download-failed ] unless ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 73d26aa327..522d0c1845 100755 --- a/extra/http/http-tests.factor +++ b/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 diff --git a/extra/http/http.factor b/extra/http/http.factor index 025e2c8441..4001301cb1 100755 --- a/extra/http/http.factor +++ b/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 sequences splitting sorting sets debugger +assocs assocs.lib 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-crlf dup - empty? [ drop ] [ header-line (read-header) ] if ; +: (read-header) ( -- alist ) + [ read-crlf dup f like ] [ parse-header-line ] [ drop ] unfold ; + +: 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 [ - "header" [ (read-header) ] with-variable - ] keep ; + (read-header) process-header ; : 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 - header-value>string check-header-string write crlf + [ check-header-string write ": " write ] + [ header-value>string check-header-string write crlf ] bi* ] 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 ; : ( value name -- cookie ) cookie new swap >>name swap >>value ; -: parse-cookies ( string -- seq ) +: parse-set-cookie ( string -- seq ) [ f swap - - ";" split [ - [ blank? ] trim "=" split1 swap >lower { + (parse-set-cookie) + [ + 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 ] } [ dup , nip ] } case - ] each + ] assoc-each + drop + ] { } make ; +: parse-cookie ( string -- seq ) + [ + f swap + (parse-cookie) + [ + swap { + { "$version" [ >>version ] } + { "$domain" [ >>domain ] } + { "$path" [ >>path ] } + [ 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) - "path" over path>> (unparse-cookie) - "domain" over domain>> (unparse-cookie) - "expires" over expires>> (unparse-cookie) - "max-age" over max-age>> (unparse-cookie) - "httponly" over http-only>> (unparse-cookie) + over value>> unparse-cookie-value + "$path" over path>> unparse-cookie-value + "$domain" over domain>> unparse-cookie-value drop ] { } make ; -: unparse-cookies ( cookies -- string ) - [ unparse-cookie ] map concat "; " join ; +: unparse-cookie ( cookies -- string ) + [ (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 ) - read-method - read-url - read-request-version + read-request-line read-request-header read-post-data extract-host extract-cookies ; -: write-method ( request -- request ) - dup method>> write bl ; - -: write-request-url ( request -- request ) - dup url>> relative-url present write bl ; - -: write-version ( request -- request ) - "HTTP/" write dup request-version write crlf ; +: write-request-line ( request -- request ) + dup + [ method>> write bl ] + [ url>> relative-url present write bl ] + [ "HTTP/" write version>> write crlf ] + tri ; : 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-url - write-version + write-request-line 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 ) - " \t" read-until - [ "Bad response: version" throw ] unless - 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-line ( response -- response ) + read-crlf parse-response-line first3 + [ >>version ] [ >>code ] [ >>message ] tri* ; : 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 ) - read-response-version - read-response-code - read-response-message + read-response-line 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-line ( response -- response ) + dup + [ "HTTP/" write version>> write bl ] + [ code>> present write bl ] + [ message>> write crlf ] + tri ; : 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 - over cookies>> f like [ unparse-cookies "set-cookie" pick set-at ] when* + #! We send one set-cookie header per cookie, because that's + #! 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-code - write-response-message + write-response-line write-response-header flush drop ; @@ -403,9 +387,7 @@ body ; "1.1" >>version ; M: raw-response write-response ( respose -- ) - write-response-version - write-response-code - write-response-message + write-response-line write-response-body drop ; diff --git a/extra/http/parsers/parsers.factor b/extra/http/parsers/parsers.factor new file mode 100644 index 0000000000..33bfa4b202 --- /dev/null +++ b/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 ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index f709939e21..21ab074907 100755 --- a/extra/http/server/server.factor +++ b/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 - ascii decode-input - ascii encode-output + 64 1024 * limit-input ?refresh-all read-request [ do-request ] ?benchmark [ do-response ] ?benchmark ] with-destructors ; +: ( -- 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" binary [ handle-client ] with-server ; + + swap >>insecure + f >>secure + start-server ; -: httpd-main ( -- ) - 8888 httpd ; - -: httpd-insomniac ( -- ) - "http.server" { httpd-hit } schedule-insomniac ; - -MAIN: httpd-main +: http-insomniac ( -- ) + "http.server" { "httpd-hit" } schedule-insomniac ; diff --git a/extra/io/encodings/ascii/ascii.factor b/extra/io/encodings/ascii/ascii.factor index 9ff120c5fa..08dc8d07d9 100755 --- a/extra/io/encodings/ascii/ascii.factor +++ b/extra/io/encodings/ascii/ascii.factor @@ -5,12 +5,11 @@ IN: io.encodings.ascii [ drop replacement-char ] unless ] - [ drop f ] if* ; + nip swap stream-read1 dup + [ tuck > [ drop replacement-char ] unless ] [ 2drop f ] if ; inline PRIVATE> SINGLETON: ascii diff --git a/extra/io/server/server-docs.factor b/extra/io/server/server-docs.factor deleted file mode 100755 index 50f38cb146..0000000000 --- a/extra/io/server/server-docs.factor +++ /dev/null @@ -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." } ; diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor deleted file mode 100755 index 965a70718b..0000000000 --- a/extra/io/server/server-tests.factor +++ /dev/null @@ -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 diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor deleted file mode 100755 index e975880a14..0000000000 --- a/extra/io/server/server.factor +++ /dev/null @@ -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 - -> ] bi ] dip - '[ , , , , with-connection ] "Client" spawn drop - ] 2keep accept-loop ; inline - -: server-loop ( addrspec encoding quot -- ) - >r 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 [ ] 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 ; - - [ datagram-loop ] with-disposal ; inline - -\ spawn-datagrams NOTICE add-input-logging - -PRIVATE> - -: with-datagrams ( seq service quot -- ) - '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline diff --git a/extra/io/server/summary.txt b/extra/io/server/summary.txt deleted file mode 100644 index e791b704eb..0000000000 --- a/extra/io/server/summary.txt +++ /dev/null @@ -1 +0,0 @@ -TCP/IP and UDP/IP servers diff --git a/extra/eval-server/authors.txt b/extra/io/servers/connection/authors.txt similarity index 100% rename from extra/eval-server/authors.txt rename to extra/io/servers/connection/authors.txt diff --git a/extra/io/servers/connection/connection-docs.factor b/extra/io/servers/connection/connection-docs.factor new file mode 100755 index 0000000000..b033ec287c --- /dev/null +++ b/extra/io/servers/connection/connection-docs.factor @@ -0,0 +1,2 @@ +USING: help help.syntax help.markup io ; +IN: io.servers.connection diff --git a/extra/io/servers/connection/connection-tests.factor b/extra/io/servers/connection/connection-tests.factor new file mode 100755 index 0000000000..bb87d67917 --- /dev/null +++ b/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 ] [ listen-on empty? ] unit-test + +[ f ] [ + + 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 + +[ ] [ init-server drop ] unit-test + +[ 10 ] [ + + 10 >>max-connections + init-server semaphore>> count>> +] unit-test + +[ ] [ "p" set ] unit-test + +[ ] [ + [ + + 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 ascii drop contents ] unit-test + +[ t ] [ "p" get 2 seconds ?promise-timeout ] unit-test diff --git a/extra/io/servers/connection/connection.factor b/extra/io/servers/connection/connection.factor new file mode 100755 index 0000000000..b062322142 --- /dev/null +++ b/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 ; + +: internet-server ( port -- addrspec ) f swap ; + +: new-threaded-server ( class -- threaded-server ) + new + "server" >>name + ascii >>encoding + 1 minutes >>timeout + V{ } clone >>sockets + >>secure-config + [ "No handler quotation" throw ] >>handler ; inline + +: ( -- threaded-server ) + threaded-server new-threaded-server ; + +SYMBOL: remote-address + +GENERIC: handle-client* ( server -- ) + +insecure ( addrspec -- addrspec' ) + dup { [ integer? ] [ string? ] } 1|| [ internet-server ] when ; + +: >secure ( addrspec -- addrspec' ) + >insecure + dup { [ secure? ] [ not ] } 1|| [ ] 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>> + [ 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 + ] 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 ; diff --git a/extra/io/servers/connection/summary.txt b/extra/io/servers/connection/summary.txt new file mode 100644 index 0000000000..8269ecfc38 --- /dev/null +++ b/extra/io/servers/connection/summary.txt @@ -0,0 +1 @@ +Multi-threaded TCP/IP servers diff --git a/extra/io/server/tags.txt b/extra/io/servers/connection/tags.txt similarity index 100% rename from extra/io/server/tags.txt rename to extra/io/servers/connection/tags.txt diff --git a/extra/io/server/authors.txt b/extra/io/servers/packet/authors.txt similarity index 100% rename from extra/io/server/authors.txt rename to extra/io/servers/packet/authors.txt diff --git a/extra/io/servers/packet/datagram.factor b/extra/io/servers/packet/datagram.factor new file mode 100644 index 0000000000..03596ee43c --- /dev/null +++ b/extra/io/servers/packet/datagram.factor @@ -0,0 +1,21 @@ +IN: io.servers.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 diff --git a/extra/io/servers/packet/summary.txt b/extra/io/servers/packet/summary.txt new file mode 100644 index 0000000000..29247a2937 --- /dev/null +++ b/extra/io/servers/packet/summary.txt @@ -0,0 +1 @@ +Multi-threaded UDP/IP servers diff --git a/extra/io/servers/packet/tags.txt b/extra/io/servers/packet/tags.txt new file mode 100644 index 0000000000..992ae12982 --- /dev/null +++ b/extra/io/servers/packet/tags.txt @@ -0,0 +1 @@ +network diff --git a/extra/io/sockets/secure/secure-tests.factor b/extra/io/sockets/secure/secure-tests.factor index 9b9436a8db..78de43d379 100644 --- a/extra/io/sockets/secure/secure-tests.factor +++ b/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 [ host>> ] [ port>> ] bi ] unit-test diff --git a/extra/io/sockets/secure/secure.factor b/extra/io/sockets/secure/secure.factor index 448a5cdda0..10aec22ee5 100644 --- a/extra/io/sockets/secure/secure.factor +++ b/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 -: resolve-secure-host ( host port passive? -- seq ) - resolve-host [ ] map ; +CONSULT: inet secure addrspec>> ; + +M: secure resolve-host ( secure -- seq ) + addrspec>> resolve-host [ ] map ; HOOK: check-certificate secure-socket-backend ( host handle -- ) @@ -53,9 +55,8 @@ PREDICATE: secure-inet < secure addrspec>> inet? ; M: secure-inet (client) [ - addrspec>> - [ [ host>> ] [ port>> ] bi f resolve-secure-host (client) >r |dispose r> ] keep - host>> pick handle>> check-certificate + [ resolve-host (client) [ |dispose ] dip ] keep + addrspec>> host>> pick handle>> check-certificate ] with-destructors ; PRIVATE> diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor index 78cddd5d3b..6aa46ccdbc 100755 --- a/extra/io/sockets/sockets-docs.factor +++ b/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 } " 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 } " 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 } "." } { $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 " } @@ -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 } "." } { $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 " } } ; @@ -118,10 +118,10 @@ HELP: } { $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 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" } - "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." + { $code "\"localhost\" 1234 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.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: } { $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 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 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." } ; diff --git a/extra/io/sockets/sockets-tests.factor b/extra/io/sockets/sockets-tests.factor index 8264bec032..4b95a31512 100755 --- a/extra/io/sockets/sockets-tests.factor +++ b/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 resolve-host length 1 >= ] unit-test ! Smoke-test UDP [ ] [ "127.0.0.1" 0 "datagram1" set ] unit-test diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 4efd30c65e..a9278c8357 100755 --- a/extra/io/sockets/sockets.factor +++ b/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 - dup integer? [ port-override set "http" ] when - r> AI_PASSIVE 0 ? ; + [ host>> ] + [ port>> dup integer? [ port-override set "http" ] when ] bi + 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 + +M: inet resolve-host [ prepare-resolve-host "addrinfo" @@ -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 dup dup length gethostname zero? [ "gethostname failed" throw ] unless ascii alien>string ; -TUPLE: inet host port ; - -C: inet - -M: inet (client) - [ host>> ] [ port>> ] bi f resolve-host (client) ; +M: inet (client) resolve-host (client) ; ERROR: invalid-inet-server addrspec ; diff --git a/extra/io/streams/limited/limited-tests.factor b/extra/io/streams/limited/limited-tests.factor index d160a3f756..eb5b921260 100644 --- a/extra/io/streams/limited/limited-tests.factor +++ b/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 [ + 5 limit-input + "l" read-until + ] with-input-stream +] unit-test diff --git a/extra/io/streams/limited/limited.factor b/extra/io/streams/limited/limited.factor index 669240d28b..e89b31a884 100644 --- a/extra/io/streams/limited/limited.factor +++ b/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 -namespaces ; +USING: kernel math io io.encodings destructors accessors +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 -- ) - input-stream [ swap ] change ; +GENERIC# limit 1 ( stream limit -- stream' ) + +M: decoder limit [ clone ] dip [ limit ] curry change-stream ; + +M: object limit ; + +: limit-input ( limit -- ) input-stream [ swap limit ] change ; ERROR: limit-exceeded ; diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 7f6b3396a1..365e51749d 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/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 diff --git a/extra/io/unix/sockets/secure/secure-tests.factor b/extra/io/unix/sockets/secure/secure-tests.factor index dca8fbbbc7..dee5c32349 100644 --- a/extra/io/unix/sockets/secure/secure-tests.factor +++ b/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 -- ) [ diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 443b9fc61d..da44c12e8f 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -24,11 +24,9 @@ MEMO: just ( parser -- parser ) : 1token ( ch -- parser ) 1string token ; -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) ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index b420574a3b..54c25778de 100755 --- a/extra/peg/peg.factor +++ b/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 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 ] - append define - ] with-compilation-unit - ] 2curry over push-all ; parsing + [ + [let | compiled-def [ def call compile ] | + [ + dup compiled-def compiled-parse + [ ast>> ] [ word parse-failed ] ?if + ] + word swap define + ] + ] with-compilation-unit + ] over push-all + ] ; parsing diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor index 824651030d..a6a8bb2cca 100755 --- a/extra/smtp/server/server.factor +++ b/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 diff --git a/extra/tty-server/tty-server.factor b/extra/tty-server/tty-server.factor index d4b1a34e76..4ba38ad06a 100644 --- a/extra/tty-server/tty-server.factor +++ b/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 -- ) - local-server - "tty-server" - utf8 [ listener ] with-server ; +: ( port -- ) + + "tty-server" >>name + utf8 >>encoding + swap local-server >>insecure + [ listener ] >>handler + start-server ; -: default-tty-server ( -- ) 9999 tty-server ; +: tty-server ( -- ) 9999 ; -MAIN: default-tty-server +MAIN: tty-server diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor index aa1aa5edc7..10e0ab54c0 100644 --- a/extra/webapps/blogs/blogs.factor +++ b/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 diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor index 30c5d403de..a14d6d9823 100644 --- a/extra/webapps/counter/counter.factor +++ b/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 diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 251872d1ac..3aeb21420f 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/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 diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index b472881e73..ca74b7e642 100755 --- a/extra/webapps/planet/planet.factor +++ b/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 diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 4b1b59e80f..0fb7e7dc89 100755 --- a/extra/webapps/todo/todo.factor +++ b/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 diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index 8c7b1b21c9..2137abbc2d 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/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 ; [ validate-username - select-tuple 1 >>deleted update-tuple + "username" value delete-tuples URL" $user-admin" ] >>submit ; diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor index 2396e98b2a..27187c4352 100644 --- a/extra/webapps/wee-url/wee-url.factor +++ b/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 ; diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 13c445b0a8..77ee242668 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/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 diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/websites/concatenative/concatenative.factor similarity index 53% rename from extra/webapps/factor-website/factor-website.factor rename to extra/websites/concatenative/concatenative.factor index c0bd856d5d..6d65f10783 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/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 -namespaces db db.tuples db.sqlite smtp +io.sockets.secure io.servers.connection +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" add-responder "wee-url" add-responder "user-admin" add-responder + URL" /wiki/view/Front Page" "" add-responder "Factor website" "Factor website" >>name allow-registration allow-password-recovery allow-edit-profile + allow-deactivation { factor-website "page" } >>template test-db ; -: init-factor-website ( -- ) - "factorcode.org" 25 smtp-server set-global - "todo@factorcode.org" lost-password-from set-global - "website@factorcode.org" insomniac-sender set-global - "slava@factorcode.org" insomniac-recipients set-global - init-factor-db - main-responder set-global ; +SYMBOL: key-password +SYMBOL: key-file +SYMBOL: dh-file -: start-factor-website ( -- ) +: common-configuration ( -- ) + "concatenative.org" 25 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 + 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 ; + +: ( -- config ) + + key-file get >>key-file + dh-file get >>dh-file + key-password get >>password ; + +: ( -- threaded-server ) + + >>secure-config + 8080 >>insecure + 8431 >>secure ; + +: start-website ( -- ) test-db start-expiring test-db start-update-task - httpd-insomniac - 8812 httpd ; + http-insomniac + start-server ; diff --git a/extra/webapps/factor-website/page.css b/extra/websites/concatenative/page.css similarity index 100% rename from extra/webapps/factor-website/page.css rename to extra/websites/concatenative/page.css diff --git a/extra/webapps/factor-website/page.xml b/extra/websites/concatenative/page.xml similarity index 88% rename from extra/webapps/factor-website/page.xml rename to extra/websites/concatenative/page.xml index 32e1223c58..464a3d9c5d 100644 --- a/extra/webapps/factor-website/page.xml +++ b/extra/websites/concatenative/page.xml @@ -12,7 +12,7 @@ - +