diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 2e7370bc39..d1ffce721d 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,5 +1,6 @@ USING: http tools.test multiline tuple-syntax -io.streams.string kernel arrays splitting sequences ; +io.streams.string kernel arrays splitting sequences +assocs io.sockets ; IN: http.tests [ "hello%20world" ] [ "hello world" url-encode ] unit-test @@ -136,10 +137,12 @@ io.encodings.ascii ; [ ] [ [ - - [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>display - "quit" add-responder - "extra/http/test" resource-path >>default + + [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>display + "quit" add-responder + + "extra/http/test" resource-path >>default + "nested" add-responder main-responder set [ 1237 httpd ] "HTTPD test" spawn drop @@ -148,7 +151,17 @@ io.encodings.ascii ; [ t ] [ "extra/http/test/foo.html" resource-path ascii file-contents - "http://localhost:1237/foo.html" http-get = + "http://localhost:1237/nested/foo.html" http-get = +] unit-test + +! Try with a slightly malformed request +[ t ] [ + "localhost" 1237 ascii [ + "GET nested HTTP/1.0\r\n" write flush + "\r\n" write flush + readln drop + read-header USE: prettyprint + ] with-stream dup . "location" swap at "/" head? ] unit-test [ "Goodbye" ] [ diff --git a/extra/http/server/auth/login/Untitled-13 b/extra/http/server/auth/login/Untitled-13 new file mode 100644 index 0000000000..ddf16405a6 --- /dev/null +++ b/extra/http/server/auth/login/Untitled-13 @@ -0,0 +1,7 @@ +hidden, how do we handle this? + +dan's delegation is the obvious solution. + +but... we have that ugly hack for integers there... + +i have hidden string, hidden username... hmmm.... diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 89984b0e84..4f04a1ff9b 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -1,20 +1,29 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors quotations assocs kernel splitting -base64 html.elements io combinators http.server -http.server.auth.providers http.server.auth.providers.null -http.server.actions http.server.components http.server.sessions -http.server.templating.fhtml http.server.validators -http.server.auth http sequences io.files namespaces hashtables +base64 io combinators sequences io.files namespaces hashtables fry io.sockets arrays threads locals qualified continuations -destructors ; +destructors + +html.elements +http +http.server +http.server.auth +http.server.auth.providers +http.server.auth.providers.null +http.server.actions +http.server.components +http.server.forms +http.server.sessions +http.server.templating.fhtml +http.server.validators ; IN: http.server.auth.login QUALIFIED: smtp SYMBOL: post-login-url SYMBOL: login-failed? -TUPLE: login users ; +TUPLE: login < dispatcher users ; : users login get users>> ; @@ -130,7 +139,7 @@ SYMBOL: user-exists? successful-login - login get responder>> init-user-profile + login get default>> responder>> init-user-profile ] >>submit ] ; @@ -178,7 +187,7 @@ SYMBOL: previous-page "password" value uid users check-login [ login-failed? on validation-failed ] unless - "new-password" value set-password + "new-password" value >>password ] unless "realname" value >>realname @@ -269,7 +278,8 @@ SYMBOL: lost-password-from : "new-password"
"resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template - "username" + "username" + hidden >>renderer t >>required add-field "new-password" @@ -278,7 +288,8 @@ SYMBOL: lost-password-from "verify-password" t >>required add-field - "ticket" + "ticket" + hidden >>renderer t >>required add-field ; @@ -342,22 +353,22 @@ C: protected "login" f ; M: protected call-responder ( path responder -- response ) - logged-in-user sget [ - dup save-user-after + logged-in-user sget dup [ + save-user-after request get request-url previous-page sset responder>> call-responder ] [ - 2drop + 3drop request get method>> { "GET" "HEAD" } member? [ show-login-page ] [ <400> ] if ] if ; M: login call-responder ( path responder -- response ) dup login set - delegate call-responder ; + call-next-method ; : ( responder -- auth ) - login + login new-dispatcher swap >>default "login" add-responder "logout" add-responder diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor index f99e4d3d2e..a8f17d6f5d 100755 --- a/extra/http/server/auth/providers/assoc/assoc-tests.factor +++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor @@ -26,7 +26,7 @@ namespaces accessors kernel ; [ t ] [ "user" get >boolean ] unit-test -[ ] [ "user" get "fdasf" set-password drop ] unit-test +[ ] [ "user" get "fdasf" >>password drop ] unit-test [ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor index 340e1bb35d..6daddac304 100755 --- a/extra/http/server/auth/providers/db/db-tests.factor +++ b/extra/http/server/auth/providers/db/db-tests.factor @@ -31,7 +31,7 @@ users-in-db "provider" set [ t ] [ "user" get >boolean ] unit-test - [ ] [ "user" get "fdasf" set-password drop ] unit-test + [ ] [ "user" get "fdasf" >>password drop ] unit-test [ ] [ "user" get "provider" get update-user ] unit-test diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor index eda3babf0f..6674a26dbc 100755 --- a/extra/http/server/auth/providers/providers.factor +++ b/extra/http/server/auth/providers/providers.factor @@ -17,8 +17,6 @@ GENERIC: new-user ( user provider -- user/f ) : check-login ( password username provider -- user/f ) get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ; -: set-password ( user password -- user ) >>password ; - ! Password recovery support :: issue-ticket ( email username provider -- user/f ) diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor index d372865b7e..3caeda1c9a 100755 --- a/extra/http/server/components/components-tests.factor +++ b/extra/http/server/components/components-tests.factor @@ -1,7 +1,10 @@ IN: http.server.components.tests -USING: http.server.components http.server.validators -namespaces tools.test kernel accessors -tuple-syntax mirrors http.server.actions ; +USING: http.server.components http.server.forms +http.server.validators namespaces tools.test kernel accessors +tuple-syntax mirrors http.server.actions +io.streams.string io.streams.null ; + +\ render-edit must-infer validation-failed? off @@ -99,11 +102,31 @@ TUPLE: test-tuple text number more-text ; "123" "n" get validate value>> ] unit-test - [ ] [ "n" get t >>integer drop ] unit-test + [ ] [ "i" "i" set ] unit-test [ 3 ] [ - "3" "n" get validate + "3" "i" get validate ] unit-test + + [ t ] [ + "3.9" "i" get validate validation-error? + ] unit-test + + H{ } clone values set + + [ ] [ 3 "i" set-value ] unit-test + + [ "3" ] [ [ "i" get render-view ] with-string-writer ] unit-test + + [ ] [ [ "i" get render-edit ] with-null-stream ] unit-test + + [ ] [ "t" "t" set ] unit-test + + [ ] [ "hello world" "t" set-value ] unit-test + + [ ] [ [ "t" get render-edit ] with-null-stream ] unit-test ] with-scope [ t ] [ "wake up sheeple" dup "n" validate = ] unit-test + +[ ] [ "password" "p" set ] unit-test diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index bd95bf4407..4b440089ad 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -2,23 +2,47 @@ ! See http://factorcode.org/license.txt for BSD license. USING: html.elements http.server.validators accessors namespaces kernel io math.parser assocs classes words classes.tuple arrays -sequences io.files http.server.templating.fhtml -http.server.actions splitting mirrors hashtables fry +sequences splitting mirrors hashtables fry combinators continuations math ; IN: http.server.components +! Renderer protocol +GENERIC: render-view* ( value renderer -- ) +GENERIC: render-edit* ( value id renderer -- ) + +TUPLE: field type ; + +C: field + +M: field render-view* drop write ; + +M: field render-edit* + > =type [ =id ] [ =name ] bi =value input/> ; + +: render-error ( message -- ) + write ; + +TUPLE: hidden < field ; + +: hidden ( -- renderer ) T{ hidden f "hidden" } ; inline + +M: hidden render-view* 2drop ; + +! Component protocol SYMBOL: components -TUPLE: component id required default ; +TUPLE: component id required default renderer ; : component ( name -- component ) dup components get at [ ] [ "No such component: " prepend throw ] ?if ; +GENERIC: init ( component -- component ) + +M: component init ; + GENERIC: validate* ( value component -- result ) -GENERIC: render-view* ( value component -- ) -GENERIC: render-edit* ( value component -- ) -GENERIC: render-error* ( reason value component -- ) +GENERIC: component-string ( value component -- string ) SYMBOL: values @@ -26,6 +50,41 @@ SYMBOL: values : set-value values get set-at ; +: blank-values H{ } clone values set ; + +: from-tuple values set ; + +: values-tuple values get mirror-object ; + +: render-view ( component -- ) + [ id>> value ] [ component-string ] [ renderer>> ] tri + render-view* ; + +> ] [ renderer>> ] bi render-edit* ; + +: render-edit-error ( component -- ) + [ id>> value ] keep + [ [ value>> ] dip render-edit-string ] + [ drop reason>> render-error ] 2bi ; + +: value-or-default ( component -- value ) + [ id>> value ] [ default>> ] bi or ; + +: render-edit-value ( component -- ) + [ value-or-default ] + [ component-string ] + [ render-edit-string ] + tri ; + +PRIVATE> + +: render-edit ( component -- ) + dup id>> value validation-error? + [ render-edit-error ] [ render-edit-value ] if ; + : validate ( value component -- result ) '[ , @@ -36,206 +95,130 @@ SYMBOL: values ] [ validate* ] if ] with-validator ; -: render-view ( component -- ) - [ id>> value ] [ render-view* ] bi ; - -: render-error ( error -- ) - write ; - -: render-edit ( component -- ) - dup id>> value dup validation-error? [ - [ reason>> ] [ value>> ] bi rot render-error* - ] [ - swap [ default>> or ] keep render-edit* - ] if ; - -: ( id class -- component ) - \ component construct-empty - swap construct-delegate - swap >>id ; inline - -! Forms -TUPLE: form view-template edit-template components ; - -: ( id -- form ) - form - V{ } clone >>components ; - -: add-field ( form component -- form ) - dup id>> pick components>> set-at ; - -: with-form ( form quot -- ) - >r components>> components r> with-variable ; inline - -: set-defaults ( form -- ) - [ - components get [ - swap values get [ - swap default>> or - ] change-at - ] assoc-each - ] with-form ; - -: view-form ( form -- ) - dup view-template>> '[ , run-template ] with-form ; - -: edit-form ( form -- ) - dup edit-template>> '[ , run-template ] with-form ; - -: validate-param ( id component -- ) - [ [ params get at ] [ validate ] bi* ] - [ drop set-value ] 2bi ; - -: (validate-form) ( form -- error? ) - [ - validation-failed? off - components get [ validate-param ] assoc-each - validation-failed? get - ] with-form ; - -: validate-form ( form -- ) - (validate-form) [ validation-failed ] when ; - -: blank-values H{ } clone values set ; - -: from-tuple values set ; - -: values-tuple values get mirror-object ; - -! ! ! -! Canned components: for simple applications and prototyping -! ! ! - -: render-input ( value component type -- ) - > [ =id ] [ =name ] bi - =value - input/> ; - -! Hidden fields -TUPLE: hidden ; - -: ( component -- component ) - hidden construct-delegate ; - -M: hidden render-view* - 2drop ; - -M: hidden render-edit* - >r dup number? [ number>string ] when r> - "hidden" render-input ; +: new-component ( id class renderer -- component ) + swap construct-empty + swap >>renderer + swap >>id + init ; inline ! String input fields -TUPLE: string min-length max-length ; +TUPLE: string < component one-line min-length max-length ; -: ( id -- component ) string ; +: new-string ( id class -- component ) + "text" new-component + t >>one-line ; inline + +: ( id -- component ) + string new-string ; M: string validate* - [ v-one-line ] [ - [ min-length>> [ v-min-length ] when* ] - [ max-length>> [ v-max-length ] when* ] - bi - ] bi* ; + [ one-line>> [ v-one-line ] when ] + [ min-length>> [ v-min-length ] when* ] + [ max-length>> [ v-max-length ] when* ] + tri ; -M: string render-view* - drop write ; - -M: string render-edit* - "text" render-input ; - -M: string render-error* - "text" render-input render-error ; +M: string component-string + drop ; ! Username fields -TUPLE: username ; +TUPLE: username < string ; + +M: username init + 2 >>min-length + 20 >>max-length ; : ( id -- component ) - username construct-delegate - 2 >>min-length - 20 >>max-length ; + username new-string ; M: username validate* - delegate validate* v-one-word ; + call-next-method v-one-word ; ! E-mail fields -TUPLE: email ; +TUPLE: email < string ; : ( id -- component ) - email construct-delegate + email new-string 5 >>min-length 60 >>max-length ; M: email validate* - delegate validate* dup empty? [ v-email ] unless ; + call-next-method dup empty? [ v-email ] unless ; + +! Don't send passwords back to the user +TUPLE: password-renderer < field ; + +: password-renderer T{ password-renderer f "password" } ; + +: blank-password >r >r drop "" r> r> ; + +M: password-renderer render-edit* + blank-password call-next-method ; ! Password fields -TUPLE: password ; +TUPLE: password < string ; + +M: password init + 6 >>min-length + 60 >>max-length ; : ( id -- component ) - password construct-delegate - 6 >>min-length - 60 >>max-length ; + password new-string + password-renderer >>renderer ; M: password validate* - delegate validate* v-one-word ; - -M: password render-edit* - >r drop f r> "password" render-input ; - -M: password render-error* - render-edit* render-error ; + call-next-method v-one-word ; ! Number fields -TUPLE: number min-value max-value integer ; +TUPLE: number < string min-value max-value ; -: ( id -- component ) number ; +: ( id -- component ) + number new-string ; M: number validate* [ v-number ] [ - [ integer>> [ v-integer ] when ] [ min-value>> [ v-min-value ] when* ] [ max-value>> [ v-max-value ] when* ] - tri + bi ] bi* ; -M: number render-view* - drop number>string write ; +M: number component-string + drop dup [ number>string ] when ; -M: number render-edit* - >r number>string r> "text" render-input ; +! Integer fields +TUPLE: integer < number ; -M: number render-error* - "text" render-input render-error ; +: ( id -- component ) + integer new-string ; -! Text areas -TUPLE: text ; - -: ( id -- component ) text ; - -M: text validate* drop ; - -M: text render-view* - drop write ; - -: render-textarea - ; - -M: text render-edit* - render-textarea ; - -M: text render-error* - render-textarea render-error ; +M: integer validate* + call-next-method v-integer ; ! Simple captchas -TUPLE: captcha ; +TUPLE: captcha < string ; : ( id -- component ) - captcha construct-delegate ; + captcha new-string ; M: captcha validate* drop v-captcha ; + +! Text areas +TUPLE: textarea-renderer ; + +: textarea-renderer T{ textarea-renderer } ; + +M: textarea-renderer render-view* + drop write ; + +M: textarea-renderer render-edit* + drop ; + +TUPLE: text < string ; + +: new-text ( id class -- component ) + new-string + f >>one-line + textarea-renderer >>renderer ; + +: ( id -- component ) + text new-text ; diff --git a/extra/http/server/components/farkup/farkup.factor b/extra/http/server/components/farkup/farkup.factor index 09c8471905..65e159513d 100755 --- a/extra/http/server/components/farkup/farkup.factor +++ b/extra/http/server/components/farkup/farkup.factor @@ -1,13 +1,16 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: splitting http.server.components kernel io sequences -farkup ; +USING: splitting kernel io sequences farkup accessors +http.server.components ; IN: http.server.components.farkup -TUPLE: farkup ; +TUPLE: farkup-renderer < textarea-renderer ; + +: farkup-renderer T{ farkup-renderer } ; + +M: farkup-renderer render-view* + drop string-lines "\n" join convert-farkup write ; : ( id -- component ) - farkup construct-delegate ; - -M: farkup render-view* - drop string-lines "\n" join convert-farkup write ; + + farkup-renderer >>renderer ; diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor index a0d732c1ef..a8b929bc98 100755 --- a/extra/http/server/db/db.factor +++ b/extra/http/server/db/db.factor @@ -9,8 +9,8 @@ TUPLE: db-persistence responder db params ; C: db-persistence : connect-db ( db-persistence -- ) - [ db>> ] [ params>> ] bi make-db - [ db set ] [ db-open ] [ add-always-destructor ] tri ; + [ db>> ] [ params>> ] bi make-db db-open + [ db set ] [ add-always-destructor ] bi ; M: db-persistence call-responder [ connect-db ] [ responder>> call-responder ] bi ; diff --git a/extra/http/server/forms/forms.factor b/extra/http/server/forms/forms.factor new file mode 100644 index 0000000000..cf8fd4ca8c --- /dev/null +++ b/extra/http/server/forms/forms.factor @@ -0,0 +1,48 @@ +USING: kernel accessors assocs namespaces io.files fry +http.server.actions +http.server.components +http.server.validators +http.server.templating.fhtml ; +IN: http.server.forms + +TUPLE: form < component view-template edit-template components ; + +M: form init V{ } clone >>components ; + +: ( id -- form ) + form f new-component ; + +: add-field ( form component -- form ) + dup id>> pick components>> set-at ; + +: with-form ( form quot -- ) + >r components>> components r> with-variable ; inline + +: set-defaults ( form -- ) + [ + components get [ + swap values get [ + swap default>> or + ] change-at + ] assoc-each + ] with-form ; + +: view-form ( form -- ) + dup view-template>> '[ , run-template ] with-form ; + +: edit-form ( form -- ) + dup edit-template>> '[ , run-template ] with-form ; + +: validate-param ( id component -- ) + [ [ params get at ] [ validate ] bi* ] + [ drop set-value ] 2bi ; + +: (validate-form) ( form -- error? ) + [ + validation-failed? off + components get [ validate-param ] assoc-each + validation-failed? get + ] with-form ; + +: validate-form ( form -- ) + (validate-form) [ validation-failed ] when ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index e1561bce89..8b3d6b8db1 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -105,8 +105,13 @@ SYMBOL: form-hook TUPLE: dispatcher default responders ; +: new-dispatcher ( class -- dispatcher ) + construct-empty + 404-responder get >>default + H{ } clone >>responders ; inline + : ( -- dispatcher ) - 404-responder get H{ } clone dispatcher construct-boa ; + dispatcher new-dispatcher ; : split-path ( path -- rest first ) [ CHAR: / = ] left-trim "/" split1 swap ; @@ -125,9 +130,6 @@ M: dispatcher call-responder ( path dispatcher -- response ) 2drop redirect-with-/ ] if ; -: ( class -- dispatcher ) - swap construct-delegate ; inline - TUPLE: vhost-dispatcher default responders ; : ( -- dispatcher ) diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index a3d06e8f18..0d875d255b 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -17,9 +17,10 @@ M: object init-session* drop ; TUPLE: session-manager responder sessions ; -: ( responder class -- responder' ) - >r session-manager construct-boa - r> construct-delegate ; inline +: construct-session-manager ( responder class -- responder' ) + construct-empty + >>sessions + swap >>responder ; inline SYMBOLS: session session-id session-changed? ; @@ -64,18 +65,18 @@ M: session-saver dispose [ [ session-id set ] [ session set ] bi* ] 2bi [ session-manager set ] [ responder>> call-responder ] bi ; -TUPLE: null-sessions ; +TUPLE: null-sessions < session-manager ; : - null-sessions ; + null-sessions construct-session-manager ; M: null-sessions call-responder ( path responder -- response ) H{ } clone f call-responder/session ; -TUPLE: url-sessions ; +TUPLE: url-sessions < session-manager ; : ( responder -- responder' ) - url-sessions ; + url-sessions construct-session-manager ; : session-id-key "factorsessid" ; @@ -107,10 +108,10 @@ M: url-sessions call-responder ( path responder -- response ) 2drop nip new-url-session ] if ; -TUPLE: cookie-sessions ; +TUPLE: cookie-sessions < session-manager ; : ( responder -- responder' ) - cookie-sessions ; + cookie-sessions construct-session-manager ; : current-cookie-session ( responder -- id namespace/f ) request get session-id-key get-cookie dup diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor index 6cd5c78b72..9ee3c5d4e2 100755 --- a/extra/http/server/templating/fhtml/fhtml.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -1,25 +1,22 @@ ! Copyright (C) 2005 Alex Chapman -! Copyright (C) 2006, 2007 Slava Pestov +! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: continuations sequences kernel parser namespaces io io.files io.streams.string html html.elements source-files debugger combinators math quotations generic strings splitting accessors http.server.static http.server assocs -io.encodings.utf8 fry ; +io.encodings.utf8 fry accessors ; IN: http.server.templating.fhtml : templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ; -! See apps/http-server/test/ or libs/furnace/ for template usage -! examples - ! We use a custom lexer so that %> ends a token even if not ! followed by whitespace -TUPLE: template-lexer ; +TUPLE: template-lexer < lexer ; : ( lines -- lexer ) - template-lexer construct-delegate ; + template-lexer construct-lexer ; M: template-lexer skip-word [ @@ -33,18 +30,18 @@ M: template-lexer skip-word DEFER: <% delimiter : check-<% ( lexer -- col ) - "<%" over lexer-line-text rot lexer-column start* ; + "<%" over line-text>> rot column>> start* ; : found-<% ( accum lexer col -- accum ) [ - over lexer-line-text - >r >r lexer-column r> r> subseq parsed + over line-text>> + >r >r column>> r> r> subseq parsed \ write-html parsed - ] 2keep 2 + swap set-lexer-column ; + ] 2keep 2 + >>column drop ; : still-looking ( accum lexer -- accum ) [ - dup lexer-line-text swap lexer-column tail + [ line-text>> ] [ column>> ] bi tail parsed \ print-html parsed ] keep next-line ;