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

core/vectors/vectors-tests.factor

@@ -26,7 +26,7 @@ IN: vectors.tests
 [ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test
 
 [ t ] [
-    100 [ 100 random ] V{ } map-as
+    100 [ 100 random ] V{ } replicate-as
     dup >array >vector =
 ] unit-test
 

extra/db/sqlite/sqlite.factor

@@ -53,7 +53,7 @@ M: sqlite-result-set dispose ( result-set -- )
 
 M: sqlite-statement low-level-bind ( statement -- )
     [ statement-bind-params ] [ statement-handle ] bi
-    swap [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ;
+    [ swap [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] curry each ;
 
 M: sqlite-statement bind-statement* ( statement -- )
     sqlite-maybe-prepare

extra/db/tuples/tuples.factor

@@ -122,6 +122,9 @@ M: retryable execute-statement* ( statement type -- )
 : ensure-table ( class -- )
     [ create-table ] curry ignore-errors ;
 
+: ensure-tables ( classes -- )
+    [ ensure-table ] each ;
+
 : insert-db-assigned-statement ( tuple -- )
     dup class
     db get db-insert-statements [ <insert-db-assigned-statement> ] cache

extra/editors/gvim/gvim.factor

@@ -3,14 +3,12 @@ namespaces sequences system combinators
 editors.vim editors.gvim.backend vocabs.loader ;
 IN: editors.gvim
 
-TUPLE: gvim ;
+SINGLETON: gvim
 
 M: gvim vim-command ( file line -- string )
-    [ "\"" % gvim-path % "\" \"" % swap % "\" +" % # ] "" make ;
+    [ gvim-path , swap , "+" swap number>string append , ] { } make ;
 
-t vim-detach set-global ! don't block the ui
+gvim vim-editor set-global
-
-T{ gvim } vim-editor set-global
 
 {
     { [ os unix? ] [ "editors.gvim.unix" ] }

extra/editors/vim/vim-docs.factor

@@ -11,7 +11,5 @@ $nl
 "USE: vim"
 "\"c:\\\\program files\\\\vim\\\\vim70\\\\gvim\" vim-path set-global"
 }
-"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "."
+"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "." ;
-$nl
-"If you are running the terminal version of Vim, you want it to block Factor until exiting, but for GVim the opposite is desired, so that one can work in Factor and GVim concurrently. The " { $link vim-detach } " global variable can be set to " { $link t } " to detach the Vim process. The default is " { $link f } "." ;
 

extra/editors/vim/vim.factor

@@ -3,24 +3,20 @@ namespaces parser prettyprint sequences editors accessors ;
 IN: editors.vim
 
 SYMBOL: vim-path
-SYMBOL: vim-detach
 
 SYMBOL: vim-editor
-HOOK: vim-command vim-editor
+HOOK: vim-command vim-editor ( file line -- array )
 
-TUPLE: vim ;
+SINGLETON: vim
 
-M: vim vim-command ( file line -- array )
+M: vim vim-command
     [
         vim-path get , swap , "+" swap number>string append ,
     ] { } make ;
 
 : vim-location ( file line -- )
-    vim-command
+    vim-command try-process ;
-    <process> swap >>command
-    vim-detach get-global [ t >>detached ] when
-    try-process ;
 
 "vim" vim-path set-global
 [ vim-location ] edit-hook set-global
-T{ vim } vim-editor set-global
+vim vim-editor set-global

extra/farkup/farkup.factor

@@ -1,12 +1,13 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io io.styles kernel memoize namespaces peg
+USING: arrays io io.styles kernel memoize namespaces peg math
-sequences strings html.elements xml.entities xmode.code2html
+combinators sequences strings html.elements xml.entities
-splitting io.streams.string peg.parsers
+xmode.code2html splitting io.streams.string peg.parsers
 sequences.deep unicode.categories ;
 IN: farkup
 
 SYMBOL: relative-link-prefix
+SYMBOL: disable-images?
 SYMBOL: link-no-follow?
 
 <PRIVATE
@@ -67,13 +68,19 @@ MEMO: eq ( -- parser )
         </pre>
     ] with-string-writer ;
 
+: invalid-url "javascript:alert('Invalid URL in farkup');" ;
+
 : check-url ( href -- href' )
-    CHAR: : over member? [
+    {
-        dup { "http://" "https://" "ftp://" } [ head? ] with contains?
+        { [ dup empty? ] [ drop invalid-url ] }
-        [ drop "/" ] unless
+        { [ dup [ 127 > ] contains? ] [ drop invalid-url ] }
-    ] [
+        { [ dup first "/\\" member? ] [ drop invalid-url ] }
-        relative-link-prefix get prepend
+        { [ CHAR: : over member? ] [
-    ] if ;
+            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 ;
@@ -82,18 +89,22 @@ MEMO: eq ( -- parser )
     escape-link
     [
         "<a" ,
-        " href=\"" , >r , r>
+        " href=\"" , >r , r> "\"" ,
         link-no-follow? get [ " nofollow=\"true\"" , ] when
-        "\">" , , "</a>" ,
+        ">" , , "</a>" ,
     ] { } make ;
 
 : make-image-link ( href alt -- seq )
-    escape-link
+    disable-images? get [
-    [
+        2drop "<strong>Images are not allowed</strong>"
-        "<img src=\"" , swap , "\"" ,
+    ] [
-        dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
+        escape-link
-        "/>" , ]
+        [
-    { } make ;
+            "<img src=\"" , swap , "\"" ,
+            dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
+            "/>" ,
+        ] { } make
+    ] if ;
 
 MEMO: image-link ( -- parser )
     [

extra/furnace/actions/actions.factor

@@ -53,7 +53,7 @@ TUPLE: action rest authorize init display validate submit ;
     ] with-exit-continuation ;
 
 : validation-failed ( -- * )
-    request get method>> "POST" = [ f ] [ <400> ] if exit-with ;
+    post-request? [ f ] [ <400> ] if exit-with ;
 
 : (handle-post) ( action -- response )
     '[
@@ -70,16 +70,13 @@ TUPLE: action rest authorize init display validate submit ;
 
 : revalidate-url-key "__u" ;
 
-: check-url ( url -- ? )
-    request get url>>
-    [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
-
 : revalidate-url ( -- url/f )
-    revalidate-url-key param dup [ >url dup check-url swap and ] when ;
+    revalidate-url-key param
+    dup [ >url [ same-host? ] keep and ] when ;
 
 : handle-post ( action -- response )
     '[
-        form-nesting-key params get at " " split
+        form-nesting-key params get at " " split harvest
         [ , (handle-post) ]
         [ swap '[ , , nest-values ] ] reduce
         call

extra/furnace/alloy/alloy.factor

@@ -0,0 +1,31 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences db.tuples alarms calendar db fry
+furnace.cache
+furnace.asides
+furnace.flash
+furnace.sessions
+furnace.referrer
+furnace.db
+furnace.auth.providers ;
+IN: furnace.alloy
+
+: <alloy> ( responder db params -- responder' )
+    '[
+        <asides>
+        <flash-scopes>
+        <sessions>
+        , , <db-persistence>
+        <check-form-submissions>
+    ] call ;
+
+: state-classes { session flash-scope aside } ; 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 ;

extra/furnace/asides/asides.factor

@@ -2,37 +2,60 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors namespaces sequences arrays kernel
 assocs assocs.lib hashtables math.parser urls combinators
-furnace http http.server http.server.filters furnace.sessions
+html.elements html.templates.chloe.syntax db.types db.tuples
-html.elements html.templates.chloe.syntax ;
+http http.server http.server.filters 
+furnace furnace.cache furnace.sessions ;
 IN: furnace.asides
 
-TUPLE: asides < filter-responder ;
+TUPLE: aside < server-state session method url post-data ;
 
-C: <asides> asides
+: <aside> ( id -- aside )
+    aside new-server-state ;
+
+aside "ASIDES"
+{
+    { "session" "SESSION" BIG-INTEGER +not-null+ }
+    { "method" "METHOD" { VARCHAR 10 } +not-null+ }
+    { "url" "URL" URL +not-null+ }
+    { "post-data" "POST_DATA" FACTOR-BLOB }
+} define-persistent
+
+TUPLE: asides < server-state-manager ;
+
+: <asides> ( responder -- responder' )
+    asides new-server-state-manager ;
 
 : begin-aside* ( -- id )
-    request get
+    f <aside>
-    [ url>> ] [ post-data>> ] [ method>> ] tri 3array
+        session get id>> >>session
-    asides sget set-at-unique
+        request get
-    session-changed ;
+        [ method>> >>method ]
+        [ url>> >>url ]
+        [ post-data>> >>post-data ]
+        tri
+    [ asides get touch-state ] [ insert-tuple ] [ id>> ] tri ;
 
-: end-aside-post ( url post-data -- response )
+: end-aside-post ( aside -- response )
     request [
         clone
-            swap >>post-data
+            over post-data>> >>post-data
-            swap >>url
+            over url>> >>url
     ] change
-    request get url>> path>> split-path
+    url>> path>> split-path
     asides get responder>> call-responder ;
 
 ERROR: end-aside-in-get-error ;
 
+: get-aside ( id -- aside )
+    dup [ aside get-state ] when
+    dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
+
 : end-aside* ( url id -- response )
-    request get method>> "POST" = [ end-aside-in-get-error ] unless
+    post-request? [ end-aside-in-get-error ] unless
-    asides sget at [
+    aside get-state [
-        first3 {
+        dup method>> {
-            { "GET" [ drop <redirect> ] }
+            { "GET" [ url>> <redirect> ] }
-            { "HEAD" [ drop <redirect> ] }
+            { "HEAD" [ url>> <redirect> ] }
             { "POST" [ end-aside-post ] }
         } case
     ] [ <redirect> ] ?if ;
@@ -47,13 +70,12 @@ SYMBOL: aside-id
 : end-aside ( default -- response )
     aside-id [ f ] change end-aside* ;
 
+: request-aside-id ( request -- aside-id )
+    aside-id-key swap request-params at string>number ;
+
 M: asides call-responder*
     dup asides set
-    aside-id-key request get request-params at aside-id set
+    request get request-aside-id aside-id set
-    call-next-method ;
-
-M: asides init-session*
-    H{ } clone asides sset
     call-next-method ;
 
 M: asides link-attr ( tag -- )

extra/furnace/auth/providers/db/db-tests.factor

@@ -14,7 +14,7 @@ login set
 
 "auth-test.db" temp-file sqlite-db [
 
-    init-users-table
+    user ensure-table
 
     [ t ] [
         "slava" <user>

extra/furnace/auth/providers/db/db.factor

@@ -18,8 +18,6 @@ user "USERS"
     { "deleted" "DELETED" INTEGER +not-null+ }
 } define-persistent
 
-: init-users-table ( -- ) user ensure-table ;
-
 SINGLETON: users-in-db
 
 M: users-in-db get-user

extra/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
+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" TIMESTAMP +not-null+ }
+} define-persistent
+
+: get-state ( id class -- state )
+    new-server-state select-tuple ;
+
+: expire-state ( class -- )
+    new
+        -1.0/0.0 now [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>> from-now >>expires drop ;

extra/furnace/flash/flash.factor

@@ -1,38 +1,59 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs assocs.lib kernel sequences urls
+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.sessions ;
+furnace furnace.cache furnace.sessions ;
 IN: furnace.flash
 
+TUPLE: flash-scope < server-state session namespace ;
+
+: <flash-scope> ( id -- aside )
+    flash-scope new-server-state ;
+
+flash-scope "FLASH_SCOPES" {
+    { "session" "SESSION" BIG-INTEGER +not-null+ }
+    { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
+} define-persistent
+
 : flash-id-key "__f" ;
 
-TUPLE: flash-scopes < filter-responder ;
+TUPLE: flash-scopes < server-state-manager ;
 
-C: <flash-scopes> flash-scopes
+: <flash-scopes> ( responder -- responder' )
+    flash-scopes new-server-state-manager ;
 
 SYMBOL: flash-scope
 
 : fget ( key -- value ) flash-scope get at ;
 
-M: flash-scopes call-responder*
+: get-flash-scope ( id -- flash-scope )
-    flash-id-key
+    dup [ flash-scope get-state ] when
-    request get request-params at
+    dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
-    flash-scopes sget at flash-scope set
-    call-next-method ;
 
-M: flash-scopes init-session*
+: request-flash-scope ( request -- flash-scope )
-    H{ } clone flash-scopes sset
+    flash-id-key swap request-params at string>number get-flash-scope ;
+
+M: flash-scopes call-responder*
+    dup flash-scopes set
+    request get request-flash-scope flash-scope set
     call-next-method ;
 
 : make-flash-scope ( seq -- id )
-    [ dup get ] H{ } map>assoc flash-scopes sget set-at-unique
+    f <flash-scope>
-    session-changed ;
+        session get id>> >>session
+        swap [ dup get ] H{ } map>assoc >>namespace
+    [ flash-scopes get touch-state ] [ insert-tuple ] [ id>> ] tri ;
 
 : <flash-redirect> ( url seq -- response )
-    make-flash-scope
+    [ clone ] dip
-    [ clone ] dip flash-id-key set-query-param
+    make-flash-scope flash-id-key set-query-param
     <redirect> ;
 
 : restore-flash ( seq -- )
-    [ flash-scope get key? ] filter [ [ fget ] keep set ] each ;
+    flash-scope get dup [
+        namespace>>
+        [ '[ , key? ] filter ]
+        [ '[ [ , at ] keep set ] each ]
+        bi
+    ] [ 2drop ] if ;

extra/furnace/furnace.factor

@@ -84,6 +84,17 @@ M: object modify-form drop ;
         ] }
     } 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 -- ? )
+    request get url>>
+    [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
+
 SYMBOL: exit-continuation
 
 : exit-with ( value -- )
@@ -98,7 +109,8 @@ SYMBOL: exit-continuation
     [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
 
 : a-url-path ( tag -- string )
-    [ "href" required-attr ] [ "rest" optional-attr value ] bi
+    [ "href" required-attr ]
+    [ "rest" optional-attr dup [ value ] when ] bi
     [ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
 
 : a-url ( tag -- url )

extra/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> referrer-check
+
+M: referrer-check call-responder*
+    referrer over quot>> call
+    [ call-next-method ]
+    [ 2drop 403 "Bad referrer" <trivial-response> ] if ;
+
+: <check-form-submissions> ( responder -- responder' )
+    [ same-host? post-request? not or ] <referrer-check> ;

extra/furnace/sessions/sessions-tests.factor

@@ -1,9 +1,9 @@
 IN: furnace.sessions.tests
 USING: tools.test http furnace.sessions
 furnace.actions http.server http.server.responses
-math namespaces kernel accessors
+math namespaces kernel accessors io.sockets io.server
 prettyprint io.streams.string io.files splitting destructors
-sequences db db.sqlite continuations urls math.parser
+sequences db db.tuples db.sqlite continuations urls math.parser
 furnace ;
 
 : with-session
@@ -54,7 +54,9 @@ M: foo call-responder*
 "auth-test.db" temp-file sqlite-db [
 
     <request> init-request
-    init-sessions-table
+    session ensure-table
+
+    "127.0.0.1" 1234 <inet4> remote-address set
 
     [ ] [
         <foo> <sessions>

extra/furnace/sessions/sessions.factor

@@ -2,39 +2,28 @@
 ! 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 destructors alarms
+fry calendar combinators combinators.lib destructors alarms io.server
 db db.tuples db.types
 http http.server http.server.dispatchers http.server.filters
-html.elements furnace ;
+html.elements
+furnace furnace.cache ;
 IN: furnace.sessions
 
-TUPLE: session id expires uid namespace changed? ;
+TUPLE: session < server-state uid namespace user-agent client changed? ;
 
 : <session> ( id -- session )
-    session new
+    session new-server-state ;
-        swap >>id ;
 
 session "SESSIONS"
 {
-    { "id" "ID" +random-id+ system-random-generator }
-    { "expires" "EXPIRES" TIMESTAMP +not-null+ }
     { "uid" "UID" { VARCHAR 255 } }
-    { "namespace" "NAMESPACE" FACTOR-BLOB }
+    { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
+    { "user-agent" "USER_AGENT" TEXT +not-null+ }
+    { "client" "CLIENT" TEXT +not-null+ }
 } define-persistent
 
 : get-session ( id -- session )
-    dup [ <session> select-tuple ] when ;
+    dup [ session get-state ] when ;
-
-: init-sessions-table ( -- ) session ensure-table ;
-
-: start-expiring-sessions ( db seq -- )
-    '[
-        , , [
-            session new
-                -1.0/0.0 now [a,b] >>expires
-            delete-tuples
-        ] with-db
-    ] 5 minutes every drop ;
 
 GENERIC: init-session* ( responder -- )
 
@@ -44,12 +33,11 @@ M: dispatcher init-session* default>> init-session* ;
 
 M: filter-responder init-session* responder>> init-session* ;
 
-TUPLE: sessions < filter-responder timeout domain ;
+TUPLE: sessions < server-state-manager domain verify? ;
 
 : <sessions> ( responder -- responder' )
-    sessions new
+    sessions new-server-state-manager
-        swap >>responder
+        t >>verify? ;
-        20 minutes >>timeout ;
 
 : (session-changed) ( session -- )
     t >>changed? drop ;
@@ -78,15 +66,20 @@ TUPLE: sessions < filter-responder timeout domain ;
 : init-session ( session -- )
     session [ sessions get init-session* ] with-variable ;
 
-: cutoff-time ( -- time )
-    sessions get timeout>> from-now ;
-
 : touch-session ( session -- )
-    cutoff-time >>expires drop ;
+    sessions get touch-state ;
+
+: remote-host ( -- string )
+    {
+        [ request get "x-forwarded-for" header ]
+        [ remote-address get host>> ]
+    } 0|| ;
 
 : empty-session ( -- session )
     f <session>
         H{ } clone >>namespace
+        remote-host >>client
+        user-agent >>user-agent
         dup touch-session ;
 
 : begin-session ( -- session )
@@ -125,8 +118,18 @@ M: session-saver dispose
         { "POST" [ post-session-id ] }
     } case ;
 
+: 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 )
-    request-session-id get-session ;
+    request-session-id get-session verify-session ;
 
 : <session-cookie> ( id -- cookie )
     session-id-key <cookie>

extra/html/components/components-tests.factor

@@ -156,7 +156,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
 [ ] [ "-foo\n-bar" "farkup" set-value ] unit-test
 
 [ "<ul><li>foo</li><li>bar</li></ul>" ] [
-    [ "farkup" farkup render ] with-string-writer
+    [ "farkup" T{ farkup } render ] with-string-writer
 ] unit-test
 
 [ ] [ { 1 2 3 } "object" set-value ] unit-test

extra/html/components/components.factor

@@ -10,9 +10,12 @@ IN: html.components
 
 SYMBOL: values
 
-: value ( name -- value ) values get at ;
+: check-value-name ( name -- name )
+    dup string? [ "Value name not a string" throw ] unless ;
 
-: set-value ( value name -- ) values get set-at ;
+: value ( name -- value ) check-value-name values get at ;
+
+: set-value ( value name -- ) check-value-name values get set-at ;
 
 : blank-values ( -- ) H{ } clone values set ;
 
@@ -200,10 +203,20 @@ M: code render*
     [ string-lines ] [ drop ] [ mode>> value ] tri* htmlize-lines ;
 
 ! Farkup component
-SINGLETON: farkup
+TUPLE: farkup no-follow disable-images ;
+
+: string>boolean ( string -- boolean )
+    {
+        { "true" [ t ] }
+        { "false" [ f ] }
+    } case ;
 
 M: farkup render*
-    2drop string-lines "\n" join convert-farkup write ;
+    [
+        [ no-follow>> [ string>boolean link-no-follow? set ] when* ]
+        [ disable-images>> [ string>boolean disable-images? set ] when* ] bi
+        drop string-lines "\n" join convert-farkup write
+    ] with-scope ;
 
 ! Inspector component
 SINGLETON: inspector

extra/html/templates/chloe/chloe.factor

@@ -98,12 +98,12 @@ CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
 
 CHLOE-SINGLETON: label
 CHLOE-SINGLETON: link
-CHLOE-SINGLETON: farkup
 CHLOE-SINGLETON: inspector
 CHLOE-SINGLETON: comparison
 CHLOE-SINGLETON: html
 CHLOE-SINGLETON: hidden
 
+CHLOE-TUPLE: farkup
 CHLOE-TUPLE: field
 CHLOE-TUPLE: textarea
 CHLOE-TUPLE: password

extra/http/http-tests.factor

@@ -121,12 +121,12 @@ read-response-test-1' 1array [
 ] unit-test
 
 ! Live-fire exercise
-USING: http.server http.server.static furnace.sessions
+USING: http.server http.server.static furnace.sessions furnace.alloy
 furnace.actions furnace.auth.login furnace.db http.client
 io.server io.files io io.encodings.ascii
 accessors namespaces threads
 http.server.responses http.server.redirection
-http.server.dispatchers ;
+http.server.dispatchers db.tuples ;
 
 : add-quit-action
     <action>
@@ -138,7 +138,7 @@ http.server.dispatchers ;
 [ test-db drop delete-file ] ignore-errors
 
 test-db [
-    init-sessions-table
+    init-furnace-tables
 ] with-db
 
 [ ] [

extra/http/server/cgi/cgi.factor

@@ -5,8 +5,6 @@ combinators arrays io.launcher io http.server.static http.server
 http accessors sequences strings math.parser fry urls ;
 IN: http.server.cgi
 
-: post? ( -- ? ) request get method>> "POST" = ;
-
 : cgi-variables ( script-path -- assoc )
     #! This needs some work.
     [
@@ -34,7 +32,7 @@ IN: http.server.cgi
         request get "user-agent" header "HTTP_USER_AGENT" set
         request get "accept" header "HTTP_ACCEPT" set
 
-        post? [
+        post-request? [
             request get post-data>> raw>>
             [ "CONTENT_TYPE" set ]
             [ length number>string "CONTENT_LENGTH" set ]
@@ -53,7 +51,7 @@ IN: http.server.cgi
     "CGI output follows" >>message
     swap '[
         , output-stream get swap <cgi-process> <process-stream> [
-            post? [ request get post-data>> raw>> write flush ] when
+            post-request? [ request get post-data>> raw>> write flush ] when
             input-stream get swap (stream-copy)
         ] with-stream
     ] >>body ;

extra/http/server/server.factor

@@ -13,13 +13,15 @@ io.encodings.ascii
 io.encodings.binary
 io.streams.limited
 io.timeouts
-fry logging calendar urls
+fry logging logging.insomniac calendar urls
 http
 http.server.responses
 html.elements
 html.streams ;
 IN: http.server
 
+: post-request? ( -- ? ) request get method>> "POST" = ;
+
 SYMBOL: responder-nesting
 
 SYMBOL: main-responder
@@ -76,9 +78,15 @@ main-responder global [ <404> <trivial-responder> or ] change-at
 
 LOG: httpd-hit NOTICE
 
+LOG: httpd-header NOTICE
+
+: log-header ( headers name -- )
+    tuck header 2array httpd-header ;
+
 : log-request ( request -- )
-    [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi
+    [ [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi 3array httpd-hit ]
-    3array httpd-hit ;
+    [ { "user-agent" "x-forwarded-for" } [ log-header ] with each ]
+    bi ;
 
 : split-path ( string -- path )
     "/" split harvest ;
@@ -90,13 +98,13 @@ LOG: httpd-hit NOTICE
 : dispatch-request ( request -- response )
     url>> path>> split-path main-responder get call-responder ;
 
-: prepare-request ( request -- request )
+: prepare-request ( request -- )
     [
         local-address get
         [ secure? "https" "http" ? >>protocol ]
         [ port>> '[ , or ] change-port ]
         bi
-    ] change-url ;
+    ] change-url drop ;
 
 : valid-request? ( request -- ? )
     url>> port>> local-address get port>> = ;
@@ -138,4 +146,7 @@ LOG: httpd-hit NOTICE
 : httpd-main ( -- )
     8888 httpd ;
 
+: httpd-insomniac ( -- )
+    "http.server" { httpd-hit } schedule-insomniac ;
+
 MAIN: httpd-main

extra/io/ports/ports-docs.factor

@@ -64,7 +64,3 @@ HELP: (wait-to-read)
 HELP: wait-to-read
 { $values { "port" input-port } { "eof?" "a boolean" } }
 { $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading. If the buffer was empty and no more data could be read, outputs " { $link t } " to indicate end-of-file; otherwise outputs " { $link f } "." } ;
-
-HELP: can-write?
-{ $values { "len" "a positive integer" } { "buffer" buffer } { "?" "a boolean" } }
-{ $description "Tests if the port's output buffer can accomodate " { $snippet "len" } " bytes. If the buffer is empty, this always outputs " { $link t } ", since in that case the buffer will be grown automatically." } ;

extra/io/ports/ports.factor

@@ -98,11 +98,9 @@ TUPLE: output-port < buffered-port ;
 : <output-port> ( handle -- output-port )
     output-port <buffered-port> ;
 
-: can-write? ( len buffer -- ? )
-    [ buffer-fill + ] keep buffer-capacity <= ;
-
 : wait-to-write ( len port -- )
-    tuck buffer>> can-write? [ drop ] [ stream-flush ] if ;
+    tuck buffer>> buffer-capacity <=
+    [ drop ] [ stream-flush ] if ;
 
 M: output-port stream-write1
     dup check-disposed

extra/logging/logging.factor

@@ -42,11 +42,9 @@ SYMBOL: log-service
 
 <PRIVATE
 
-PREDICATE: one-string-array < array
-    [ length 1 = ] [ [ string? ] all? ] bi and ;
-
 : stack>message ( obj -- inputs>message )
-    dup one-string-array? [ first ] [
+    dup array? [ dup length 1 = [ first ] when ] when
+    dup string? [
         [
             string-limit off
             1 line-limit set
@@ -54,7 +52,7 @@ PREDICATE: one-string-array < array
             0 margin set
             unparse
         ] with-scope
-    ] if ;
+    ] unless ;
 
 PRIVATE>
 

extra/math/quadratic/quadratic.factor

@@ -3,13 +3,13 @@
 USING: kernel math math.functions ;
 IN: math.quadratic
 
-: monic ( c b a -- c' b' ) tuck / >r / r> ;
+: monic ( c b a -- c' b' ) tuck [ / ] 2bi@ ;
 
 : discriminant ( c b -- b d ) tuck sq 4 / swap - sqrt ;
 
-: critical ( b d -- -b/2 d ) >r -2 / r> ;
+: critical ( b d -- -b/2 d ) [ -2 / ] dip ;
 
-: +- ( x y -- x+y x-y ) [ + ] 2keep - ;
+: +- ( x y -- x+y x-y ) [ + ] [ - ] 2bi ;
 
 : quadratic ( c b a -- alpha beta )
     #! Solve a quadratic equation ax^2 + bx + c = 0
@@ -17,4 +17,4 @@ IN: math.quadratic
 
 : qeval ( x c b a -- y )
     #! Evaluate ax^2 + bx + c
-    >r pick * r> roll sq * + + ;
+    [ pick * ] dip roll sq * + + ;

extra/persistent-vectors/persistent-vectors-tests.factor

@@ -24,7 +24,7 @@ random namespaces vectors math math.order ;
     [ t ] swap [ dup >persistent-vector sequence= ] curry unit-test
 ] each
 
-[ ] [ 10000 [ drop 16 random-bits ] PV{ } map-as "1" set ] unit-test
+[ ] [ 10000 [ 16 random-bits ] PV{ } replicate-as "1" set ] unit-test
 [ ] [ "1" get >vector "2" set ] unit-test
 
 [ t ] [

extra/sequences/lib/lib-tests.factor

@@ -80,7 +80,6 @@ IN: sequences.lib.tests
 [ ] [ { } 0 firstn ] unit-test
 [ "a" ] [ { "a" } 1 firstn ] unit-test
 
-[ { { 1 1 } { 1 2 } { 2 0 } } ] [ { { 2 0 } { 1 1 } { 1 2 } } dup [ first ] insertion-sort ] unit-test
 [ "empty" ] [ { } [ "not empty" ] [ "empty" ] if-seq ] unit-test
 [ { 1 } "not empty" ] [ { 1 } [ "not empty" ] [ "empty" ] if-seq ] unit-test
 

extra/sorting/insertion/insertion-tests.factor

@@ -0,0 +1,4 @@
+IN: sorting.insertion
+USING: sorting.insertion sequences kernel tools.test ;
+
+[ { { 1 1 } { 1 2 } { 2 0 } } ] [ { { 2 0 } { 1 1 } { 1 2 } } dup [ first ] insertion-sort ] unit-test

extra/urls/urls.factor

@@ -135,6 +135,8 @@ PRIVATE>
 
 GENERIC: >url ( obj -- url )
 
+M: f >url drop <url> ;
+
 M: url >url ;
 
 M: string >url

extra/webapps/blogs/blogs.factor

@@ -59,8 +59,6 @@ M: post entity-url
 
 : <post> ( id -- post ) \ post new swap >>id ;
 
-: init-posts-table ( -- ) \ post ensure-table ;
-
 TUPLE: comment < entity parent ;
 
 comment "COMMENTS" {
@@ -78,8 +76,6 @@ M: comment entity-url
         swap >>id
         swap >>parent ;
 
-: init-comments-table ( -- ) comment ensure-table ;
-
 : post ( id -- post )
     [ <post> select-tuple ] [ f <comment> select-tuples ] bi
     >>comments ;
@@ -120,6 +116,7 @@ M: comment entity-url
 
 : <posts-by-feed-action> ( -- action )
     <feed-action>
+        "author" >>rest
         [ validate-author ] >>init
         [ "Recent Posts by " "author" value append ] >>title
         [ list-posts ] >>entries
@@ -127,6 +124,7 @@ M: comment entity-url
 
 : <post-feed-action> ( -- action )
     <feed-action>
+        "id" >>rest
         [ validate-integer-id "id" value post "post" set-value ] >>init
         [ "post" value feed-entry-title ] >>title
         [ "post" value entity-url ] >>url

extra/webapps/blogs/view-post.xml

@@ -37,7 +37,7 @@
 		</p>
 
 		<p class="posting-body">
-			<t:farkup t:name="content" />
+			<t:farkup t:name="content" t:no-follow="true" t:disable-images="true" />
 		</p>
 		
 		<t:button t:action="$blogs/delete-comment" t:for="id,parent" class="link-button link">Delete Comment</t:button>

extra/webapps/factor-website/factor-website.factor

@@ -2,9 +2,11 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences assocs io.files io.sockets
 io.server
-namespaces db db.sqlite smtp
+namespaces db db.tuples db.sqlite smtp
+logging.insomniac
 http.server
 http.server.dispatchers
+furnace.alloy
 furnace.db
 furnace.asides
 furnace.flash
@@ -25,24 +27,16 @@ IN: webapps.factor-website
 
 : init-factor-db ( -- )
     test-db [
-        init-users-table
+        init-furnace-tables
-        init-sessions-table
 
-        init-pastes-table
+        {
-        init-annotations-table
+            post comment
-
+            paste annotation
-        init-blog-table
+            blog posting
-        init-postings-table
+            todo
-
+            short-url
-        init-todo-table
+            article revision
-
+        } ensure-tables
-        init-articles-table
-        init-revisions-table
-
-        init-postings-table
-        init-comments-table
-
-        init-short-url-table
     ] with-db ;
 
 TUPLE: factor-website < dispatcher ;
@@ -63,18 +57,18 @@ TUPLE: factor-website < dispatcher ;
         allow-edit-profile
     <boilerplate>
         { factor-website "page" } >>template
-    <asides> <flash-scopes> <sessions>
+    test-db <alloy> ;
-    test-db <db-persistence> ;
 
 : 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 ;
 
 : start-factor-website ( -- )
-    test-db start-expiring-sessions
+    test-db start-expiring
     test-db start-update-task
+    httpd-insomniac
     8812 httpd ;

extra/webapps/pastebin/pastebin.factor

@@ -236,7 +236,3 @@ M: annotation entity-url
         <delete-annotation-action> "delete-annotation" add-responder
     <boilerplate>
         { pastebin "pastebin-common" } >>template ;
-
-: init-pastes-table ( -- ) \ paste ensure-table ;
-
-: init-annotations-table ( -- ) annotation ensure-table ;

extra/webapps/planet/planet.factor

@@ -49,10 +49,6 @@ posting "POSTINGS"
     { "date" "DATE" TIMESTAMP +not-null+ }
 } define-persistent
 
-: init-blog-table ( -- ) blog ensure-table ;
-
-: init-postings-table ( -- ) posting ensure-table ;
-
 : <blog> ( id -- todo )
     blog new
         swap >>id ;

extra/webapps/todo/todo.factor

@@ -28,8 +28,6 @@ todo "TODO"
     { "description" "DESCRIPTION" { VARCHAR 256 } }
 } define-persistent
 
-: init-todo-table ( -- ) todo ensure-table ;
-
 : <todo> ( id -- todo )
     todo new
         swap >>id

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

@@ -16,9 +16,6 @@ short-url "SHORT_URLS" {
     { "url" "URL" TEXT +not-null+ }
 } define-persistent
 
-: init-short-url-table ( -- )
-    short-url ensure-table ;
-
 : letter-bank ( -- seq )
     CHAR: a CHAR: z [a,b]
     CHAR: A CHAR: Z [a,b]

extra/webapps/wiki/revisions.xml

@@ -16,7 +16,7 @@
 				<tr>
 					<td> <t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a> </td>
 					<td> <t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a> </td>
-					<td> <t:button t:action="rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
+					<td> <t:button t:action="$wiki/rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
 				</tr>
 			</t:bind-each>
 		</table>

extra/webapps/wiki/wiki.factor

@@ -39,15 +39,11 @@ TUPLE: article title revision ;
 
 article "ARTICLES" {
     { "title" "TITLE" { VARCHAR 256 } +not-null+ +user-assigned-id+ }
-    ! { "AUTHOR" INTEGER +not-null+ } ! uid
-    ! { "PROTECTED" BOOLEAN +not-null+ }
     { "revision" "REVISION" INTEGER +not-null+ } ! revision id
 } define-persistent
 
 : <article> ( title -- article ) article new swap >>title ;
 
-: init-articles-table ( -- ) article ensure-table ;
-
 TUPLE: revision id title author date content ;
 
 revision "REVISIONS" {
@@ -71,8 +67,6 @@ M: revision feed-entry-url id>> revision-url ;
 : <revision> ( id -- revision )
     revision new swap >>id ;
 
-: init-revisions-table ( -- ) revision ensure-table ;
-
 : validate-title ( -- )
     { { "title" [ v-one-line ] } } validate-params ;
 
@@ -115,14 +109,17 @@ M: revision feed-entry-url id>> revision-url ;
 
         { wiki "view" } >>template ;
 
+: amend-article ( revision article -- )
+    swap id>> >>revision update-tuple ;
+
+: add-article ( revision -- )
+    [ title>> ] [ id>> ] bi article boa insert-tuple ;
+
 : add-revision ( revision -- )
     [ insert-tuple ]
     [
-        dup title>> <article> select-tuple [
+        dup title>> <article> select-tuple
-            swap id>> >>revision update-tuple
+        [ amend-article ] [ add-article ] if*
-        ] [
-            [ title>> ] [ id>> ] bi article boa insert-tuple
-        ] if*
     ] bi ;
 
 : <edit-article-action> ( -- action )