From 0a436e1184a2c6e56315ac8efb4e1937d6e4aad4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 17 Jun 2008 00:04:18 -0500 Subject: [PATCH 01/26] New threaded-server --- extra/io/server/server-docs.factor | 10 -- extra/io/server/server-tests.factor | 7 - extra/io/server/server.factor | 76 ---------- extra/io/server/summary.txt | 1 - .../connection}/authors.txt | 0 .../servers/connection/connection-docs.factor | 2 + .../connection/connection-tests.factor | 47 +++++++ extra/io/servers/connection/connection.factor | 131 ++++++++++++++++++ extra/io/servers/connection/summary.txt | 1 + .../{server => servers/connection}/tags.txt | 0 extra/io/servers/packet/authors.txt | 1 + extra/io/servers/packet/datagram.factor | 21 +++ extra/io/servers/packet/summary.txt | 1 + extra/io/servers/packet/tags.txt | 1 + extra/io/sockets/secure/secure-tests.factor | 5 +- extra/io/sockets/secure/secure.factor | 13 +- extra/io/sockets/sockets-docs.factor | 20 +-- extra/io/sockets/sockets-tests.factor | 2 +- extra/io/sockets/sockets.factor | 27 ++-- 19 files changed, 245 insertions(+), 121 deletions(-) delete mode 100755 extra/io/server/server-docs.factor delete mode 100755 extra/io/server/server-tests.factor delete mode 100755 extra/io/server/server.factor delete mode 100644 extra/io/server/summary.txt rename extra/io/{server => servers/connection}/authors.txt (100%) mode change 100755 => 100644 create mode 100755 extra/io/servers/connection/connection-docs.factor create mode 100755 extra/io/servers/connection/connection-tests.factor create mode 100755 extra/io/servers/connection/connection.factor create mode 100644 extra/io/servers/connection/summary.txt rename extra/io/{server => servers/connection}/tags.txt (100%) create mode 100755 extra/io/servers/packet/authors.txt create mode 100644 extra/io/servers/packet/datagram.factor create mode 100644 extra/io/servers/packet/summary.txt create mode 100644 extra/io/servers/packet/tags.txt 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/io/server/authors.txt b/extra/io/servers/connection/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from extra/io/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..f01112a70f --- /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 + +\ accept-loop ERROR add-error-logging + +: start-accept-loop ( server -- ) + threaded-server get encoding>> + [ threaded-server get sockets>> push ] + [ [ accept-loop ] with-disposal ] + bi ; + +: 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/servers/packet/authors.txt b/extra/io/servers/packet/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/io/servers/packet/authors.txt @@ -0,0 +1 @@ +Slava Pestov 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..75ac39e190 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: 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 ; From 24e9149a2e9528e5b1f8b1952953b5e3cfe05331 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 17 Jun 2008 00:08:50 -0500 Subject: [PATCH 02/26] Updating code for new io.servers code --- .../distributed/distributed.factor | 21 +++++++++---------- extra/eval-server/authors.txt | 1 - extra/eval-server/eval-server.factor | 11 ---------- extra/eval-server/summary.txt | 1 - extra/eval-server/tags.txt | 4 ---- extra/smtp/server/server.factor | 2 +- extra/tty-server/tty-server.factor | 16 +++++++------- 7 files changed, 20 insertions(+), 36 deletions(-) delete mode 100644 extra/eval-server/authors.txt delete mode 100644 extra/eval-server/eval-server.factor delete mode 100644 extra/eval-server/summary.txt delete mode 100644 extra/eval-server/tags.txt diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor index c637f4baa3..c9257eb27e 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,20 @@ 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 ] 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/authors.txt b/extra/eval-server/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/extra/eval-server/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov 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/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..e155c2068d 100644 --- a/extra/tty-server/tty-server.factor +++ b/extra/tty-server/tty-server.factor @@ -1,11 +1,13 @@ -USING: listener io.server io.encodings.utf8 ; +USING: listener io.servers.connection io.encodings.utf8 ; 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 ; -: default-tty-server ( -- ) 9999 tty-server ; +: tty-server ( -- ) 9999 tty-server ; -MAIN: default-tty-server +MAIN: tty-server From dc7b414f5718423d1f6d91109fa11c26c4cf7e47 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 17 Jun 2008 00:10:09 -0500 Subject: [PATCH 03/26] More flexible io.streams.limited, works with encoded streams --- extra/io/streams/limited/limited-tests.factor | 8 ++++++++ extra/io/streams/limited/limited.factor | 13 +++++++++---- 2 files changed, 17 insertions(+), 4 deletions(-) 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 ; From 5809df329a6f351d187eadd59b2abfbf5196ae5e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 17 Jun 2008 00:10:18 -0500 Subject: [PATCH 04/26] Add a unit test --- extra/io/unix/sockets/secure/secure-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 -- ) [ From cc605060b20d0928c0e9b803b1ab154b6ef33e1b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 17 Jun 2008 00:10:46 -0500 Subject: [PATCH 05/26] Working on https server support --- extra/furnace/asides/asides.factor | 2 +- .../recover-password/recover-password.factor | 3 +- .../features/registration/registration.factor | 3 +- extra/furnace/auth/login/login.factor | 3 +- extra/furnace/flash/flash.factor | 2 +- extra/furnace/furnace.factor | 7 -- extra/furnace/redirection/redirection.factor | 29 ++++++ extra/furnace/sessions/sessions-tests.factor | 2 +- extra/furnace/sessions/sessions.factor | 7 +- extra/http/http-tests.factor | 2 +- extra/http/server/server.factor | 32 +++---- extra/webapps/blogs/blogs.factor | 1 + extra/webapps/pastebin/pastebin.factor | 1 + extra/webapps/planet/planet.factor | 1 + extra/webapps/todo/todo.factor | 1 + extra/webapps/user-admin/user-admin.factor | 1 + extra/webapps/wee-url/wee-url.factor | 2 +- extra/webapps/wiki/wiki.factor | 1 + .../concatenative/concatenative.factor | 88 +++++++++++++++++++ extra/websites/concatenative/page.css | 78 ++++++++++++++++ extra/websites/concatenative/page.xml | 28 ++++++ 21 files changed, 257 insertions(+), 37 deletions(-) create mode 100644 extra/furnace/redirection/redirection.factor create mode 100644 extra/websites/concatenative/concatenative.factor create mode 100644 extra/websites/concatenative/page.css create mode 100644 extra/websites/concatenative/page.xml 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/features/recover-password/recover-password.factor b/extra/furnace/auth/features/recover-password/recover-password.factor index 1e8d163e99..806df024f0 100644 --- a/extra/furnace/auth/features/recover-password/recover-password.factor +++ b/extra/furnace/auth/features/recover-password/recover-password.factor @@ -3,7 +3,8 @@ 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 ; +furnace furnace.actions furnace.auth furnace.auth.providers +furnace.redirection ; IN: furnace.auth.features.recover-password SYMBOL: lost-password-from diff --git a/extra/furnace/auth/features/registration/registration.factor b/extra/furnace/auth/features/registration/registration.factor index 2bc7688b10..5c1851fb64 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 ) diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index e2b208de3a..4c53cb9c89 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 @@ -94,7 +95,7 @@ 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 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..7f87c677b9 --- /dev/null +++ b/extra/furnace/redirection/redirection.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors combinators namespaces +io.servers.connection +http http.server http.server.redirection +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>> ; 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/http/http-tests.factor b/extra/http/http-tests.factor index 73d26aa327..b5ed144579 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -123,7 +123,7 @@ read-response-test-1' 1array [ ! 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.dispatchers db.tuples ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index f709939e21..0312e62e8d 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,23 @@ 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 ; -: httpd ( port -- ) - dup integer? [ internet-server ] when - "http.server" binary [ handle-client ] with-server ; +: ( -- server ) + http-server new-threaded-server + "http.server" >>name + "http" protocol-port >>insecure + "https" protocol-port >>secure ; -: 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/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/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..359730d4b2 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 ; 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/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor new file mode 100644 index 0000000000..fcf98b08da --- /dev/null +++ b/extra/websites/concatenative/concatenative.factor @@ -0,0 +1,88 @@ +! Copyright (c) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel sequences assocs io.files io.sockets +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.boilerplate +furnace.redirection +webapps.blogs +webapps.pastebin +webapps.planet +webapps.todo +webapps.wiki +webapps.wee-url +webapps.user-admin ; +IN: websites.concatenative + +: test-db ( -- db params ) "resource:test.db" sqlite-db ; + +: init-factor-db ( -- ) + test-db [ + init-furnace-tables + + { + post comment + paste annotation + blog posting + todo + short-url + article revision + } ensure-tables + ] with-db ; + +TUPLE: factor-website < dispatcher ; + +: ( -- responder ) + factor-website new-dispatcher + "blogs" add-responder + "todo" add-responder + "pastebin" add-responder + "planet" add-responder + "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 + + { 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 ; + +: ( -- config ) + + "resource:extra/openssl/test/server.pem" >>key-file + "resource:extra/openssl/test/dh1024.pem" >>dh-file + "password" >>password ; + +: ( -- threaded-server ) + + >>secure-config + 8080 >>insecure + 8431 >>secure ; + +: start-factor-website ( -- ) + test-db start-expiring + test-db start-update-task + http-insomniac + start-server ; diff --git a/extra/websites/concatenative/page.css b/extra/websites/concatenative/page.css new file mode 100644 index 0000000000..49e26883ad --- /dev/null +++ b/extra/websites/concatenative/page.css @@ -0,0 +1,78 @@ +body, button { + font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif; + color:#444; +} + +.link-button { + padding: 0px; + background: none; + border: none; +} + +a, .link { + color: #222; + border-bottom:1px dotted #666; + text-decoration:none; +} + +a:hover, .link:hover { + border-bottom:1px solid #66a; +} + +.error { color: #a00; } + +.errors li { color: #a00; } + +.field-label { + text-align: right; +} + +.inline { + display: inline; +} + +.navbar { + background-color: #eee; + padding: 5px; + border: 1px solid #ccc; +} + +.big-field-label { + vertical-align: top; +} + +.description { + padding: 5px; + color: #000; +} + +.description pre { + border: 1px dashed #ccc; + background-color: #f5f5f5; +} + +.description p:first-child { + margin-top: 0px; +} + +.description p:last-child { + margin-bottom: 0px; +} + +.description table, .description td { + border-color: #666; + border-style: solid; +} + +.description table { + border-width: 0 0 1px 1px; + border-spacing: 0; + border-collapse: collapse; +} + +.description td { + margin: 0; + padding: 4px; + border-width: 1px 1px 0 0; +} + diff --git a/extra/websites/concatenative/page.xml b/extra/websites/concatenative/page.xml new file mode 100644 index 0000000000..464a3d9c5d --- /dev/null +++ b/extra/websites/concatenative/page.xml @@ -0,0 +1,28 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + From 44112e32e6d66429a0a344f56efd520b5bf5b177 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 17 Jun 2008 05:21:45 -0500 Subject: [PATCH 06/26] Fix build errors --- .../distributed/distributed-tests.factor | 10 ++- .../distributed/distributed.factor | 1 + extra/io/servers/connection/connection.factor | 4 +- extra/io/sockets/secure/secure-tests.factor | 2 +- extra/tty-server/tty-server.factor | 8 +- extra/webapps/counter/counter.factor | 2 +- .../factor-website/factor-website.factor | 73 ----------------- extra/webapps/factor-website/page.css | 78 ------------------- extra/webapps/factor-website/page.xml | 28 ------- 9 files changed, 16 insertions(+), 190 deletions(-) delete mode 100644 extra/webapps/factor-website/factor-website.factor delete mode 100644 extra/webapps/factor-website/page.css delete mode 100644 extra/webapps/factor-website/page.xml 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 c9257eb27e..9ae2627505 100755 --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -20,6 +20,7 @@ SYMBOL: local-node binary >>encoding "concurrency.distributed" >>name [ handle-node-client ] >>handler + start-server ] curry "Distributed concurrency server" spawn drop ; : start-node ( port -- ) diff --git a/extra/io/servers/connection/connection.factor b/extra/io/servers/connection/connection.factor index f01112a70f..b062322142 100755 --- a/extra/io/servers/connection/connection.factor +++ b/extra/io/servers/connection/connection.factor @@ -86,14 +86,14 @@ M: threaded-server handle-client* handler>> call ; if* ] [ accept-loop ] bi ; inline -\ accept-loop ERROR add-error-logging - : 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>> [ diff --git a/extra/io/sockets/secure/secure-tests.factor b/extra/io/sockets/secure/secure-tests.factor index 75ac39e190..78de43d379 100644 --- a/extra/io/sockets/secure/secure-tests.factor +++ b/extra/io/sockets/secure/secure-tests.factor @@ -1,4 +1,4 @@ IN: io.sockets.secure.tests -USING: io.sockets.secure tools.test ; +USING: accessors kernel io.sockets io.sockets.secure tools.test ; [ "hello" 24 ] [ "hello" 24 [ host>> ] [ port>> ] bi ] unit-test diff --git a/extra/tty-server/tty-server.factor b/extra/tty-server/tty-server.factor index e155c2068d..4ba38ad06a 100644 --- a/extra/tty-server/tty-server.factor +++ b/extra/tty-server/tty-server.factor @@ -1,4 +1,5 @@ -USING: listener io.servers.connection io.encodings.utf8 ; +USING: listener io.servers.connection io.encodings.utf8 +accessors kernel ; IN: tty-server : ( port -- ) @@ -6,8 +7,9 @@ IN: tty-server "tty-server" >>name utf8 >>encoding swap local-server >>insecure - [ listener ] >>handler ; + [ listener ] >>handler + start-server ; -: tty-server ( -- ) 9999 tty-server ; +: tty-server ( -- ) 9999 ; MAIN: tty-server 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/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor deleted file mode 100644 index c0bd856d5d..0000000000 --- a/extra/webapps/factor-website/factor-website.factor +++ /dev/null @@ -1,73 +0,0 @@ -! 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 -logging.insomniac -http.server -http.server.dispatchers -furnace.alloy -furnace.auth.login -furnace.auth.providers.db -furnace.auth.features.edit-profile -furnace.auth.features.recover-password -furnace.auth.features.registration -furnace.boilerplate -webapps.blogs -webapps.pastebin -webapps.planet -webapps.todo -webapps.wiki -webapps.wee-url -webapps.user-admin ; -IN: webapps.factor-website - -: test-db ( -- db params ) "resource:test.db" sqlite-db ; - -: init-factor-db ( -- ) - test-db [ - init-furnace-tables - - { - post comment - paste annotation - blog posting - todo - short-url - article revision - } ensure-tables - ] with-db ; - -TUPLE: factor-website < dispatcher ; - -: ( -- responder ) - factor-website new-dispatcher - "blogs" add-responder - "todo" add-responder - "pastebin" add-responder - "planet" add-responder - "wiki" add-responder - "wee-url" add-responder - "user-admin" add-responder - "Factor website" - "Factor website" >>name - allow-registration - allow-password-recovery - allow-edit-profile - - { 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 ; - -: start-factor-website ( -- ) - test-db start-expiring - test-db start-update-task - httpd-insomniac - 8812 httpd ; diff --git a/extra/webapps/factor-website/page.css b/extra/webapps/factor-website/page.css deleted file mode 100644 index 49e26883ad..0000000000 --- a/extra/webapps/factor-website/page.css +++ /dev/null @@ -1,78 +0,0 @@ -body, button { - font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif; - color:#444; -} - -.link-button { - padding: 0px; - background: none; - border: none; -} - -a, .link { - color: #222; - border-bottom:1px dotted #666; - text-decoration:none; -} - -a:hover, .link:hover { - border-bottom:1px solid #66a; -} - -.error { color: #a00; } - -.errors li { color: #a00; } - -.field-label { - text-align: right; -} - -.inline { - display: inline; -} - -.navbar { - background-color: #eee; - padding: 5px; - border: 1px solid #ccc; -} - -.big-field-label { - vertical-align: top; -} - -.description { - padding: 5px; - color: #000; -} - -.description pre { - border: 1px dashed #ccc; - background-color: #f5f5f5; -} - -.description p:first-child { - margin-top: 0px; -} - -.description p:last-child { - margin-bottom: 0px; -} - -.description table, .description td { - border-color: #666; - border-style: solid; -} - -.description table { - border-width: 0 0 1px 1px; - border-spacing: 0; - border-collapse: collapse; -} - -.description td { - margin: 0; - padding: 4px; - border-width: 1px 1px 0 0; -} - diff --git a/extra/webapps/factor-website/page.xml b/extra/webapps/factor-website/page.xml deleted file mode 100644 index 32e1223c58..0000000000 --- a/extra/webapps/factor-website/page.xml +++ /dev/null @@ -1,28 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - From 27c89d75d46120df04769c3a375a7af2aa626443 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 17 Jun 2008 05:22:33 -0500 Subject: [PATCH 07/26] I/O micro-optimizations; 12% improvement on reverse-complement --- core/io/encodings/encodings.factor | 102 ++++++++++-------- core/optimizer/known-words/known-words.factor | 20 ++-- extra/io/encodings/ascii/ascii.factor | 7 +- 3 files changed, 70 insertions(+), 59 deletions(-) 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..970b69a18a 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -9,7 +9,7 @@ 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,19 @@ 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 ; +: member-quot ( seq predicate -- newquot ) + [ curry [ dup ] prepose [ drop t ] ] curry { } map>assoc + [ drop f ] suffix [ nip cond ] curry ; -: expand-member ( #call -- ) - dup node-in-d peek value-literal member-quot f splice-quot ; +: expand-member ( #call predicate -- ) + >r dup node-in-d peek value-literal r> member-quot f splice-quot ; \ member? { - { [ dup literal-member? ] [ expand-member ] } + { [ dup literal-member? ] [ [ = ] expand-member ] } +} define-optimizers + +\ memq? { + { [ dup literal-member? ] [ [ eq? ] expand-member ] } } define-optimizers ! if the result of eq? is t and the second input is a literal, @@ -97,7 +101,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/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 From d17470b5fbf6f51f7d3f32a8f398b170e6f60e94 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 17 Jun 2008 05:25:21 -0500 Subject: [PATCH 08/26] HTTPd test fixes --- extra/http/http-tests.factor | 2 +- extra/http/server/server.factor | 6 ++++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index b5ed144579..a02382f083 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -125,7 +125,7 @@ USING: http.server http.server.static furnace.sessions furnace.alloy furnace.actions furnace.auth furnace.auth.login furnace.db http.client 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/server/server.factor b/extra/http/server/server.factor index 0312e62e8d..21ab074907 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -144,5 +144,11 @@ M: http-server handle-client* "http" protocol-port >>insecure "https" protocol-port >>secure ; +: httpd ( port -- ) + + swap >>insecure + f >>secure + start-server ; + : http-insomniac ( -- ) "http.server" { "httpd-hit" } schedule-insomniac ; From 0c0aaceedb84a947d0127a404a4bdee07b858840 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 00:32:38 -0500 Subject: [PATCH 09/26] Better compilation of member? when the sequence contains small integers only --- core/optimizer/known-words/known-words.factor | 60 +++++++++++++++---- 1 file changed, 50 insertions(+), 10 deletions(-) diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 970b69a18a..7f882d85d0 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -2,9 +2,9 @@ ! 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 @@ -59,19 +59,59 @@ sequences.private combinators byte-arrays byte-vectors ; node-in-d peek dup value? [ value-literal sequence? ] [ drop f ] if ; -: member-quot ( seq predicate -- newquot ) - [ curry [ dup ] prepose [ drop t ] ] curry { } map>assoc - [ drop f ] suffix [ nip cond ] curry ; +: expand-member ( #call quot -- ) + >r dup node-in-d peek value-literal r> call f splice-quot ; -: expand-member ( #call predicate -- ) - >r dup node-in-d peek value-literal r> 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 + ] [ + [ [ 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? ] [ [ eq? ] expand-member ] } + { [ dup literal-member? ] [ [ memq-quot ] expand-member ] } } define-optimizers ! if the result of eq? is t and the second input is a literal, From dc3929f3db12a47e20798567aba8c2754a24459b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 00:35:19 -0500 Subject: [PATCH 10/26] Improve PEG: word --- extra/peg/parsers/parsers.factor | 2 -- extra/peg/peg.factor | 25 ++++++++++++++++++------- 2 files changed, 18 insertions(+), 9 deletions(-) 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..05f84afedb 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,22 @@ 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 [ ] compiled-def [ def call compile ] | [ - call compile [ compiled-parse ] curry - [ dup [ parse-result-ast ] [ "Parse failed" throw ] if ] - append define - ] with-compilation-unit - ] 2curry over push-all ; parsing + [ + [ + dup compiled-def compiled-parse + [ ast>> ] [ word parse-failed ] ?if + ] + word swap define + ] with-compilation-unit + ] over push-all + ] ; parsing From c19d83e13f5b9330a09a7d74b5b7a01a3e403fba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 00:35:34 -0500 Subject: [PATCH 11/26] Use fry in html --- extra/html/elements/elements.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) 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 [ From 9674541cebfbb6bddfc135f3b3c9af892615236a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 00:36:20 -0500 Subject: [PATCH 12/26] New http request/response parsers using pegs --- extra/http/http-tests.factor | 49 ++++++- extra/http/http.factor | 224 ++++++++++++++---------------- extra/http/parsers/parsers.factor | 166 ++++++++++++++++++++++ 3 files changed, 315 insertions(+), 124 deletions(-) create mode 100644 extra/http/parsers/parsers.factor diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index a02382f083..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,7 +129,38 @@ 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 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 ; From 9453415eb5f9196a3a7de44dd33ae27d0efd1ebb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 00:37:04 -0500 Subject: [PATCH 13/26] https support --- extra/furnace/auth/auth.factor | 27 +++++++++++++++----- extra/furnace/auth/login/login.factor | 13 +++++++--- extra/furnace/boilerplate/boilerplate.factor | 8 +++++- extra/furnace/redirection/redirection.factor | 16 ++++++++++-- 4 files changed, 51 insertions(+), 13 deletions(-) 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/login/login.factor b/extra/furnace/auth/login/login.factor index 4c53cb9c89..68161382c1 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -39,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 ; @@ -82,7 +85,9 @@ SYMBOL: capabilities "password" value "username" value check-login [ successful-login ] [ login-failed ] if* - ] >>submit ; + ] >>submit + + ; : ( -- action ) @@ -99,6 +104,6 @@ M: login-realm login-required* : ( 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/redirection/redirection.factor b/extra/furnace/redirection/redirection.factor index 7f87c677b9..88d621b573 100644 --- a/extra/furnace/redirection/redirection.factor +++ b/extra/furnace/redirection/redirection.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors combinators namespaces +USING: kernel accessors combinators namespaces fry io.servers.connection -http http.server http.server.redirection +http http.server http.server.redirection http.server.filters furnace ; IN: furnace.redirection @@ -27,3 +27,15 @@ TUPLE: redirect-responder to ; 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 ; From 21d3380bf229ccc856b2afc4e7550d84aa6192c2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 00:50:10 -0500 Subject: [PATCH 14/26] Bootstrap fix --- core/optimizer/known-words/known-words.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 7f882d85d0..d69a2f94bc 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -98,7 +98,7 @@ sequences.private combinators byte-arrays byte-vectors ; dup bit-member? [ bit-member-quot ] [ - [ [ t ] ] { } map>assoc + [ literalize [ t ] ] { } map>assoc [ drop f ] suffix [ nip case ] curry ] if ; From 83099e01d4ecb4670c05f12e33023f211769d4f3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 00:58:29 -0500 Subject: [PATCH 15/26] Fixing PEG: --- extra/peg/peg.factor | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 05f84afedb..3d3b4ad626 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -571,14 +571,16 @@ M: parse-failed error. : PEG: (:) - [let* | def [ ] word [ ] compiled-def [ def call compile ] | + [let | word [ ] def [ ] | [ [ - [ - dup compiled-def compiled-parse - [ ast>> ] [ word parse-failed ] ?if + [let | compiled-def [ def call compile ] + [ + dup compiled-def compiled-parse + [ ast>> ] [ word parse-failed ] ?if + ] + word swap define ] - word swap define ] with-compilation-unit ] over push-all ] ; parsing From e55c674a2bf97bbf87a38aba0db752d6b03edae4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 01:18:39 -0500 Subject: [PATCH 16/26] Fix again --- extra/peg/peg.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 3d3b4ad626..54c25778de 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -571,10 +571,10 @@ M: parse-failed error. : PEG: (:) - [let | word [ ] def [ ] | + [let | def [ ] word [ ] | [ [ - [let | compiled-def [ def call compile ] + [let | compiled-def [ def call compile ] | [ dup compiled-def compiled-parse [ ast>> ] [ word parse-failed ] ?if From 6d2ded44f28c0be26dbe33bfb9231f18a1db9d85 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 01:40:48 -0500 Subject: [PATCH 17/26] Launcher fix --- extra/io/unix/launcher/launcher.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From 6aa23fd7a2c93cff05fd89c3260abc281140a14c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 01:52:50 -0500 Subject: [PATCH 18/26] Fix http.client load error' --- extra/http/client/client.factor | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) 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 ; From ef29b725b8be7927a9f112ab2b5f699ca97aa260 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 01:59:29 -0500 Subject: [PATCH 19/26] Fix ftp.server load error --- extra/ftp/server/server.factor | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) 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 ; From 1260a87468dd1a83f6d35b38d3ac60844186ad30 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 02:52:49 -0500 Subject: [PATCH 20/26] Debugging 'recover password' --- .../features/recover-password/recover-1.xml | 2 +- .../features/recover-password/recover-3.xml | 2 +- .../features/recover-password/recover-4.xml | 2 +- .../recover-password/recover-password.factor | 30 +++++++++---------- 4 files changed, 18 insertions(+), 18 deletions(-) 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 806df024f0..93b3a7ad73 100644 --- a/extra/furnace/auth/features/recover-password/recover-password.factor +++ b/extra/furnace/auth/features/recover-password/recover-password.factor @@ -1,8 +1,9 @@ ! 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 +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 @@ -13,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 ) @@ -35,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" % @@ -48,7 +48,7 @@ SYMBOL: lost-password-from : ( -- action ) - { realm "recover-1" } >>template + { realm "features/recover-password/recover-1" } >>template [ { @@ -64,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 ) @@ -80,7 +80,7 @@ SYMBOL: lost-password-from } validate-params ] >>init - { realm "recover-3" } >>template + { realm "features/recover-password/recover-3" } >>template [ { @@ -100,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* @@ -108,7 +108,7 @@ SYMBOL: lost-password-from : ( -- action ) - { realm "recover-4" } >>template ; + { realm "features/recover-password/recover-4" } >>template ; : allow-password-recovery ( login -- login ) From ef6807a4dd6786c349abb93ccbfdfb458d5a26a8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 02:54:11 -0500 Subject: [PATCH 21/26] Tweak --- extra/websites/concatenative/concatenative.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index fcf98b08da..1e79b043e2 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -63,8 +63,8 @@ TUPLE: factor-website < dispatcher ; : 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 + "noreply@concatenative.org" lost-password-from set-global + "website@concatenative.org" insomniac-sender set-global "slava@factorcode.org" insomniac-recipients set-global init-factor-db main-responder set-global ; From 9ce8116fad5a079343eebef63d0cac7176927570 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 03:16:45 -0500 Subject: [PATCH 22/26] Fix 'delete user' --- extra/webapps/user-admin/user-admin.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index 359730d4b2..f445b6f471 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -139,7 +139,7 @@ TUPLE: user-admin < dispatcher ; [ validate-username - select-tuple 1 >>deleted update-tuple + "username" value select-tuple 1 >>deleted update-tuple URL" $user-admin" ] >>submit ; From db6b24614fbfadf820a97af19a3cbc7299cf7ba4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 03:26:50 -0500 Subject: [PATCH 23/26] Improving user-admin tool --- .../deactivate-user/deactivate-user.factor | 22 +++++++++++++++++++ .../features/edit-profile/edit-profile.xml | 3 +++ .../features/registration/registration.factor | 5 +++-- extra/html/templates/chloe/chloe.factor | 5 ++--- extra/webapps/user-admin/user-admin.factor | 2 +- .../concatenative/concatenative.factor | 2 ++ 6 files changed, 33 insertions(+), 6 deletions(-) create mode 100644 extra/furnace/auth/features/deactivate-user/deactivate-user.factor 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..49fa00353b --- /dev/null +++ b/extra/furnace/auth/features/deactivate-user/deactivate-user.factor @@ -0,0 +1,22 @@ +! 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 ) + "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/registration/registration.factor b/extra/furnace/auth/features/registration/registration.factor index 5c1851fb64..20a48d07d2 100644 --- a/extra/furnace/auth/features/registration/registration.factor +++ b/extra/furnace/auth/features/registration/registration.factor @@ -35,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/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/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index f445b6f471..2137abbc2d 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -139,7 +139,7 @@ TUPLE: user-admin < dispatcher ; [ validate-username - "username" value select-tuple 1 >>deleted update-tuple + "username" value delete-tuples URL" $user-admin" ] >>submit ; diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index 1e79b043e2..a4f826d7f6 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -13,6 +13,7 @@ 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 @@ -57,6 +58,7 @@ TUPLE: factor-website < dispatcher ; allow-registration allow-password-recovery allow-edit-profile + allow-deactivation { factor-website "page" } >>template test-db ; From 5a133ceeceab676eff63174e90b6232771a576c0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 03:28:15 -0500 Subject: [PATCH 24/26] Security --- .../auth/features/deactivate-user/deactivate-user.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/furnace/auth/features/deactivate-user/deactivate-user.factor b/extra/furnace/auth/features/deactivate-user/deactivate-user.factor index 49fa00353b..cf6a56c2d4 100644 --- a/extra/furnace/auth/features/deactivate-user/deactivate-user.factor +++ b/extra/furnace/auth/features/deactivate-user/deactivate-user.factor @@ -16,7 +16,9 @@ IN: furnace.auth.features.deactivate-user ] >>submit ; : allow-deactivation ( realm -- realm ) - "deactivate-user" add-responder ; + + "delete your profile" >>description + "deactivate-user" add-responder ; : allow-deactivation? ( -- ? ) realm get responders>> "deactivate-user" swap key? ; From 4e1e14566943ec4574a498f54dd359bbe123826f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 03:40:05 -0500 Subject: [PATCH 25/26] Tweaking config some more --- .../concatenative/concatenative.factor | 30 ++++++++++++++----- 1 file changed, 22 insertions(+), 8 deletions(-) diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index a4f826d7f6..6d65f10783 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -63,19 +63,33 @@ TUPLE: factor-website < dispatcher ; { factor-website "page" } >>template test-db ; -: init-factor-website ( -- ) - "factorcode.org" 25 smtp-server set-global +SYMBOL: key-password +SYMBOL: key-file +SYMBOL: dh-file + +: 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 - init-factor-db - main-responder 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 ) - "resource:extra/openssl/test/server.pem" >>key-file - "resource:extra/openssl/test/dh1024.pem" >>dh-file - "password" >>password ; + key-file get >>key-file + dh-file get >>dh-file + key-password get >>password ; : ( -- threaded-server ) @@ -83,7 +97,7 @@ TUPLE: factor-website < dispatcher ; 8080 >>insecure 8431 >>secure ; -: start-factor-website ( -- ) +: start-website ( -- ) test-db start-expiring test-db start-update-task http-insomniac From ebb3423e4a5138c4d4985fd080278b298613a4b9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jun 2008 03:53:16 -0500 Subject: [PATCH 26/26] Fix assocs.lib tests --- extra/assocs/lib/lib-tests.factor | 4 ++++ extra/assocs/lib/lib.factor | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) create mode 100644 extra/assocs/lib/lib-tests.factor 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