From: Slava Pestov
Date: Thu, 4 Sep 2008 23:15:13 +0000 (-0500)
Subject: Move web framework to basis
X-Git-Tag: 0.94~2439^2~126^2~2
X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=724fae53e9701ddf60c03da7a8b8cca7313ba288
Move web framework to basis
---
diff --git a/basis/farkup/authors.txt b/basis/farkup/authors.txt
new file mode 100644
index 0000000000..5674120196
--- /dev/null
+++ b/basis/farkup/authors.txt
@@ -0,0 +1,2 @@
+Doug Coleman
+Slava Pestov
diff --git a/basis/farkup/farkup-docs.factor b/basis/farkup/farkup-docs.factor
new file mode 100644
index 0000000000..b2b662db82
--- /dev/null
+++ b/basis/farkup/farkup-docs.factor
@@ -0,0 +1,6 @@
+USING: help.markup help.syntax ;
+IN: farkup
+
+HELP: convert-farkup
+{ $values { "string" "a string" } { "string'" "a string" } }
+{ $description "Parse a string as farkup (Factor mARKUP) and output the result aas an string of HTML." } ;
diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor
new file mode 100644
index 0000000000..0f96934798
--- /dev/null
+++ b/basis/farkup/farkup-tests.factor
@@ -0,0 +1,99 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: farkup kernel peg peg.ebnf tools.test ;
+IN: farkup.tests
+
+[ ] [
+ "abcd-*strong*\nasdifj\nweouh23ouh23"
+ "paragraph" \ farkup rule parse drop
+] unit-test
+
+[ ] [
+ "abcd-*strong*\nasdifj\nweouh23ouh23\n"
+ "paragraph" \ farkup rule parse drop
+] unit-test
+
+[ "a-b
" ] [ "a-b" convert-farkup ] unit-test
+[ "*foo\nbar\n
" ] [ "*foo\nbar\n" convert-farkup ] unit-test
+[ "Wow!
" ] [ "*Wow!*" convert-farkup ] unit-test
+[ "Wow.
" ] [ "_Wow._" convert-farkup ] unit-test
+
+[ "*
" ] [ "*" convert-farkup ] unit-test
+[ "*
" ] [ "\\*" convert-farkup ] unit-test
+[ "**
" ] [ "\\**" convert-farkup ] unit-test
+
+[ "" ] [ "-a-b" convert-farkup ] unit-test
+[ "" ] [ "-foo" convert-farkup ] unit-test
+[ "" ] [ "-foo\n" convert-farkup ] unit-test
+[ "" ] [ "-foo\n-bar" convert-farkup ] unit-test
+[ "" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
+
+[ "bar\n
" ] [ "-foo\nbar\n" convert-farkup ] unit-test
+
+
+[ "\n\n" ] [ "\n\n" convert-farkup ] unit-test
+[ "\n\n" ] [ "\r\n\r\n" convert-farkup ] unit-test
+[ "\n\n\n\n" ] [ "\r\r\r\r" convert-farkup ] unit-test
+[ "\n\n\n" ] [ "\r\r\r" convert-farkup ] unit-test
+[ "\n\n\n" ] [ "\n\n\n" convert-farkup ] unit-test
+[ "foo
bar
" ] [ "foo\n\nbar" convert-farkup ] unit-test
+[ "foo
bar
" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
+[ "foo
bar
" ] [ "foo\r\rbar" convert-farkup ] unit-test
+[ "foo
bar
" ] [ "foo\r\r\nbar" convert-farkup ] unit-test
+
+[ "\nbar\n
" ] [ "\nbar\n" convert-farkup ] unit-test
+[ "\nbar\n
" ] [ "\rbar\r" convert-farkup ] unit-test
+[ "\nbar\n
" ] [ "\r\nbar\r\n" convert-farkup ] unit-test
+
+[ "foo
bar
" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
+
+[ "" ] [ "" convert-farkup ] unit-test
+
+[ "|a
" ]
+[ "|a" convert-farkup ] unit-test
+
+[ "" ]
+[ "|a|" convert-farkup ] unit-test
+
+[ "" ]
+[ "|a|b|" convert-farkup ] unit-test
+
+[ "" ]
+[ "|a|b|\n|c|d|" convert-farkup ] unit-test
+
+[ "" ]
+[ "|a|b|\n|c|d|\n" convert-farkup ] unit-test
+
+[ "foo\n
aheading
\nadfasd
" ]
+[ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test
+
+[ "foo
\n" ] [ "=foo=\n" convert-farkup ] unit-test
+[ "lol
foo
\n" ] [ "lol=foo=\n" convert-farkup ] unit-test
+[ "=foo\n
" ] [ "=foo\n" convert-farkup ] unit-test
+[ "=foo
" ] [ "=foo" convert-farkup ] unit-test
+[ "==foo
" ] [ "==foo" convert-farkup ] unit-test
+[ "=
foo
" ] [ "==foo=" convert-farkup ] unit-test
+[ "foo
" ] [ "==foo==" convert-farkup ] unit-test
+[ "foo
" ] [ "==foo==" convert-farkup ] unit-test
+[ "=
foo
" ] [ "===foo==" convert-farkup ] unit-test
+[ "foo
=
" ] [ "=foo==" convert-farkup ] unit-test
+
+[ "int main()\n
" ]
+[ "[c{int main()}]" convert-farkup ] unit-test
+
+[ "" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
+[ "" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
+[ "lol.com
" ] [ "[[lol.com]]" convert-farkup ] unit-test
+[ "haha
" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
+
+[ ] [ "[{}]" convert-farkup drop ] unit-test
+
+[ "hello\n
" ] [ "[{hello}]" convert-farkup ] unit-test
+
+[
+ "Feature comparison:\n
a | Factor | Java | Lisp |
Coolness | Yes | No | No |
Badass | Yes | No | No |
Enterprise | Yes | Yes | No |
Kosher | Yes | No | Yes |
"
+] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
+
+[
+ "Feature comparison:
a | Factor | Java | Lisp |
Coolness | Yes | No | No |
Badass | Yes | No | No |
Enterprise | Yes | Yes | No |
Kosher | Yes | No | Yes |
"
+] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor
new file mode 100644
index 0000000000..baf2ccaba2
--- /dev/null
+++ b/basis/farkup/farkup.factor
@@ -0,0 +1,180 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators html.elements io io.streams.string
+kernel math memoize namespaces peg peg.ebnf prettyprint
+sequences sequences.deep strings xml.entities vectors splitting
+xmode.code2html ;
+IN: farkup
+
+SYMBOL: relative-link-prefix
+SYMBOL: disable-images?
+SYMBOL: link-no-follow?
+
+TUPLE: heading1 obj ;
+TUPLE: heading2 obj ;
+TUPLE: heading3 obj ;
+TUPLE: heading4 obj ;
+TUPLE: strong obj ;
+TUPLE: emphasis obj ;
+TUPLE: superscript obj ;
+TUPLE: subscript obj ;
+TUPLE: inline-code obj ;
+TUPLE: paragraph obj ;
+TUPLE: list-item obj ;
+TUPLE: list obj ;
+TUPLE: table obj ;
+TUPLE: table-row obj ;
+TUPLE: link href text ;
+TUPLE: image href text ;
+TUPLE: code mode string ;
+
+EBNF: farkup
+nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
+2nl = nl nl
+
+heading1 = "=" (!("=" | nl).)+ "="
+ => [[ second >string heading1 boa ]]
+
+heading2 = "==" (!("=" | nl).)+ "=="
+ => [[ second >string heading2 boa ]]
+
+heading3 = "===" (!("=" | nl).)+ "==="
+ => [[ second >string heading3 boa ]]
+
+heading4 = "====" (!("=" | nl).)+ "===="
+ => [[ second >string heading4 boa ]]
+
+strong = "*" (!("*" | nl).)+ "*"
+ => [[ second >string strong boa ]]
+
+emphasis = "_" (!("_" | nl).)+ "_"
+ => [[ second >string emphasis boa ]]
+
+superscript = "^" (!("^" | nl).)+ "^"
+ => [[ second >string superscript boa ]]
+
+subscript = "~" (!("~" | nl).)+ "~"
+ => [[ second >string subscript boa ]]
+
+inline-code = "%" (!("%" | nl).)+ "%"
+ => [[ second >string inline-code boa ]]
+
+escaped-char = "\" . => [[ second ]]
+
+image-link = "[[image:" (!("|") .)+ "|" (!("]]").)+ "]]"
+ => [[ [ second >string ] [ fourth >string ] bi image boa ]]
+ | "[[image:" (!("]").)+ "]]"
+ => [[ second >string f image boa ]]
+
+simple-link = "[[" (!("|]" | "]]") .)+ "]]"
+ => [[ second >string dup link boa ]]
+
+labelled-link = "[[" (!("|") .)+ "|" (!("]]").)+ "]]"
+ => [[ [ second >string ] [ fourth >string ] bi link boa ]]
+
+link = image-link | labelled-link | simple-link
+
+heading = heading4 | heading3 | heading2 | heading1
+
+inline-tag = strong | emphasis | superscript | subscript | inline-code
+ | link | escaped-char
+
+inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '['
+
+table-column = (list | (!(nl | inline-delimiter | '|').)+ | inline-tag | inline-delimiter ) '|'
+ => [[ first ]]
+table-row = "|" (table-column)+
+ => [[ second table-row boa ]]
+table = ((table-row nl => [[ first ]] )+ table-row? | table-row)
+ => [[ table boa ]]
+
+paragraph-item = ( table | (!(nl | code | heading | inline-delimiter | table ).) | inline-tag | inline-delimiter)+
+paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]]
+ | (paragraph-item nl)+ paragraph-item?
+ | paragraph-item)
+ => [[ paragraph boa ]]
+
+list-item = '-' ((!(inline-delimiter | nl).)+ | inline-tag)*
+ => [[ second list-item boa ]]
+list = ((list-item nl)+ list-item? | list-item)
+ => [[ list boa ]]
+
+code = '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]"
+ => [[ [ second >string ] [ fourth >string ] bi code boa ]]
+
+stand-alone = (code | heading | list | table | paragraph | nl)*
+;EBNF
+
+
+
+: invalid-url "javascript:alert('Invalid URL in farkup');" ;
+
+: check-url ( href -- href' )
+ {
+ { [ dup empty? ] [ drop invalid-url ] }
+ { [ dup [ 127 > ] contains? ] [ drop invalid-url ] }
+ { [ dup first "/\\" member? ] [ drop invalid-url ] }
+ { [ CHAR: : over member? ] [
+ dup { "http://" "https://" "ftp://" } [ head? ] with contains?
+ [ drop invalid-url ] unless
+ ] }
+ [ relative-link-prefix get prepend ]
+ } cond ;
+
+: escape-link ( href text -- href-esc text-esc )
+ >r check-url escape-quoted-string r> escape-string ;
+
+: write-link ( text href -- )
+ escape-link
+ "" write write "" write ;
+
+: write-image-link ( href text -- )
+ disable-images? get [
+ 2drop "Images are not allowed" write
+ ] [
+ escape-link
+ >r "
+ dup empty? [ drop ] [ " alt=\"" write write "\"" write ] if
+ "/>" write
+ ] if ;
+
+: render-code ( string mode -- string' )
+ >r string-lines r>
+ [
+
+ htmlize-lines
+
+ ] with-string-writer write ;
+
+GENERIC: write-farkup ( obj -- )
+: ( string -- ) write ;
+: ( string -- ) write ;
+: in-tag. ( obj quot string -- ) [ call ] keep ; inline
+M: heading1 write-farkup ( obj -- ) [ obj>> write-farkup ] "h1" in-tag. ;
+M: heading2 write-farkup ( obj -- ) [ obj>> write-farkup ] "h2" in-tag. ;
+M: heading3 write-farkup ( obj -- ) [ obj>> write-farkup ] "h3" in-tag. ;
+M: heading4 write-farkup ( obj -- ) [ obj>> write-farkup ] "h4" in-tag. ;
+M: strong write-farkup ( obj -- ) [ obj>> write-farkup ] "strong" in-tag. ;
+M: emphasis write-farkup ( obj -- ) [ obj>> write-farkup ] "em" in-tag. ;
+M: superscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sup" in-tag. ;
+M: subscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sub" in-tag. ;
+M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ;
+M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ;
+M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ;
+M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ;
+M: link write-farkup ( obj -- ) [ text>> ] [ href>> ] bi write-link ;
+M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
+M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
+M: table-row write-farkup ( obj -- )
+ obj>> [ [ [ write-farkup ] "td" in-tag. ] each ] "tr" in-tag. ;
+M: table write-farkup ( obj -- ) [ obj>> write-farkup ] "table" in-tag. ;
+M: fixnum write-farkup ( obj -- ) write1 ;
+M: string write-farkup ( obj -- ) write ;
+M: vector write-farkup ( obj -- ) [ write-farkup ] each ;
+M: f write-farkup ( obj -- ) drop ;
+
+: convert-farkup ( string -- string' )
+ farkup [ write-farkup ] with-string-writer ;
diff --git a/basis/farkup/summary.txt b/basis/farkup/summary.txt
new file mode 100644
index 0000000000..c6e75d28a9
--- /dev/null
+++ b/basis/farkup/summary.txt
@@ -0,0 +1 @@
+Simple markup language for generating HTML
diff --git a/basis/farkup/tags.txt b/basis/farkup/tags.txt
new file mode 100644
index 0000000000..8e27be7d61
--- /dev/null
+++ b/basis/farkup/tags.txt
@@ -0,0 +1 @@
+text
diff --git a/basis/furnace/actions/actions-tests.factor b/basis/furnace/actions/actions-tests.factor
new file mode 100755
index 0000000000..60a526fb24
--- /dev/null
+++ b/basis/furnace/actions/actions-tests.factor
@@ -0,0 +1,41 @@
+USING: kernel furnace.actions validators
+tools.test math math.parser multiline namespaces http
+io.streams.string http.server sequences splitting accessors ;
+IN: furnace.actions.tests
+
+
+ [ "a" param "b" param [ string>number ] bi@ + ] >>display
+"action-1" set
+
+: lf>crlf "\n" split "\r\n" join ;
+
+STRING: action-request-test-1
+GET http://foo/bar?a=12&b=13 HTTP/1.1
+
+blah
+;
+
+[ 25 ] [
+ action-request-test-1 lf>crlf
+ [ read-request ] with-string-reader
+ init-request
+ { } "action-1" get call-responder
+] unit-test
+
+
+ "a" >>rest
+ [ "a" param string>number sq ] >>display
+"action-2" set
+
+STRING: action-request-test-2
+GET http://foo/bar/123 HTTP/1.1
+
+blah
+;
+
+[ 25 ] [
+ action-request-test-2 lf>crlf
+ [ read-request ] with-string-reader
+ init-request
+ { "5" } "action-2" get call-responder
+] unit-test
diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor
new file mode 100755
index 0000000000..d42972c360
--- /dev/null
+++ b/basis/furnace/actions/actions.factor
@@ -0,0 +1,136 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors sequences kernel assocs combinators
+validators http hashtables namespaces fry continuations locals
+io arrays math boxes splitting urls
+xml.entities
+http.server
+http.server.responses
+furnace
+furnace.redirection
+furnace.conversations
+html.forms
+html.elements
+html.components
+html.components
+html.templates.chloe
+html.templates.chloe.syntax ;
+IN: furnace.actions
+
+SYMBOL: params
+
+SYMBOL: rest
+
+: render-validation-messages ( -- )
+ form get errors>>
+ dup empty? [ drop ] [
+
+ [ - escape-string write
] each
+
+ ] if ;
+
+CHLOE: validation-messages drop render-validation-messages ;
+
+TUPLE: action rest authorize init display validate submit ;
+
+: new-action ( class -- action )
+ new [ ] >>init [ ] >>validate [ ] >>authorize ; inline
+
+: ( -- action )
+ action new-action ;
+
+: merge-forms ( form -- )
+ form get
+ [ [ errors>> ] bi@ push-all ]
+ [ [ values>> ] bi@ swap update ]
+ [ swap validation-failed>> >>validation-failed drop ]
+ 2tri ;
+
+: set-nested-form ( form name -- )
+ dup empty? [
+ drop merge-forms
+ ] [
+ unclip [ set-nested-form ] nest-form
+ ] if ;
+
+: restore-validation-errors ( -- )
+ form cget [
+ nested-forms cget set-nested-form
+ ] when* ;
+
+: handle-get ( action -- response )
+ '[
+ , dup display>> [
+ {
+ [ init>> call ]
+ [ authorize>> call ]
+ [ drop restore-validation-errors ]
+ [ display>> call ]
+ } cleave
+ ] [ drop <400> ] if
+ ] with-exit-continuation ;
+
+: param ( name -- value )
+ params get at ;
+
+: revalidate-url-key "__u" ;
+
+: revalidate-url ( -- url/f )
+ revalidate-url-key param
+ dup [ >url [ same-host? ] keep and ] when ;
+
+: validation-failed ( -- * )
+ post-request? revalidate-url and [
+ begin-conversation
+ nested-forms-key param " " split harvest nested-forms cset
+ form get form cset
+
+ ] [ <400> ] if*
+ exit-with ;
+
+: handle-post ( action -- response )
+ '[
+ , dup submit>> [
+ [ validate>> call ]
+ [ authorize>> call ]
+ [ submit>> call ]
+ tri
+ ] [ drop <400> ] if
+ ] with-exit-continuation ;
+
+: handle-rest ( path action -- assoc )
+ rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;
+
+: init-action ( path action -- )
+ begin-form
+ handle-rest
+ request get request-params assoc-union params set ;
+
+M: action call-responder* ( path action -- response )
+ [ init-action ] keep
+ request get method>> {
+ { "GET" [ handle-get ] }
+ { "HEAD" [ handle-get ] }
+ { "POST" [ handle-post ] }
+ } case ;
+
+M: action modify-form
+ drop url get revalidate-url-key hidden-form-field ;
+
+: check-validation ( -- )
+ validation-failed? [ validation-failed ] when ;
+
+: validate-params ( validators -- )
+ params get swap validate-values check-validation ;
+
+: validate-integer-id ( -- )
+ { { "id" [ v-number ] } } validate-params ;
+
+TUPLE: page-action < action template ;
+
+: ( path -- response )
+ resolve-template-path "text/html" ;
+
+: ( -- page )
+ page-action new-action
+ dup '[ , template>> ] >>display ;
diff --git a/basis/furnace/alloy/alloy.factor b/basis/furnace/alloy/alloy.factor
new file mode 100644
index 0000000000..29cb37b557
--- /dev/null
+++ b/basis/furnace/alloy/alloy.factor
@@ -0,0 +1,30 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences db.tuples alarms calendar db fry
+furnace.db
+furnace.cache
+furnace.referrer
+furnace.sessions
+furnace.conversations
+furnace.auth.providers
+furnace.auth.login.permits ;
+IN: furnace.alloy
+
+: ( responder db params -- responder' )
+ '[
+
+
+ , ,
+
+ ] call ;
+
+: state-classes { session conversation permit } ; inline
+
+: init-furnace-tables ( -- )
+ state-classes ensure-tables
+ user ensure-table ;
+
+: start-expiring ( db params -- )
+ '[
+ , , [ state-classes [ expire-state ] each ] with-db
+ ] 5 minutes every drop ;
diff --git a/basis/furnace/auth/auth-tests.factor b/basis/furnace/auth/auth-tests.factor
new file mode 100644
index 0000000000..220a8cd04c
--- /dev/null
+++ b/basis/furnace/auth/auth-tests.factor
@@ -0,0 +1,6 @@
+USING: furnace.auth tools.test ;
+IN: furnace.auth.tests
+
+\ logged-in-username must-infer
+\ must-infer
+\ new-realm must-infer
diff --git a/basis/furnace/auth/auth.factor b/basis/furnace/auth/auth.factor
new file mode 100755
index 0000000000..4487759719
--- /dev/null
+++ b/basis/furnace/auth/auth.factor
@@ -0,0 +1,167 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs namespaces kernel sequences sets
+destructors combinators fry logging
+io.encodings.utf8 io.encodings.string io.binary random
+checksums checksums.sha2
+html.forms
+http.server
+http.server.filters
+http.server.dispatchers
+furnace
+furnace.actions
+furnace.redirection
+furnace.boilerplate
+furnace.auth.providers
+furnace.auth.providers.db ;
+IN: furnace.auth
+
+SYMBOL: logged-in-user
+
+: logged-in? ( -- ? )
+ logged-in-user get >boolean ;
+
+: username ( -- string/f )
+ logged-in-user get dup [ username>> ] when ;
+
+GENERIC: init-user-profile ( responder -- )
+
+M: object init-user-profile drop ;
+
+M: dispatcher init-user-profile
+ default>> init-user-profile ;
+
+M: filter-responder init-user-profile
+ responder>> init-user-profile ;
+
+: profile ( -- assoc ) logged-in-user get profile>> ;
+
+: user-changed ( -- )
+ logged-in-user get t >>changed? drop ;
+
+: uget ( key -- value )
+ profile at ;
+
+: uset ( value key -- )
+ profile set-at
+ user-changed ;
+
+: uchange ( quot key -- )
+ profile swap change-at
+ user-changed ; inline
+
+SYMBOL: capabilities
+
+V{ } clone capabilities set-global
+
+: define-capability ( word -- ) capabilities get adjoin ;
+
+TUPLE: realm < dispatcher name users checksum secure ;
+
+GENERIC: login-required* ( description capabilities realm -- response )
+
+GENERIC: init-realm ( realm -- )
+
+GENERIC: logged-in-username ( realm -- username )
+
+: login-required ( description capabilities -- * )
+ realm get login-required* exit-with ;
+
+: new-realm ( responder name class -- realm )
+ new-dispatcher
+ swap >>name
+ swap >>default
+ users-in-db >>users
+ sha-256 >>checksum
+ t >>secure ; inline
+
+: users ( -- provider )
+ realm get users>> ;
+
+TUPLE: user-saver user ;
+
+C: user-saver
+
+M: user-saver dispose
+ user>> dup changed?>> [ users update-user ] [ drop ] if ;
+
+: save-user-after ( user -- )
+ &dispose drop ;
+
+: init-user ( user -- )
+ [ [ logged-in-user set ] [ save-user-after ] bi ] when* ;
+
+\ init-user DEBUG add-input-logging
+
+M: realm call-responder* ( path responder -- response )
+ dup realm set
+ logged-in? [
+ dup init-realm
+ dup logged-in-username
+ dup [ users get-user ] when
+ init-user
+ ] unless
+ call-next-method ;
+
+: encode-password ( string salt -- bytes )
+ [ utf8 encode ] [ 4 >be ] bi* append
+ realm get checksum>> checksum-bytes ;
+
+: >>encoded-password ( user string -- user )
+ 32 random-bits [ encode-password ] keep
+ [ >>password ] [ >>salt ] bi* ; inline
+
+: valid-login? ( password user -- ? )
+ [ salt>> encode-password ] [ password>> ] bi = ;
+
+: 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 )
+ protected new
+ swap >>responder ;
+
+: have-capabilities? ( capabilities -- ? )
+ logged-in-user get {
+ { [ dup not ] [ 2drop f ] }
+ { [ dup deleted>> 1 = ] [ 2drop f ] }
+ [ capabilities>> subset? ]
+ } cond ;
+
+M: protected call-responder* ( path responder -- response )
+ '[
+ , ,
+ dup protected set
+ dup capabilities>> have-capabilities?
+ [ call-next-method ] [
+ [ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
+ realm get login-required*
+ ] if
+ ] if-secure-realm ;
+
+: ( responder -- responder' )
+ { realm "boilerplate" } >>template ;
+
+: password-mismatch ( -- * )
+ "passwords do not match" validation-error
+ validation-failed ;
+
+: same-password-twice ( -- )
+ "new-password" value "verify-password" value =
+ [ password-mismatch ] unless ;
+
+: user-exists ( -- * )
+ "username taken" validation-error
+ validation-failed ;
diff --git a/basis/furnace/auth/basic/basic.factor b/basis/furnace/auth/basic/basic.factor
new file mode 100755
index 0000000000..ff3c302b40
--- /dev/null
+++ b/basis/furnace/auth/basic/basic.factor
@@ -0,0 +1,29 @@
+! Copyright (c) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel splitting base64 namespaces strings
+http http.server.responses furnace.auth ;
+IN: furnace.auth.basic
+
+TUPLE: basic-auth-realm < realm ;
+
+: ( responder name -- realm )
+ basic-auth-realm new-realm ;
+
+: parse-basic-auth ( header -- username/f password/f )
+ dup [
+ " " split1 swap "Basic" = [
+ base64> >string ":" split1
+ ] [ drop f f ] if
+ ] [ drop f f ] if ;
+
+: <401> ( realm -- response )
+ 401 "Invalid username or password"
+ [ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ;
+
+M: basic-auth-realm login-required* ( description capabilities realm -- response )
+ 2nip name>> <401> ;
+
+M: basic-auth-realm logged-in-username ( realm -- uid )
+ drop
+ request get "authorization" header parse-basic-auth
+ dup [ over check-login swap and ] [ 2drop f ] if ;
diff --git a/basis/furnace/auth/boilerplate.xml b/basis/furnace/auth/boilerplate.xml
new file mode 100644
index 0000000000..edc8c329df
--- /dev/null
+++ b/basis/furnace/auth/boilerplate.xml
@@ -0,0 +1,9 @@
+
+
+
+
+
+
+
+
+
diff --git a/basis/furnace/auth/features/deactivate-user/deactivate-user.factor b/basis/furnace/auth/features/deactivate-user/deactivate-user.factor
new file mode 100644
index 0000000000..43560d021c
--- /dev/null
+++ b/basis/furnace/auth/features/deactivate-user/deactivate-user.factor
@@ -0,0 +1,27 @@
+! 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.conversations
+furnace.actions
+furnace.auth
+furnace.auth.providers ;
+IN: furnace.auth.features.deactivate-user
+
+: ( -- action )
+
+ [
+ logged-in-user get
+ 1 >>deleted
+ t >>changed?
+ drop
+ URL" $realm" end-aside
+ ] >>submit ;
+
+: allow-deactivation ( realm -- realm )
+
+ "delete your profile" >>description
+ "deactivate-user" add-responder ;
+
+: allow-deactivation? ( -- ? )
+ realm get responders>> "deactivate-user" swap key? ;
diff --git a/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor b/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor
new file mode 100644
index 0000000000..d0fdf22c27
--- /dev/null
+++ b/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor
@@ -0,0 +1,4 @@
+IN: furnace.auth.features.edit-profile.tests
+USING: tools.test furnace.auth.features.edit-profile ;
+
+\ allow-edit-profile must-infer
diff --git a/basis/furnace/auth/features/edit-profile/edit-profile.factor b/basis/furnace/auth/features/edit-profile/edit-profile.factor
new file mode 100644
index 0000000000..fb4fbb898f
--- /dev/null
+++ b/basis/furnace/auth/features/edit-profile/edit-profile.factor
@@ -0,0 +1,65 @@
+! Copyright (c) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces sequences assocs
+validators urls html.forms http.server.dispatchers
+furnace.auth
+furnace.actions
+furnace.conversations ;
+IN: furnace.auth.features.edit-profile
+
+: ( -- action )
+
+ [
+ logged-in-user get
+ [ username>> "username" set-value ]
+ [ realname>> "realname" set-value ]
+ [ email>> "email" set-value ]
+ tri
+ ] >>init
+
+ { realm "features/edit-profile/edit-profile" } >>template
+
+ [
+ username "username" set-value
+
+ {
+ { "realname" [ [ v-one-line ] v-optional ] }
+ { "password" [ ] }
+ { "new-password" [ [ v-password ] v-optional ] }
+ { "verify-password" [ [ v-password ] v-optional ] }
+ { "email" [ [ v-email ] v-optional ] }
+ } validate-params
+
+ { "password" "new-password" "verify-password" }
+ [ value empty? not ] contains? [
+ "password" value username check-login
+ [ "incorrect password" validation-error ] unless
+
+ same-password-twice
+ ] when
+ ] >>validate
+
+ [
+ logged-in-user get
+
+ "new-password" value dup empty?
+ [ drop ] [ >>encoded-password ] if
+
+ "realname" value >>realname
+ "email" value >>email
+
+ t >>changed?
+
+ drop
+
+ URL" $realm" end-aside
+ ] >>submit
+
+
+ "edit your profile" >>description ;
+
+: allow-edit-profile ( login -- login )
+ "edit-profile" add-responder ;
+
+: allow-edit-profile? ( -- ? )
+ realm get responders>> "edit-profile" swap key? ;
diff --git a/basis/furnace/auth/features/edit-profile/edit-profile.xml b/basis/furnace/auth/features/edit-profile/edit-profile.xml
new file mode 100644
index 0000000000..a9d7994e97
--- /dev/null
+++ b/basis/furnace/auth/features/edit-profile/edit-profile.xml
@@ -0,0 +1,73 @@
+
+
+
+
+ Edit Profile
+
+
+
+
+
+
+ User name: |
+ |
+
+
+
+ Real name: |
+ |
+
+
+
+ |
+ Specifying a real name is optional. |
+
+
+
+ Current password: |
+ |
+
+
+
+ |
+ If you don't want to change your current password, leave this field blank. |
+
+
+
+ New password: |
+ |
+
+
+
+ Verify: |
+ |
+
+
+
+ |
+ If you are changing your password, enter it twice to ensure it is correct. |
+
+
+
+ E-mail: |
+ |
+
+
+
+ |
+ Specifying an e-mail address is optional. It enables the "recover password" feature. |
+
+
+
+
+
+
+
+
+
+
+
+
+ Delete User
+
+
diff --git a/basis/furnace/auth/features/recover-password/recover-1.xml b/basis/furnace/auth/features/recover-password/recover-1.xml
new file mode 100644
index 0000000000..46e52d5319
--- /dev/null
+++ b/basis/furnace/auth/features/recover-password/recover-1.xml
@@ -0,0 +1,39 @@
+
+
+
+
+ Recover lost password: step 1 of 4
+
+ 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.
+
+
+
+
+
+
+ User name: |
+ |
+
+
+
+ E-mail: |
+ |
+
+
+
+ Captcha: |
+ |
+
+
+
+ |
+ Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked. |
+
+
+
+
+
+
+
+
+
diff --git a/basis/furnace/auth/features/recover-password/recover-2.xml b/basis/furnace/auth/features/recover-password/recover-2.xml
new file mode 100644
index 0000000000..c7819bd21b
--- /dev/null
+++ b/basis/furnace/auth/features/recover-password/recover-2.xml
@@ -0,0 +1,9 @@
+
+
+
+
+ Recover lost password: step 2 of 4
+
+ If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.
+
+
diff --git a/basis/furnace/auth/features/recover-password/recover-3.xml b/basis/furnace/auth/features/recover-password/recover-3.xml
new file mode 100644
index 0000000000..a71118ea31
--- /dev/null
+++ b/basis/furnace/auth/features/recover-password/recover-3.xml
@@ -0,0 +1,40 @@
+
+
+
+
+ Recover lost password: step 3 of 4
+
+ Choose a new password for your account.
+
+
+
+
+
+
+
+
+
+ Password: |
+ |
+
+
+
+ Verify password: |
+ |
+
+
+
+ |
+ Enter your password twice to ensure it is correct. |
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/basis/furnace/auth/features/recover-password/recover-4.xml b/basis/furnace/auth/features/recover-password/recover-4.xml
new file mode 100755
index 0000000000..d71a01bc25
--- /dev/null
+++ b/basis/furnace/auth/features/recover-password/recover-4.xml
@@ -0,0 +1,9 @@
+
+
+
+
+ Recover lost password: step 4 of 4
+
+ Your password has been reset. You may now proceed.
+
+
diff --git a/basis/furnace/auth/features/recover-password/recover-password-tests.factor b/basis/furnace/auth/features/recover-password/recover-password-tests.factor
new file mode 100644
index 0000000000..b589c52624
--- /dev/null
+++ b/basis/furnace/auth/features/recover-password/recover-password-tests.factor
@@ -0,0 +1,4 @@
+IN: furnace.auth.features.recover-password
+USING: tools.test furnace.auth.features.recover-password ;
+
+\ allow-password-recovery must-infer
diff --git a/basis/furnace/auth/features/recover-password/recover-password.factor b/basis/furnace/auth/features/recover-password/recover-password.factor
new file mode 100644
index 0000000000..77915f1083
--- /dev/null
+++ b/basis/furnace/auth/features/recover-password/recover-password.factor
@@ -0,0 +1,124 @@
+! 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 present
+http http.server.responses http.server.redirection
+http.server.dispatchers
+furnace furnace.actions furnace.auth furnace.auth.providers
+furnace.redirection ;
+IN: furnace.auth.features.recover-password
+
+SYMBOL: lost-password-from
+
+: current-host ( -- string )
+ url get host>> host-name or ;
+
+: new-password-url ( user -- url )
+ URL" recover-3" clone
+ swap
+ [ username>> "username" set-query-param ]
+ [ ticket>> "ticket" set-query-param ]
+ bi
+ adjust-url relative-to-request ;
+
+: password-email ( user -- email )
+
+ [ "[ " % current-host % " ] password recovery" % ] "" make >>subject
+ lost-password-from get >>from
+ over email>> 1array >>to
+ [
+ "This e-mail was sent by the application server on " % current-host % "\n" %
+ "because somebody, maybe you, clicked on a ``recover password'' link in the\n" %
+ "login form, and requested a new password for the user named ``" %
+ over username>> % "''.\n" %
+ "\n" %
+ "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 present %
+ "\n\n" %
+ "Love,\n" %
+ "\n" %
+ " FactorBot\n" %
+ ] "" make >>body ;
+
+: send-password-email ( user -- )
+ '[ , password-email send-email ]
+ "E-mail send thread" spawn drop ;
+
+: ( -- action )
+
+ { realm "features/recover-password/recover-1" } >>template
+
+ [
+ {
+ { "username" [ v-username ] }
+ { "email" [ v-email ] }
+ { "captcha" [ v-captcha ] }
+ } validate-params
+ ] >>validate
+
+ [
+ "email" value "username" value
+ users issue-ticket [
+ send-password-email
+ ] when*
+
+ URL" $realm/recover-2"
+ ] >>submit ;
+
+: ( -- action )
+
+ { realm "features/recover-password/recover-2" } >>template ;
+
+: ( -- action )
+
+ [
+ {
+ { "username" [ v-username ] }
+ { "ticket" [ v-required ] }
+ } validate-params
+ ] >>init
+
+ { realm "features/recover-password/recover-3" } >>template
+
+ [
+ {
+ { "username" [ v-username ] }
+ { "ticket" [ v-required ] }
+ { "new-password" [ v-password ] }
+ { "verify-password" [ v-password ] }
+ } validate-params
+
+ same-password-twice
+ ] >>validate
+
+ [
+ "ticket" value
+ "username" value
+ users claim-ticket [
+ "new-password" value >>encoded-password
+ users update-user
+
+ URL" $realm/recover-4"
+ ] [
+ <403>
+ ] if*
+ ] >>submit ;
+
+: ( -- action )
+
+ { realm "features/recover-password/recover-4" } >>template ;
+
+: allow-password-recovery ( login -- login )
+
+ "recover-password" add-responder
+
+ "recover-2" add-responder
+
+ "recover-3" add-responder
+
+ "recover-4" add-responder ;
+
+: allow-password-recovery? ( -- ? )
+ realm get responders>> "recover-password" swap key? ;
diff --git a/basis/furnace/auth/features/registration/register.xml b/basis/furnace/auth/features/registration/register.xml
new file mode 100644
index 0000000000..9815f21945
--- /dev/null
+++ b/basis/furnace/auth/features/registration/register.xml
@@ -0,0 +1,72 @@
+
+
+
+
+ New User Registration
+
+
+
+
+
+
+ User name: |
+ |
+
+
+
+ Real name: |
+ |
+
+
+
+ |
+ Specifying a real name is optional. |
+
+
+
+ Password: |
+ |
+
+
+
+ Verify: |
+ |
+
+
+
+ |
+ Enter your password twice to ensure it is correct. |
+
+
+
+ E-mail: |
+ |
+
+
+
+ |
+ Specifying an e-mail address is optional. It enables the "recover password" feature. |
+
+
+
+ Captcha: |
+ |
+
+
+
+ |
+ Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked. |
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/basis/furnace/auth/features/registration/registration-tests.factor b/basis/furnace/auth/features/registration/registration-tests.factor
new file mode 100644
index 0000000000..e770f35586
--- /dev/null
+++ b/basis/furnace/auth/features/registration/registration-tests.factor
@@ -0,0 +1,4 @@
+IN: furnace.auth.features.registration.tests
+USING: tools.test furnace.auth.features.registration ;
+
+\ allow-registration must-infer
diff --git a/basis/furnace/auth/features/registration/registration.factor b/basis/furnace/auth/features/registration/registration.factor
new file mode 100644
index 0000000000..20a48d07d2
--- /dev/null
+++ b/basis/furnace/auth/features/registration/registration.factor
@@ -0,0 +1,45 @@
+! Copyright (c) 2008 Slava Pestov.
+! 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.redirection ;
+IN: furnace.auth.features.registration
+
+: ( -- action )
+
+ { realm "features/registration/register" } >>template
+
+ [
+ {
+ { "username" [ v-username ] }
+ { "realname" [ [ v-one-line ] v-optional ] }
+ { "new-password" [ v-password ] }
+ { "verify-password" [ v-password ] }
+ { "email" [ [ v-email ] v-optional ] }
+ { "captcha" [ v-captcha ] }
+ } validate-params
+
+ same-password-twice
+ ] >>validate
+
+ [
+ "username" value
+ "realname" value >>realname
+ "new-password" value >>encoded-password
+ "email" value >>email
+ H{ } clone >>profile
+
+ users new-user [ user-exists ] unless*
+
+ realm get init-user-profile
+
+ URL" $realm"
+ ] >>submit
+ ;
+
+: allow-registration ( login -- login )
+ "register" add-responder ;
+
+: allow-registration? ( -- ? )
+ realm get responders>> "register" swap key? ;
diff --git a/basis/furnace/auth/login/login-tests.factor b/basis/furnace/auth/login/login-tests.factor
new file mode 100755
index 0000000000..64f7bd3b96
--- /dev/null
+++ b/basis/furnace/auth/login/login-tests.factor
@@ -0,0 +1,4 @@
+IN: furnace.auth.login.tests
+USING: tools.test furnace.auth.login ;
+
+\ must-infer
diff --git a/basis/furnace/auth/login/login.factor b/basis/furnace/auth/login/login.factor
new file mode 100755
index 0000000000..1a4477023d
--- /dev/null
+++ b/basis/furnace/auth/login/login.factor
@@ -0,0 +1,104 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces sequences math.parser
+calendar validators urls logging html.forms
+http http.server http.server.dispatchers
+furnace
+furnace.auth
+furnace.actions
+furnace.sessions
+furnace.utilities
+furnace.redirection
+furnace.conversations
+furnace.auth.login.permits ;
+IN: furnace.auth.login
+
+SYMBOL: permit-id
+
+: permit-id-key ( realm -- string )
+ [ >hex 2 CHAR: 0 pad-left ] { } map-as concat
+ "__p_" prepend ;
+
+: client-permit-id ( realm -- id/f )
+ permit-id-key client-state dup [ string>number ] when ;
+
+TUPLE: login-realm < realm timeout domain ;
+
+M: login-realm init-realm
+ name>> client-permit-id permit-id set ;
+
+M: login-realm logged-in-username
+ drop permit-id get dup [ get-permit-uid ] when ;
+
+M: login-realm modify-form ( responder -- )
+ drop permit-id get realm get name>> permit-id-key hidden-form-field ;
+
+: ( -- cookie )
+ permit-id get realm get name>> permit-id-key
+ "$login-realm" resolve-base-path >>path
+ realm get
+ [ domain>> >>domain ]
+ [ secure>> >>secure ]
+ bi ;
+
+: put-permit-cookie ( response -- response' )
+ put-cookie ;
+
+\ put-permit-cookie DEBUG add-input-logging
+
+: successful-login ( user -- response )
+ [ username>> make-permit permit-id set ] [ init-user ] bi
+ URL" $realm" end-aside
+ put-permit-cookie ;
+
+\ successful-login DEBUG add-input-logging
+
+: logout ( -- )
+ permit-id get [ delete-permit ] when*
+ URL" $realm" end-aside ;
+
+SYMBOL: description
+SYMBOL: capabilities
+
+: flashed-variables { description capabilities } ;
+
+: login-failed ( -- * )
+ "invalid username or password" validation-error
+ validation-failed ;
+
+: ( -- action )
+
+ [
+ description cget "description" set-value
+ capabilities cget words>strings "capabilities" set-value
+ ] >>init
+
+ { login-realm "login" } >>template
+
+ [
+ {
+ { "username" [ v-required ] }
+ { "password" [ v-required ] }
+ } validate-params
+
+ "password" value
+ "username" value check-login
+ [ successful-login ] [ login-failed ] if*
+ ] >>submit
+
+ ;
+
+: ( -- action )
+
+ [ logout ] >>submit ;
+
+M: login-realm login-required* ( description capabilities login -- response )
+ begin-aside
+ [ description cset ] [ capabilities cset ] [ drop ] tri*
+ URL" $realm/login" >secure-url ;
+
+: ( responder name -- auth )
+ login-realm new-realm
+ "login" add-responder
+ "logout" add-responder
+ 20 minutes >>timeout ;
diff --git a/basis/furnace/auth/login/login.xml b/basis/furnace/auth/login/login.xml
new file mode 100644
index 0000000000..81f9520e76
--- /dev/null
+++ b/basis/furnace/auth/login/login.xml
@@ -0,0 +1,55 @@
+
+
+
+
+ Login
+
+
+ You must log in to .
+
+
+
+ Your user must have the following capabilities:
+
+
+
+
+
+
+
+
+ User name: |
+ |
+
+
+
+ Password: |
+ |
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ Register
+
+ |
+
+ Recover Password
+
+
+
+
diff --git a/basis/furnace/auth/login/permits/permits.factor b/basis/furnace/auth/login/permits/permits.factor
new file mode 100644
index 0000000000..1a9784f147
--- /dev/null
+++ b/basis/furnace/auth/login/permits/permits.factor
@@ -0,0 +1,30 @@
+USING: accessors namespaces kernel combinators.short-circuit
+db.tuples db.types furnace.auth furnace.sessions furnace.cache ;
+
+IN: furnace.auth.login.permits
+
+TUPLE: permit < server-state session uid ;
+
+permit "PERMITS" {
+ { "session" "SESSION" BIG-INTEGER +not-null+ }
+ { "uid" "UID" { VARCHAR 255 } +not-null+ }
+} define-persistent
+
+: touch-permit ( permit -- )
+ realm get touch-state ;
+
+: get-permit-uid ( id -- uid )
+ permit get-state {
+ [ ]
+ [ session>> session get id>> = ]
+ [ [ touch-permit ] [ uid>> ] bi ]
+ } 1&& ;
+
+: make-permit ( uid -- id )
+ permit new
+ swap >>uid
+ session get id>> >>session
+ [ touch-permit ] [ insert-tuple ] [ id>> ] tri ;
+
+: delete-permit ( id -- )
+ permit new-server-state delete-tuples ;
diff --git a/basis/furnace/auth/providers/assoc/assoc-tests.factor b/basis/furnace/auth/providers/assoc/assoc-tests.factor
new file mode 100755
index 0000000000..8fe1dd4dd4
--- /dev/null
+++ b/basis/furnace/auth/providers/assoc/assoc-tests.factor
@@ -0,0 +1,35 @@
+IN: furnace.auth.providers.assoc.tests
+USING: furnace.actions furnace.auth furnace.auth.providers
+furnace.auth.providers.assoc furnace.auth.login
+tools.test namespaces accessors kernel ;
+
+ "Test"
+ >>users
+realm set
+
+[ t ] [
+ "slava"
+ "foobar" >>encoded-password
+ "slava@factorcode.org" >>email
+ H{ } clone >>profile
+ users new-user
+ username>> "slava" =
+] unit-test
+
+[ f ] [
+ "slava"
+ H{ } clone >>profile
+ users new-user
+] unit-test
+
+[ f ] [ "fdasf" "slava" check-login >boolean ] unit-test
+
+[ ] [ "foobar" "slava" check-login "user" set ] unit-test
+
+[ t ] [ "user" get >boolean ] unit-test
+
+[ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test
+
+[ t ] [ "fdasf" "slava" check-login >boolean ] unit-test
+
+[ f ] [ "foobar" "slava" check-login >boolean ] unit-test
diff --git a/basis/furnace/auth/providers/assoc/assoc.factor b/basis/furnace/auth/providers/assoc/assoc.factor
new file mode 100755
index 0000000000..f5a79d701b
--- /dev/null
+++ b/basis/furnace/auth/providers/assoc/assoc.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: furnace.auth.providers.assoc
+USING: accessors assocs kernel furnace.auth.providers ;
+
+TUPLE: users-in-memory assoc ;
+
+: ( -- provider )
+ H{ } clone users-in-memory boa ;
+
+M: users-in-memory get-user ( username provider -- user/f )
+ assoc>> at ;
+
+M: users-in-memory update-user ( user provider -- ) 2drop ;
+
+M: users-in-memory new-user ( user provider -- user/f )
+ [ dup username>> ] dip assoc>>
+ 2dup key? [ 3drop f ] [ pick [ set-at ] dip ] if ;
diff --git a/basis/furnace/auth/providers/db/db-tests.factor b/basis/furnace/auth/providers/db/db-tests.factor
new file mode 100755
index 0000000000..fac5c23e4a
--- /dev/null
+++ b/basis/furnace/auth/providers/db/db-tests.factor
@@ -0,0 +1,46 @@
+IN: furnace.auth.providers.db.tests
+USING: furnace.actions
+furnace.auth
+furnace.auth.login
+furnace.auth.providers
+furnace.auth.providers.db tools.test
+namespaces db db.sqlite db.tuples continuations
+io.files accessors kernel ;
+
+ "test" realm set
+
+[ "auth-test.db" temp-file delete-file ] ignore-errors
+
+"auth-test.db" temp-file sqlite-db [
+
+ user ensure-table
+
+ [ t ] [
+ "slava"
+ "foobar" >>encoded-password
+ "slava@factorcode.org" >>email
+ H{ } clone >>profile
+ users new-user
+ username>> "slava" =
+ ] unit-test
+
+ [ f ] [
+ "slava"
+ H{ } clone >>profile
+ users new-user
+ ] unit-test
+
+ [ f ] [ "fdasf" "slava" check-login >boolean ] unit-test
+
+ [ ] [ "foobar" "slava" check-login "user" set ] unit-test
+
+ [ t ] [ "user" get >boolean ] unit-test
+
+ [ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test
+
+ [ ] [ "user" get users update-user ] unit-test
+
+ [ t ] [ "fdasf" "slava" check-login >boolean ] unit-test
+
+ [ f ] [ "foobar" "slava" check-login >boolean ] unit-test
+] with-db
diff --git a/basis/furnace/auth/providers/db/db.factor b/basis/furnace/auth/providers/db/db.factor
new file mode 100755
index 0000000000..72eb0d462a
--- /dev/null
+++ b/basis/furnace/auth/providers/db/db.factor
@@ -0,0 +1,39 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db db.tuples db.types accessors
+furnace.auth.providers kernel continuations
+classes.singleton ;
+IN: furnace.auth.providers.db
+
+user "USERS"
+{
+ { "username" "USERNAME" { VARCHAR 256 } +user-assigned-id+ }
+ { "realname" "REALNAME" { VARCHAR 256 } }
+ { "password" "PASSWORD" BLOB +not-null+ }
+ { "salt" "SALT" INTEGER +not-null+ }
+ { "email" "EMAIL" { VARCHAR 256 } }
+ { "ticket" "TICKET" { VARCHAR 256 } }
+ { "capabilities" "CAPABILITIES" FACTOR-BLOB }
+ { "profile" "PROFILE" FACTOR-BLOB }
+ { "deleted" "DELETED" INTEGER +not-null+ }
+} define-persistent
+
+SINGLETON: users-in-db
+
+M: users-in-db get-user
+ drop select-tuple ;
+
+M: users-in-db new-user
+ drop
+ [
+ user new
+ over username>> >>username
+ select-tuple [
+ drop f
+ ] [
+ dup insert-tuple
+ ] if
+ ] with-transaction ;
+
+M: users-in-db update-user
+ drop update-tuple ;
diff --git a/basis/furnace/auth/providers/null/null.factor b/basis/furnace/auth/providers/null/null.factor
new file mode 100755
index 0000000000..39ea812ae7
--- /dev/null
+++ b/basis/furnace/auth/providers/null/null.factor
@@ -0,0 +1,14 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: furnace.auth.providers kernel ;
+IN: furnace.auth.providers.null
+
+TUPLE: no-users ;
+
+: no-users T{ no-users } ;
+
+M: no-users get-user 2drop f ;
+
+M: no-users new-user 2drop f ;
+
+M: no-users update-user 2drop ;
diff --git a/basis/furnace/auth/providers/providers.factor b/basis/furnace/auth/providers/providers.factor
new file mode 100755
index 0000000000..1933fc8c59
--- /dev/null
+++ b/basis/furnace/auth/providers/providers.factor
@@ -0,0 +1,50 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors random math.parser locals
+sequences math ;
+IN: furnace.auth.providers
+
+TUPLE: user
+username realname
+password salt
+email ticket capabilities profile deleted changed? ;
+
+: ( username -- user )
+ user new
+ swap >>username
+ 0 >>deleted ;
+
+GENERIC: get-user ( username provider -- user/f )
+
+GENERIC: update-user ( user provider -- )
+
+GENERIC: new-user ( user provider -- user/f )
+
+! Password recovery support
+
+:: issue-ticket ( email username provider -- user/f )
+ [let | user [ username provider get-user ] |
+ user [
+ user email>> length 0 > [
+ user email>> email = [
+ user
+ 256 random-bits >hex >>ticket
+ dup provider update-user
+ ] [ f ] if
+ ] [ f ] if
+ ] [ f ] if
+ ] ;
+
+:: claim-ticket ( ticket username provider -- user/f )
+ [let | user [ username provider get-user ] |
+ user [
+ user ticket>> ticket = [
+ user f >>ticket dup provider update-user
+ ] [ f ] if
+ ] [ f ] if
+ ] ;
+
+! For configuration
+
+: add-user ( provider user -- provider )
+ over new-user [ "User exists" throw ] when ;
diff --git a/basis/furnace/boilerplate/boilerplate.factor b/basis/furnace/boilerplate/boilerplate.factor
new file mode 100644
index 0000000000..59f71b1524
--- /dev/null
+++ b/basis/furnace/boilerplate/boilerplate.factor
@@ -0,0 +1,37 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math.order namespaces furnace combinators.short-circuit
+html.forms
+html.templates
+html.templates.chloe
+locals
+http.server
+http.server.filters ;
+IN: furnace.boilerplate
+
+TUPLE: boilerplate < filter-responder template init ;
+
+: ( responder -- boilerplate )
+ boilerplate new
+ 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
+ responder init>> call
+ dup content-type>> "text/html" = [
+ clone [| body |
+ [
+ body
+ responder template>> resolve-template-path
+ with-boilerplate
+ ]
+ ] change-body
+ ] when ;
diff --git a/basis/furnace/cache/cache.factor b/basis/furnace/cache/cache.factor
new file mode 100644
index 0000000000..a5308c171e
--- /dev/null
+++ b/basis/furnace/cache/cache.factor
@@ -0,0 +1,36 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors math.intervals
+system calendar alarms fry
+random db db.tuples db.types
+http.server.filters ;
+IN: furnace.cache
+
+TUPLE: server-state id expires ;
+
+: new-server-state ( id class -- server-state )
+ new swap >>id ; inline
+
+server-state f
+{
+ { "id" "ID" +random-id+ system-random-generator }
+ { "expires" "EXPIRES" BIG-INTEGER +not-null+ }
+} define-persistent
+
+: get-state ( id class -- state )
+ new-server-state select-tuple ;
+
+: expire-state ( class -- )
+ new
+ -1.0/0.0 millis [a,b] >>expires
+ delete-tuples ;
+
+TUPLE: server-state-manager < filter-responder timeout ;
+
+: new-server-state-manager ( responder class -- responder' )
+ new
+ swap >>responder
+ 20 minutes >>timeout ; inline
+
+: touch-state ( state manager -- )
+ timeout>> hence timestamp>millis >>expires drop ;
diff --git a/basis/furnace/conversations/conversations.factor b/basis/furnace/conversations/conversations.factor
new file mode 100644
index 0000000000..7216978110
--- /dev/null
+++ b/basis/furnace/conversations/conversations.factor
@@ -0,0 +1,178 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs kernel sequences accessors hashtables
+urls db.types db.tuples math.parser fry logging combinators
+html.templates.chloe.syntax
+http http.server http.server.filters http.server.redirection
+furnace
+furnace.cache
+furnace.scopes
+furnace.sessions
+furnace.redirection ;
+IN: furnace.conversations
+
+TUPLE: conversation < scope
+session
+method url post-data ;
+
+: ( id -- aside )
+ conversation new-server-state ;
+
+conversation "CONVERSATIONS" {
+ { "session" "SESSION" BIG-INTEGER +not-null+ }
+ { "method" "METHOD" { VARCHAR 10 } }
+ { "url" "URL" URL }
+ { "post-data" "POST_DATA" FACTOR-BLOB }
+} define-persistent
+
+: conversation-id-key "__c" ;
+
+TUPLE: conversations < server-state-manager ;
+
+: ( responder -- responder' )
+ conversations new-server-state-manager ;
+
+SYMBOL: conversation
+
+SYMBOL: conversation-id
+
+: cget ( key -- value )
+ conversation get scope-get ;
+
+: cset ( value key -- )
+ conversation get scope-set ;
+
+: cchange ( key quot -- )
+ conversation get scope-change ; inline
+
+: get-conversation ( id -- conversation )
+ dup [ conversation get-state ] when
+ dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
+
+: request-conversation-id ( request -- id )
+ conversation-id-key swap request-params at string>number ;
+
+: request-conversation ( request -- conversation )
+ request-conversation-id get-conversation ;
+
+: save-conversation-after ( conversation -- )
+ conversations get save-scope-after ;
+
+: set-conversation ( conversation -- )
+ [
+ [ conversation set ]
+ [ id>> conversation-id set ]
+ [ save-conversation-after ]
+ tri
+ ] when* ;
+
+: init-conversations ( conversations -- )
+ conversations set
+ request get request-conversation-id
+ get-conversation
+ set-conversation ;
+
+M: conversations call-responder*
+ [ init-conversations ]
+ [ conversations set ]
+ [ call-next-method ]
+ tri ;
+
+: empty-conversastion ( -- conversation )
+ conversation empty-scope
+ session get id>> >>session ;
+
+: touch-conversation ( conversation -- )
+ conversations get touch-state ;
+
+: add-conversation ( conversation -- )
+ [ touch-conversation ] [ insert-tuple ] bi ;
+
+: begin-conversation* ( -- conversation )
+ empty-conversastion dup add-conversation ;
+
+: begin-conversation ( -- )
+ conversation get [
+ begin-conversation*
+ set-conversation
+ ] unless ;
+
+: end-conversation ( -- )
+ conversation off
+ conversation-id off ;
+
+: ( url seq -- response )
+ begin-conversation
+ [ [ get ] keep cset ] each
+ ;
+
+: restore-conversation ( seq -- )
+ conversation get dup [
+ namespace>>
+ [ '[ , key? ] filter ]
+ [ '[ [ , at ] keep set ] each ]
+ bi
+ ] [ 2drop ] if ;
+
+: begin-aside ( -- )
+ begin-conversation
+ conversation get
+ request get
+ [ method>> >>method ]
+ [ url>> >>url ]
+ [ post-data>> >>post-data ]
+ tri
+ touch-conversation ;
+
+: end-aside-post ( aside -- response )
+ request [
+ clone
+ over post-data>> >>post-data
+ over url>> >>url
+ ] change
+ url>> path>> split-path
+ conversations get responder>> call-responder ;
+
+\ end-aside-post DEBUG add-input-logging
+
+ERROR: end-aside-in-get-error ;
+
+: move-on ( id -- response )
+ post-request? [ end-aside-in-get-error ] unless
+ dup method>> {
+ { "GET" [ url>> ] }
+ { "HEAD" [ url>> ] }
+ { "POST" [ end-aside-post ] }
+ } case ;
+
+: get-aside ( id -- conversation )
+ get-conversation dup [ dup method>> [ drop f ] unless ] when ;
+
+: end-aside* ( url id -- response )
+ get-aside [ move-on ] [ ] ?if ;
+
+: end-aside ( default -- response )
+ conversation-id get
+ end-conversation
+ end-aside* ;
+
+M: conversations link-attr ( tag -- )
+ drop
+ "aside" optional-attr {
+ { "none" [ conversation-id off ] }
+ { "begin" [ begin-aside ] }
+ { "current" [ ] }
+ { f [ ] }
+ } case ;
+
+M: conversations modify-query ( query conversations -- query' )
+ drop
+ conversation-id get [
+ conversation-id-key associate assoc-union
+ ] when* ;
+
+M: conversations modify-form ( conversations -- )
+ drop
+ conversation-id get
+ conversation-id-key
+ hidden-form-field ;
diff --git a/basis/furnace/db/db-tests.factor b/basis/furnace/db/db-tests.factor
new file mode 100644
index 0000000000..34357ae701
--- /dev/null
+++ b/basis/furnace/db/db-tests.factor
@@ -0,0 +1,4 @@
+IN: furnace.db.tests
+USING: tools.test furnace.db ;
+
+\ must-infer
diff --git a/basis/furnace/db/db.factor b/basis/furnace/db/db.factor
new file mode 100755
index 0000000000..b4a4386015
--- /dev/null
+++ b/basis/furnace/db/db.factor
@@ -0,0 +1,17 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors continuations namespaces destructors
+db db.pools io.pools http.server http.server.filters ;
+IN: furnace.db
+
+TUPLE: db-persistence < filter-responder pool ;
+
+: ( responder params db -- responder' )
+ db-persistence boa ;
+
+M: db-persistence call-responder*
+ [
+ pool>> [ acquire-connection ] keep
+ [ return-connection-later ] [ drop db set ] 2bi
+ ]
+ [ call-next-method ] bi ;
diff --git a/basis/furnace/furnace-tests.factor b/basis/furnace/furnace-tests.factor
new file mode 100644
index 0000000000..223b20455d
--- /dev/null
+++ b/basis/furnace/furnace-tests.factor
@@ -0,0 +1,35 @@
+IN: furnace.tests
+USING: http.server.dispatchers http.server.responses
+http.server furnace tools.test kernel namespaces accessors
+io.streams.string ;
+TUPLE: funny-dispatcher < dispatcher ;
+
+: funny-dispatcher new-dispatcher ;
+
+TUPLE: base-path-check-responder ;
+
+C: base-path-check-responder
+
+M: base-path-check-responder call-responder*
+ 2drop
+ "$funny-dispatcher" resolve-base-path
+ "text/plain" ;
+
+[ ] [
+
+
+
+ "c" add-responder
+ "b" add-responder
+ "a" add-responder
+ main-responder set
+] unit-test
+
+[ "/a/b/" ] [
+ V{ } responder-nesting set
+ "a/b/c" split-path main-responder get call-responder body>>
+] unit-test
+
+[ "" ]
+[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
+unit-test
diff --git a/basis/furnace/furnace.factor b/basis/furnace/furnace.factor
new file mode 100644
index 0000000000..fadd398882
--- /dev/null
+++ b/basis/furnace/furnace.factor
@@ -0,0 +1,208 @@
+! Copyright (C) 2003, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel combinators assocs
+continuations namespaces sequences splitting words
+vocabs.loader classes strings
+fry urls multiline present
+xml
+xml.data
+xml.entities
+xml.writer
+html.components
+html.elements
+html.forms
+html.templates
+html.templates.chloe
+html.templates.chloe.syntax
+http
+http.server
+http.server.redirection
+http.server.responses
+qualified ;
+QUALIFIED-WITH: assocs a
+EXCLUDE: xml.utilities => children>string ;
+IN: furnace
+
+: nested-responders ( -- seq )
+ responder-nesting get a:values ;
+
+: each-responder ( quot -- )
+ nested-responders swap each ; inline
+
+: base-path ( string -- pair )
+ dup responder-nesting get
+ [ second class superclasses [ name>> = ] with contains? ] with find nip
+ [ first ] [ "No such responder: " swap append throw ] ?if ;
+
+: resolve-base-path ( string -- string' )
+ "$" ?head [
+ [
+ "/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
+ ] "" make
+ ] when ;
+
+: vocab-path ( vocab -- path )
+ dup vocab-dir vocab-append-path ;
+
+: resolve-template-path ( pair -- path )
+ [
+ first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi*
+ ] "" make ;
+
+GENERIC: modify-query ( query responder -- query' )
+
+M: object modify-query drop ;
+
+GENERIC: adjust-url ( url -- url' )
+
+M: url adjust-url
+ clone
+ [ [ modify-query ] each-responder ] change-query
+ [ resolve-base-path ] change-path
+ relative-to-request ;
+
+M: string adjust-url ;
+
+GENERIC: modify-form ( responder -- )
+
+M: object modify-form drop ;
+
+: request-params ( request -- assoc )
+ dup method>> {
+ { "GET" [ url>> query>> ] }
+ { "HEAD" [ url>> query>> ] }
+ { "POST" [
+ post-data>>
+ dup content-type>> "application/x-www-form-urlencoded" =
+ [ content>> ] [ drop f ] if
+ ] }
+ } case ;
+
+: referrer ( -- referrer )
+ #! Typo is intentional, its in the HTTP spec!
+ "referer" request get header>> at >url ;
+
+: user-agent ( -- user-agent )
+ "user-agent" request get header>> at "" or ;
+
+: same-host? ( url -- ? )
+ url get
+ [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
+
+: cookie-client-state ( key request -- value/f )
+ swap get-cookie dup [ value>> ] when ;
+
+: post-client-state ( key request -- value/f )
+ request-params at ;
+
+: client-state ( key -- value/f )
+ request get dup method>> {
+ { "GET" [ cookie-client-state ] }
+ { "HEAD" [ cookie-client-state ] }
+ { "POST" [ post-client-state ] }
+ } case ;
+
+SYMBOL: exit-continuation
+
+: exit-with ( value -- )
+ exit-continuation get continue-with ;
+
+: with-exit-continuation ( quot -- )
+ '[ exit-continuation set @ ] callcc1 exit-continuation off ;
+
+! Chloe tags
+: parse-query-attr ( string -- assoc )
+ dup empty?
+ [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
+
+: a-url-path ( tag -- string )
+ [ "href" required-attr ]
+ [ "rest" optional-attr dup [ value ] when ] bi
+ [ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
+
+: a-url ( tag -- url )
+ dup "value" optional-attr
+ [ value ] [
+
+ swap
+ [ a-url-path >>path ]
+ [ "query" optional-attr parse-query-attr >>query ]
+ bi
+ adjust-url relative-to-request
+ ] ?if ;
+
+CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ;
+
+CHLOE: write-atom drop write-atom-feeds ;
+
+GENERIC: link-attr ( tag responder -- )
+
+M: object link-attr 2drop ;
+
+: link-attrs ( tag -- )
+ #! Side-effects current namespace.
+ '[ , _ link-attr ] each-responder ;
+
+: a-start-tag ( tag -- )
+ [ ] with-scope ;
+
+CHLOE: a
+ [ a-start-tag ]
+ [ process-tag-children ]
+ [ drop ]
+ tri ;
+
+: hidden-form-field ( value name -- )
+ over [
+
+ ] [ 2drop ] if ;
+
+: nested-forms-key "__n" ;
+
+: form-magic ( tag -- )
+ [ modify-form ] each-responder
+ nested-forms get " " join f like nested-forms-key hidden-form-field
+ "for" optional-attr [ "," split [ hidden render ] each ] when* ;
+
+: form-start-tag ( tag -- )
+ [
+ [
+ ]
+ tri ;
+
+STRING: button-tag-markup
+
+
+
+;
+
+: add-tag-attrs ( attrs tag -- )
+ attrs>> swap update ;
+
+CHLOE: button
+ button-tag-markup string>xml body>>
+ {
+ [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
+ [ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
+ [ [ children>string 1array ] dip "button" tag-named (>>children) ]
+ [ nip ]
+ } 2cleave process-chloe-tag ;
diff --git a/basis/furnace/json/json.factor b/basis/furnace/json/json.factor
new file mode 100644
index 0000000000..a5188cd355
--- /dev/null
+++ b/basis/furnace/json/json.factor
@@ -0,0 +1,7 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: json.writer http.server.responses ;
+IN: furnace.json
+
+: ( body -- response )
+ >json "application/json" ;
diff --git a/basis/furnace/redirection/redirection.factor b/basis/furnace/redirection/redirection.factor
new file mode 100644
index 0000000000..83941cd08f
--- /dev/null
+++ b/basis/furnace/redirection/redirection.factor
@@ -0,0 +1,41 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors combinators namespaces fry
+io.servers.connection urls
+http http.server http.server.redirection http.server.filters
+furnace ;
+IN: furnace.redirection
+
+: ( url -- response )
+ adjust-url request get method>> {
+ { "GET" [ ] }
+ { "HEAD" [ ] }
+ { "POST" [ ] }
+ } case ;
+
+: >secure-url ( url -- url' )
+ clone
+ "https" >>protocol
+ secure-port >>port ;
+
+: ( url -- response )
+ >secure-url ;
+
+TUPLE: redirect-responder to ;
+
+: ( url -- responder )
+ redirect-responder boa ;
+
+M: redirect-responder call-responder* nip to>> ;
+
+TUPLE: secure-only < filter-responder ;
+
+C: secure-only
+
+: if-secure ( quot -- )
+ >r url get protocol>> "http" =
+ [ url get ]
+ r> if ; inline
+
+M: secure-only call-responder*
+ '[ , , call-next-method ] if-secure ;
diff --git a/basis/furnace/referrer/referrer.factor b/basis/furnace/referrer/referrer.factor
new file mode 100644
index 0000000000..56777676fc
--- /dev/null
+++ b/basis/furnace/referrer/referrer.factor
@@ -0,0 +1,16 @@
+USING: accessors kernel
+http.server http.server.filters http.server.responses
+furnace ;
+IN: furnace.referrer
+
+TUPLE: referrer-check < filter-responder quot ;
+
+C: referrer-check
+
+M: referrer-check call-responder*
+ referrer over quot>> call
+ [ call-next-method ]
+ [ 2drop 403 "Bad referrer" ] if ;
+
+: ( responder -- responder' )
+ [ same-host? post-request? not or ] ;
diff --git a/basis/furnace/scopes/scopes.factor b/basis/furnace/scopes/scopes.factor
new file mode 100644
index 0000000000..daad0dcf91
--- /dev/null
+++ b/basis/furnace/scopes/scopes.factor
@@ -0,0 +1,42 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors assocs destructors
+db.tuples db.types furnace.cache ;
+IN: furnace.scopes
+
+TUPLE: scope < server-state namespace changed? ;
+
+: empty-scope ( class -- scope )
+ f swap new-server-state
+ H{ } clone >>namespace ; inline
+
+scope f
+{
+ { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
+} define-persistent
+
+: scope-changed ( scope -- )
+ t >>changed? drop ;
+
+: scope-get ( key scope -- value )
+ dup [ namespace>> at ] [ 2drop f ] if ;
+
+: scope-set ( value key scope -- )
+ [ namespace>> set-at ] [ scope-changed ] bi ;
+
+: scope-change ( key quot scope -- )
+ [ namespace>> swap change-at ] [ scope-changed ] bi ; inline
+
+! Destructor
+TUPLE: scope-saver scope manager ;
+
+C: scope-saver
+
+M: scope-saver dispose
+ [ manager>> ] [ scope>> ] bi
+ dup changed?>> [
+ [ swap touch-state ] [ update-tuple ] bi
+ ] [ 2drop ] if ;
+
+: save-scope-after ( scope manager -- )
+ &dispose drop ;
diff --git a/basis/furnace/sessions/authors.txt b/basis/furnace/sessions/authors.txt
new file mode 100755
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/basis/furnace/sessions/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/basis/furnace/sessions/sessions-tests.factor b/basis/furnace/sessions/sessions-tests.factor
new file mode 100755
index 0000000000..98d1bbdfc9
--- /dev/null
+++ b/basis/furnace/sessions/sessions-tests.factor
@@ -0,0 +1,154 @@
+IN: furnace.sessions.tests
+USING: tools.test http furnace.sessions
+furnace.actions http.server http.server.responses
+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 ;
+
+: with-session
+ [
+ [ [ save-session-after ] [ session set ] bi ] dip call
+ ] with-destructors ; inline
+
+TUPLE: foo ;
+
+C: foo
+
+M: foo init-session* drop 0 "x" sset ;
+
+M: foo call-responder*
+ 2drop
+ "x" [ 1+ ] schange
+ "x" sget number>string "text/html" ;
+
+: url-responder-mock-test
+ [
+
+ "GET" >>method
+ dup url>>
+ "id" get session-id-key set-query-param
+ "/" >>path drop
+ init-request
+ { } sessions get call-responder
+ [ write-response-body drop ] with-string-writer
+ ] with-destructors ;
+
+: sessions-mock-test
+ [
+
+ "GET" >>method
+ "cookies" get >>cookies
+ dup url>> "/" >>path drop
+ init-request
+ { } sessions get call-responder
+ [ write-response-body drop ] with-string-writer
+ ] with-destructors ;
+
+:
+
+ [ [ ] "text/plain" exit-with ] >>display ;
+
+[ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors
+
+"auth-test.db" temp-file sqlite-db [
+
+ init-request
+ session ensure-table
+
+ "127.0.0.1" 1234 remote-address set
+
+ [ ] [
+
+ sessions set
+ ] unit-test
+
+ [
+ [ ] [
+ empty-session
+ 123 >>id session set
+ ] unit-test
+
+ [ ] [ 3 "x" sset ] unit-test
+
+ [ 9 ] [ "x" sget sq ] unit-test
+
+ [ ] [ "x" [ 1- ] schange ] unit-test
+
+ [ 4 ] [ "x" sget sq ] unit-test
+
+ [ t ] [ session get changed?>> ] unit-test
+ ] with-scope
+
+ [ t ] [
+ begin-session id>>
+ get-session session?
+ ] unit-test
+
+ [ { 5 0 } ] [
+ [
+ begin-session
+ dup [ 5 "a" sset ] with-session
+ dup [ "a" sget , ] with-session
+ dup [ "x" sget , ] with-session
+ drop
+ ] { } make
+ ] unit-test
+
+ [ 0 ] [
+ begin-session id>>
+ get-session [ "x" sget ] with-session
+ ] unit-test
+
+ [ { 5 0 } ] [
+ [
+ begin-session id>>
+ dup get-session [ 5 "a" sset ] with-session
+ dup get-session [ "a" sget , ] with-session
+ dup get-session [ "x" sget , ] with-session
+ drop
+ ] { } make
+ ] unit-test
+
+ [ ] [
+
+ sessions set
+ ] unit-test
+
+ [
+
+ "GET" >>method
+ dup url>> "/" >>path drop
+ request set
+ { "etc" } sessions get call-responder response set
+ [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
+ response get
+ ] with-destructors
+ response set
+
+ [ ] [ response get cookies>> "cookies" set ] unit-test
+
+ [ "2" ] [ sessions-mock-test ] unit-test
+ [ "3" ] [ sessions-mock-test ] unit-test
+ [ "4" ] [ sessions-mock-test ] unit-test
+
+ [
+ [ ] [
+
+ "GET" >>method
+ dup url>>
+ "id" get session-id-key set-query-param
+ "/" >>path drop
+ request set
+
+ [
+ { }
+ call-responder
+ ] with-destructors response set
+ ] unit-test
+
+ [ "text/plain" ] [ response get content-type>> ] unit-test
+
+ [ f ] [ response get cookies>> empty? ] unit-test
+ ] with-scope
+] with-db
diff --git a/basis/furnace/sessions/sessions.factor b/basis/furnace/sessions/sessions.factor
new file mode 100755
index 0000000000..718953c58c
--- /dev/null
+++ b/basis/furnace/sessions/sessions.factor
@@ -0,0 +1,109 @@
+! Copyright (C) 2008 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs kernel math.intervals math.parser namespaces
+strings random accessors quotations hashtables sequences continuations
+fry calendar combinators combinators.short-circuit destructors alarms
+io.servers.connection
+db db.tuples db.types
+http http.server http.server.dispatchers http.server.filters
+html.elements
+furnace furnace.cache furnace.scopes ;
+IN: furnace.sessions
+
+TUPLE: session < scope user-agent client ;
+
+: ( id -- session )
+ session new-server-state ;
+
+session "SESSIONS"
+{
+ { "user-agent" "USER_AGENT" TEXT +not-null+ }
+ { "client" "CLIENT" TEXT +not-null+ }
+} define-persistent
+
+: get-session ( id -- session )
+ dup [ session get-state ] when ;
+
+GENERIC: init-session* ( responder -- )
+
+M: object init-session* drop ;
+
+M: dispatcher init-session* default>> init-session* ;
+
+M: filter-responder init-session* responder>> init-session* ;
+
+TUPLE: sessions < server-state-manager domain verify? ;
+
+: ( responder -- responder' )
+ sessions new-server-state-manager
+ t >>verify? ;
+
+: session-changed ( -- )
+ session get scope-changed ;
+
+: sget ( key -- value ) session get scope-get ;
+
+: sset ( value key -- ) session get scope-set ;
+
+: schange ( key quot -- ) session get scope-change ; inline
+
+: init-session ( session -- )
+ session [ sessions get init-session* ] with-variable ;
+
+: touch-session ( session -- )
+ sessions get touch-state ;
+
+: remote-host ( -- string )
+ {
+ [ request get "x-forwarded-for" header ]
+ [ remote-address get host>> ]
+ } 0|| ;
+
+: empty-session ( -- session )
+ session empty-scope
+ remote-host >>client
+ user-agent >>user-agent
+ dup touch-session ;
+
+: begin-session ( -- session )
+ empty-session [ init-session ] [ insert-tuple ] [ ] tri ;
+
+: save-session-after ( session -- )
+ sessions get save-scope-after ;
+
+: existing-session ( path session -- response )
+ [ session set ] [ save-session-after ] bi
+ sessions get responder>> call-responder ;
+
+: session-id-key "__s" ;
+
+: verify-session ( session -- session )
+ sessions get verify?>> [
+ dup [
+ dup
+ [ client>> remote-host = ]
+ [ user-agent>> user-agent = ]
+ bi and [ drop f ] unless
+ ] when
+ ] when ;
+
+: request-session ( -- session/f )
+ session-id-key
+ client-state dup string? [ string>number ] when
+ get-session verify-session ;
+
+: ( -- cookie )
+ session get id>> session-id-key
+ "$sessions" resolve-base-path >>path
+ sessions get domain>> >>domain ;
+
+: put-session-cookie ( response -- response' )
+ put-cookie ;
+
+M: sessions modify-form ( responder -- )
+ drop session get id>> session-id-key hidden-form-field ;
+
+M: sessions call-responder* ( path responder -- response )
+ sessions set
+ request-session [ begin-session ] unless*
+ existing-session put-session-cookie ;
diff --git a/basis/furnace/syndication/syndication.factor b/basis/furnace/syndication/syndication.factor
new file mode 100644
index 0000000000..31a978aef3
--- /dev/null
+++ b/basis/furnace/syndication/syndication.factor
@@ -0,0 +1,53 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences fry
+combinators syndication
+http.server.responses http.server.redirection
+furnace furnace.actions ;
+IN: furnace.syndication
+
+GENERIC: feed-entry-title ( object -- string )
+
+GENERIC: feed-entry-date ( object -- timestamp )
+
+GENERIC: feed-entry-url ( object -- url )
+
+GENERIC: feed-entry-description ( object -- description )
+
+M: object feed-entry-description drop f ;
+
+GENERIC: >entry ( object -- entry )
+
+M: entry >entry ;
+
+M: object >entry
+
+ swap {
+ [ feed-entry-title >>title ]
+ [ feed-entry-date >>date ]
+ [ feed-entry-url >>url ]
+ [ feed-entry-description >>description ]
+ } cleave ;
+
+: process-entries ( seq -- seq' )
+ 20 short head-slice [
+ >entry clone
+ [ adjust-url relative-to-request ] change-url
+ ] map ;
+
+: ( body -- response )
+ feed>xml "application/atom+xml" ;
+
+TUPLE: feed-action < action title url entries ;
+
+: ( -- action )
+ feed-action new-action
+ dup '[
+ feed new
+ ,
+ [ title>> call >>title ]
+ [ url>> call adjust-url relative-to-request >>url ]
+ [ entries>> call process-entries >>entries ]
+ tri
+
+ ] >>display ;
diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor
new file mode 100644
index 0000000000..4bfbdcd943
--- /dev/null
+++ b/basis/furnace/utilities/utilities.factor
@@ -0,0 +1,19 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors words kernel sequences splitting ;
+IN: furnace.utilities
+
+: word>string ( word -- string )
+ [ vocabulary>> ] [ name>> ] bi ":" swap 3append ;
+
+: words>strings ( seq -- seq' )
+ [ word>string ] map ;
+
+ERROR: no-such-word name vocab ;
+
+: string>word ( string -- word )
+ ":" split1 swap 2dup lookup dup
+ [ 2nip ] [ drop no-such-word ] if ;
+
+: strings>words ( seq -- seq' )
+ [ string>word ] map ;
diff --git a/basis/globs/authors.txt b/basis/globs/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/basis/globs/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/globs/globs-tests.factor b/basis/globs/globs-tests.factor
new file mode 100644
index 0000000000..446f1ee0a9
--- /dev/null
+++ b/basis/globs/globs-tests.factor
@@ -0,0 +1,18 @@
+IN: globs.tests
+USING: tools.test globs ;
+
+[ f ] [ "abd" "fdf" glob-matches? ] unit-test
+[ f ] [ "fdsafas" "?" glob-matches? ] unit-test
+[ t ] [ "fdsafas" "*as" glob-matches? ] unit-test
+[ t ] [ "fdsafas" "*a*" glob-matches? ] unit-test
+[ t ] [ "fdsafas" "*a?" glob-matches? ] unit-test
+[ t ] [ "fdsafas" "*?" glob-matches? ] unit-test
+[ f ] [ "fdsafas" "*s?" glob-matches? ] unit-test
+[ t ] [ "a" "[abc]" glob-matches? ] unit-test
+[ f ] [ "a" "[^abc]" glob-matches? ] unit-test
+[ t ] [ "d" "[^abc]" glob-matches? ] unit-test
+[ f ] [ "foo.java" "*.{xml,txt}" glob-matches? ] unit-test
+[ t ] [ "foo.txt" "*.{xml,txt}" glob-matches? ] unit-test
+[ t ] [ "foo.xml" "*.{xml,txt}" glob-matches? ] unit-test
+[ f ] [ "foo." "*.{,xml,txt}" glob-matches? ] unit-test
+[ t ] [ "foo.{" "*.{" glob-matches? ] unit-test
diff --git a/basis/globs/globs.factor b/basis/globs/globs.factor
new file mode 100755
index 0000000000..c7d5413a47
--- /dev/null
+++ b/basis/globs/globs.factor
@@ -0,0 +1,42 @@
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser-combinators regexp lists sequences kernel
+promises strings unicode.case ;
+IN: globs
+
+ [ >lower token ] <@ ;
+
+: 'escaped-char' ( -- parser )
+ "\\" token any-char-parser &> [ 1token ] <@ ;
+
+: 'escaped-string' ( -- parser )
+ 'string' 'escaped-char' <|> ;
+
+DEFER: 'term'
+
+: 'glob' ( -- parser )
+ 'term' <*> [ ] <@ ;
+
+: 'union' ( -- parser )
+ 'glob' "," token nonempty-list-of "{" "}" surrounded-by
+ [ ] <@ ;
+
+LAZY: 'term' ( -- parser )
+ 'union'
+ 'character-class' <|>
+ "?" token [ drop any-char-parser ] <@ <|>
+ "*" token [ drop any-char-parser <*> ] <@ <|>
+ 'escaped-string' <|> ;
+
+PRIVATE>
+
+: ( string -- glob ) 'glob' just parse-1 just ;
+
+: glob-matches? ( input glob -- ? )
+ [ >lower ] [ ] bi* parse nil? not ;
diff --git a/basis/globs/summary.txt b/basis/globs/summary.txt
new file mode 100644
index 0000000000..e97b9b28f7
--- /dev/null
+++ b/basis/globs/summary.txt
@@ -0,0 +1 @@
+Unix shell-style glob pattern matching
diff --git a/basis/html/components/components-tests.factor b/basis/html/components/components-tests.factor
new file mode 100644
index 0000000000..56c7118ab9
--- /dev/null
+++ b/basis/html/components/components-tests.factor
@@ -0,0 +1,185 @@
+IN: html.components.tests
+USING: tools.test kernel io.streams.string
+io.streams.null accessors inspector html.streams
+html.elements html.components html.forms namespaces ;
+
+[ ] [ begin-form ] unit-test
+
+[ ] [ 3 "hi" set-value ] unit-test
+
+[ 3 ] [ "hi" value ] unit-test
+
+TUPLE: color red green blue ;
+
+[ ] [ 1 2 3 color boa from-object ] unit-test
+
+[ 1 ] [ "red" value ] unit-test
+
+[ ] [ "jimmy" "red" set-value ] unit-test
+
+[ "jimmy" ] [
+ [
+ "red" label render
+ ] with-string-writer
+] unit-test
+
+[ ] [ "" "red" set-value ] unit-test
+
+[ "<jimmy>" ] [
+ [
+ "red" label render
+ ] with-string-writer
+] unit-test
+
+[ "" ] [
+ [
+ "red" hidden render
+ ] with-string-writer
+] unit-test
+
+[ ] [ "'jimmy'" "red" set-value ] unit-test
+
+[ "" ] [
+ [
+ "red" 5 >>size render
+ ] with-string-writer
+] unit-test
+
+[ "" ] [
+ [
+ "red" 5 >>size render
+ ] with-string-writer
+] unit-test
+
+[ ] [
+ [
+ "green" patterned
+ #! 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 ]
+ (( -- )) html-word ;
+
+: foo/> ( str -- str/> ) "/>" append ;
+
+: def-for-html-word-foo/> ( name -- )
+ #! Return the name and code for the foo/> patterned
+ #! word.
+ foo/> [ "/>" write-html ] (( -- )) html-word ;
+
+: define-closed-html-word ( name -- )
+ #! Given an HTML tag name, define the words for
+ #! that closable HTML tag.
+ dup def-for-html-word-
+ dup def-for-html-word-
+ def-for-html-word- ;
+
+: define-open-html-word ( name -- )
+ #! Given an HTML tag name, define the words for
+ #! that open HTML tag.
+ dup def-for-html-word-
+ dup def-for-html-word- ;
+
+: write-attr ( value name -- )
+ " " write-html
+ write-html
+ "='" write-html
+ present escape-quoted-string write-html
+ "'" write-html ;
+
+: define-attribute-word ( name -- )
+ dup "=" prepend swap
+ '[ , write-attr ] (( string -- )) html-word ;
+
+! Define some closed HTML tags
+[
+ "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
+ "ol" "li" "form" "a" "p" "html" "head" "body" "title"
+ "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
+ "script" "div" "span" "select" "option" "style" "input"
+] [ define-closed-html-word ] each
+
+! Define some open HTML tags
+[
+ "input"
+ "br"
+ "link"
+ "img"
+] [ define-open-html-word ] each
+
+! Define some attributes
+[
+ "method" "action" "type" "value" "name"
+ "size" "href" "class" "border" "rows" "cols"
+ "id" "onclick" "style" "valign" "accesskey"
+ "src" "language" "colspan" "onchange" "rel"
+ "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
+ "media" "title" "multiple" "checked"
+] [ define-attribute-word ] each
+
+>>
+
+: xhtml-preamble ( -- )
+ "" write-html
+ "" write-html ;
+
+: simple-page ( title quot -- )
+ #! Call the quotation, with all output going to the
+ #! body of an html page with the given title.
+ xhtml-preamble
+
+ swap write
+ call
+ ; inline
+
+: render-error ( message -- )
+ escape-string write ;
diff --git a/basis/html/forms/forms-tests.factor b/basis/html/forms/forms-tests.factor
new file mode 100644
index 0000000000..d2dc3ed3a3
--- /dev/null
+++ b/basis/html/forms/forms-tests.factor
@@ -0,0 +1,67 @@
+IN: html.forms.tests
+USING: kernel sequences tools.test assocs html.forms validators accessors
+namespaces ;
+
+: with-validation ( quot -- messages )
+ [
+ begin-form
+ call
+ ] with-scope ; inline
+
+[ 14 ] [
+ [
+ "14" [ v-number 13 v-min-value 100 v-max-value ] validate
+ ] with-validation
+] unit-test
+
+[ t ] [
+ [
+ "140" [ v-number 13 v-min-value 100 v-max-value ] validate
+ [ validation-error? ]
+ [ value>> "140" = ]
+ bi and
+ ] with-validation
+] unit-test
+
+TUPLE: person name age ;
+
+person {
+ { "name" [ ] }
+ { "age" [ v-number 13 v-min-value 100 v-max-value ] }
+} define-validators
+
+[ t t ] [
+ [
+ { { "age" "" } }
+ { { "age" [ v-required ] } }
+ validate-values
+ validation-failed?
+ "age" value
+ [ validation-error? ]
+ [ message>> "required" = ]
+ bi and
+ ] with-validation
+] unit-test
+
+[ H{ { "a" 123 } } f ] [
+ [
+ H{
+ { "a" "123" }
+ { "b" "c" }
+ { "c" "d" }
+ }
+ H{
+ { "a" [ v-integer ] }
+ } validate-values
+ values
+ validation-failed?
+ ] with-validation
+] unit-test
+
+[ t "foo" ] [
+ [
+ "foo" validation-error
+ validation-failed?
+ form get errors>> first
+ ] with-validation
+] unit-test
diff --git a/basis/html/forms/forms.factor b/basis/html/forms/forms.factor
new file mode 100644
index 0000000000..0da3fcb0b3
--- /dev/null
+++ b/basis/html/forms/forms.factor
@@ -0,0 +1,106 @@
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors strings namespaces assocs hashtables
+mirrors math fry sequences sequences.lib words continuations ;
+IN: html.forms
+
+TUPLE: form errors values validation-failed ;
+
+: