Add referrer check responder, harden sessions against cross-site scripting

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,12 +70,9 @@ 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 )
     '[

extra/furnace/alloy/alloy.factor

@@ -5,12 +5,19 @@ 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> ] 2dip <db-persistence> ;
+    '[
+        <asides>
+        <flash-scopes>
+        <sessions>
+        , , <db-persistence>
+        <check-form-submissions>
+    ] call ;
 
 : state-classes { session flash-scope aside } ; inline
 

extra/furnace/asides/asides.factor

@@ -51,7 +51,7 @@ ERROR: end-aside-in-get-error ;
     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
     aside get-state [
         dup method>> {
             { "GET" [ url>> <redirect> ] }

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 -- )

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.factor

@@ -2,14 +2,14 @@
 ! 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 destructors alarms io.server
 db db.tuples db.types
 http http.server http.server.dispatchers http.server.filters
 html.elements
 furnace furnace.cache ;
 IN: furnace.sessions
 
-TUPLE: session < server-state uid namespace changed? ;
+TUPLE: session < server-state uid namespace user-agent client changed? ;
 
 : <session> ( id -- session )
     session new-server-state ;
@@ -18,6 +18,8 @@ session "SESSIONS"
 {
     { "uid" "UID" { VARCHAR 255 } }
     { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
+    { "user-agent" "USER_AGENT" TEXT +not-null+ }
+    { "client" "CLIENT" TEXT +not-null+ }
 } define-persistent
 
 : get-session ( id -- session )
@@ -31,10 +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-server-state-manager ;
+    sessions new-server-state-manager
+        t >>verify? ;
 
 : (session-changed) ( session -- )
     t >>changed? drop ;
@@ -66,9 +69,13 @@ TUPLE: sessions < filter-responder timeout domain ;
 : touch-session ( session -- )
     sessions get touch-state ;
 
+: remote-host ( -- string ) remote-address get host>> ;
+
 : empty-session ( -- session )
     f <session>
         H{ } clone >>namespace
+        remote-host >>client
+        user-agent >>user-agent
         dup touch-session ;
 
 : begin-session ( -- session )
@@ -107,8 +114,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/http/http-tests.factor

@@ -269,7 +269,7 @@ SYMBOL: a
 ! Test flash scope
 [ "xyz" ] [
     H{ { "a" "xyz" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
-    "http://localhost:1237/" <post-request> "cookies" get >>cookies B http-request nip test-a
+    "http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
 ] unit-test
 
 [ 4 ] [ a get-global ] unit-test

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

@@ -20,6 +20,8 @@ html.elements
 html.streams ;
 IN: http.server
 
+: post-request? ( -- ? ) request get method>> "POST" = ;
+
 SYMBOL: responder-nesting
 
 SYMBOL: main-responder

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/factor-website/factor-website.factor

@@ -61,9 +61,7 @@ TUPLE: factor-website < dispatcher ;
 : init-factor-website ( -- )
     "factorcode.org" 25 <inet> smtp-server set-global
     "todo@factorcode.org" lost-password-from set-global
-
     init-factor-db
-
     <factor-website> main-responder set-global ;
 
 : start-factor-website ( -- )

extra/webapps/wiki/wiki.factor

@@ -39,8 +39,6 @@ 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
 
@@ -111,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 )