diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index a281687096..2b3144fd27 100755 --- a/extra/furnace/actions/actions.factor +++ b/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 ) '[ diff --git a/extra/furnace/alloy/alloy.factor b/extra/furnace/alloy/alloy.factor index 24b47cc4b8..14ffbaba9d 100644 --- a/extra/furnace/alloy/alloy.factor +++ b/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 : ( responder db params -- responder' ) - [ ] 2dip ; + '[ + + + + , , + + ] call ; : state-classes { session flash-scope aside } ; inline diff --git a/extra/furnace/asides/asides.factor b/extra/furnace/asides/asides.factor index fc767e050d..15d1c1df0b 100644 --- a/extra/furnace/asides/asides.factor +++ b/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>> ] } diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index cdee2821b6..2645146fbf 100644 --- a/extra/furnace/furnace.factor +++ b/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 -- ) diff --git a/extra/furnace/referrer/referrer.factor b/extra/furnace/referrer/referrer.factor new file mode 100644 index 0000000000..56777676fc --- /dev/null +++ b/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 + +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/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 0c0788a1e6..ab971d24d0 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/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? ; : ( 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? ; : ( 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 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 ; : ( id -- cookie ) session-id-key diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index d9b26341e7..bc206f08b7 100755 --- a/extra/http/http-tests.factor +++ b/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/" "cookies" get >>cookies B http-request nip test-a + "http://localhost:1237/" "cookies" get >>cookies http-request nip test-a ] unit-test [ 4 ] [ a get-global ] unit-test diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor index 626cd78e14..3a13b6de39 100755 --- a/extra/http/server/cgi/cgi.factor +++ b/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 [ - 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 ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 8e3d1a586a..4ad44554f5 100755 --- a/extra/http/server/server.factor +++ b/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 diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor index 7e74fd1115..38511de8e8 100644 --- a/extra/urls/urls.factor +++ b/extra/urls/urls.factor @@ -135,6 +135,8 @@ PRIVATE> GENERIC: >url ( obj -- url ) +M: f >url drop ; + M: url >url ; M: string >url diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index 55f7ec7ffa..fa598c0948 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -61,9 +61,7 @@ TUPLE: factor-website < dispatcher ; : init-factor-website ( -- ) "factorcode.org" 25 smtp-server set-global "todo@factorcode.org" lost-password-from set-global - init-factor-db - main-responder set-global ; : start-factor-website ( -- ) diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index eb3048a26c..8dd62c8761 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/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>>
select-tuple [ - swap id>> >>revision update-tuple - ] [ - [ title>> ] [ id>> ] bi article boa insert-tuple - ] if* + dup title>>
select-tuple + [ amend-article ] [ add-article ] if* ] bi ; : ( -- action )