Working on https server support

extra/furnace/asides/asides.factor

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

extra/furnace/auth/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

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

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs kernel namespaces validators html.forms urls
 http.server.dispatchers
-furnace furnace.auth furnace.auth.providers furnace.actions ;
+furnace furnace.auth furnace.auth.providers furnace.actions
+furnace.redirection ;
 IN: furnace.auth.features.registration
 
 : <register-action> ( -- action )

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 <flash-redirect> ;
+    URL" $realm/login" >secure-url flashed-variables <flash-redirect> ;
 
 : <login-realm> ( responder name -- auth )
     login-realm new-realm

extra/furnace/flash/flash.factor

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

extra/furnace/furnace.factor

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

extra/furnace/redirection/redirection.factor

@@ -0,0 +1,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
+
+: <redirect> ( url -- response )
+    adjust-url request get method>> {
+        { "GET" [ <temporary-redirect> ] }
+        { "HEAD" [ <temporary-redirect> ] }
+        { "POST" [ <permanent-redirect> ] }
+    } case ;
+
+: >secure-url ( url -- url' )
+    clone
+        "https" >>protocol
+        secure-port >>port ;
+
+: <secure-redirect> ( url -- response )
+    >secure-url <redirect> ;
+
+TUPLE: redirect-responder to ;
+
+: <redirect-responder> ( url -- responder )
+    redirect-responder boa ;
+
+M: redirect-responder call-responder* nip to>> <redirect> ;

extra/furnace/sessions/sessions-tests.factor

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

extra/furnace/sessions/sessions.factor

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

extra/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 ;

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
+        64 1024 * limit-input
-        ascii decode-input
-        ascii encode-output
         ?refresh-all
         read-request
         [ do-request ] ?benchmark
         [ do-response ] ?benchmark
     ] with-destructors ;
 
-: httpd ( port -- )
+: <http-server> ( -- server )
-    dup integer? [ internet-server ] when
+    http-server new-threaded-server
-    "http.server" binary [ handle-client ] with-server ;
+        "http.server" >>name
+        "http" protocol-port >>insecure
+        "https" protocol-port >>secure ;
 
-: httpd-main ( -- )
+: http-insomniac ( -- )
-    8888 httpd ;
+    "http.server" { "httpd-hit" } schedule-insomniac ;
-
-: httpd-insomniac ( -- )
-    "http.server" { httpd-hit } schedule-insomniac ;
-
-MAIN: httpd-main

extra/webapps/blogs/blogs.factor

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

extra/webapps/pastebin/pastebin.factor

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

extra/webapps/planet/planet.factor

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

extra/webapps/todo/todo.factor

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

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

@@ -12,6 +12,7 @@ furnace.auth.providers.db
 furnace.auth.login
 furnace.auth
 furnace.actions
+furnace.redirection
 furnace.utilities
 http.server
 http.server.dispatchers ;

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

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

extra/webapps/wiki/wiki.factor

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

extra/websites/concatenative/concatenative.factor

@@ -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 ;
+
+: <factor-website> ( -- responder )
+    factor-website new-dispatcher
+        <blogs> "blogs" add-responder
+        <todo-list> "todo" add-responder
+        <pastebin> "pastebin" add-responder
+        <planet-factor> "planet" add-responder
+        <wiki> "wiki" add-responder
+        <wee-url> "wee-url" add-responder
+        <user-admin> "user-admin" add-responder
+        URL" /wiki/view/Front Page" <redirect-responder> "" add-responder
+    "Factor website" <login-realm>
+        "Factor website" >>name
+        allow-registration
+        allow-password-recovery
+        allow-edit-profile
+    <boilerplate>
+        { factor-website "page" } >>template
+    test-db <alloy> ;
+
+: init-factor-website ( -- )
+    "factorcode.org" 25 <inet> 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
+    <factor-website> main-responder set-global ;
+
+: <factor-secure-config> ( -- config )
+    <secure-config>
+        "resource:extra/openssl/test/server.pem" >>key-file
+        "resource:extra/openssl/test/dh1024.pem" >>dh-file
+        "password" >>password ;
+
+: <factor-website-server> ( -- threaded-server )
+    <http-server>
+        <factor-secure-config> >>secure-config
+        8080 >>insecure
+        8431 >>secure ;
+
+: start-factor-website ( -- )
+    test-db start-expiring
+    test-db start-update-task
+    http-insomniac
+    <factor-website-server> start-server ;

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;
+}
+

extra/websites/concatenative/page.xml

@@ -0,0 +1,28 @@
+<?xml version='1.0' ?>
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+
+<html xmlns="http://www.w3.org/1999/xhtml">
+
+	<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+		<head>
+			<t:write-title />
+
+			<t:style t:include="resource:extra/xmode/code2html/stylesheet.css" />
+
+			<t:style t:include="resource:extra/websites/concatenative/page.css" />
+
+			<t:write-style />
+
+			<t:write-atom />
+		</head>
+
+		<body>
+			<t:call-next-template />
+		</body>
+
+	</t:chloe>
+
+</html>