diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index c875475278..f56ac810d9 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -20,26 +20,25 @@ GENERIC: assoc-clone-like ( assoc exemplar -- newassoc ) GENERIC: >alist ( assoc -- newassoc ) +: (assoc-each) ( assoc quot -- seq quot' ) + >r >alist r> [ first2 ] prepose ; inline + : assoc-find ( assoc quot -- key value ? ) - >r >alist r> [ first2 ] prepose find swap - [ first2 t ] [ drop f f f ] if ; inline + (assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline : key? ( key assoc -- ? ) at* nip ; inline : assoc-each ( assoc quot -- ) - [ f ] compose assoc-find 3drop ; inline - -: (assoc>map) ( quot accum -- quot' ) - [ push ] curry compose ; inline + (assoc-each) each ; inline : assoc>map ( assoc quot exemplar -- seq ) - >r over assoc-size - [ (assoc>map) assoc-each ] keep - r> like ; inline + >r accumulator >r assoc-each r> r> like ; inline + +: assoc-map-as ( assoc quot exemplar -- newassoc ) + >r [ 2array ] compose V{ } assoc>map r> assoc-like ; inline : assoc-map ( assoc quot -- newassoc ) - over >r [ 2array ] compose V{ } assoc>map r> assoc-like ; - inline + over assoc-map-as ; inline : assoc-push-if ( key value quot accum -- ) >r 2keep r> roll diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor index 5900e5a844..7d43187f54 100755 --- a/core/inference/inference-docs.factor +++ b/core/inference/inference-docs.factor @@ -92,7 +92,7 @@ ARTICLE: "inference-errors" "Inference errors" { $subsection missing-effect } ; ARTICLE: "inference" "Stack effect inference" -"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile." +"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")." $nl "The main entry point is a single word which takes a quotation and prints its stack effect and variable usage:" { $subsection infer. } diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index cb33552693..02a7191f0a 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -419,10 +419,11 @@ PRIVATE> : interleave ( seq between quot -- ) [ (interleave) ] 2curry >r dup length swap r> 2each ; inline +: accumulator ( quot -- quot' vec ) + V{ } clone [ [ push ] curry compose ] keep ; inline + : unfold ( pred quot tail -- seq ) - V{ } clone [ - swap >r [ push ] curry compose r> while - ] keep { } like ; inline + swap accumulator >r swap while r> { } like ; inline : follow ( obj quot -- seq ) >r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline diff --git a/extra/base64/base64-tests.factor b/extra/base64/base64-tests.factor index d867351f8b..86c58af505 100644 --- a/extra/base64/base64-tests.factor +++ b/extra/base64/base64-tests.factor @@ -1,8 +1,18 @@ USING: kernel tools.test base64 strings ; -[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> +[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string ] unit-test -[ "" ] [ "" >base64 base64> ] unit-test -[ "a" ] [ "a" >base64 base64> ] unit-test -[ "ab" ] [ "ab" >base64 base64> ] unit-test -[ "abc" ] [ "abc" >base64 base64> ] unit-test +[ "" ] [ "" >base64 base64> >string ] unit-test +[ "a" ] [ "a" >base64 base64> >string ] unit-test +[ "ab" ] [ "ab" >base64 base64> >string ] unit-test +[ "abc" ] [ "abc" >base64 base64> >string ] unit-test + +! From http://en.wikipedia.org/wiki/Base64 +[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ] +[ + "Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure." + >base64 >string +] unit-test + +\ >base64 must-infer +\ base64> must-infer diff --git a/extra/base64/base64.factor b/extra/base64/base64.factor index 600a8f4c3d..d48abc2014 100644 --- a/extra/base64/base64.factor +++ b/extra/base64/base64.factor @@ -1,11 +1,10 @@ -USING: kernel math sequences namespaces io.binary splitting -grouping strings hashtables ; +USING: kernel math sequences io.binary splitting grouping ; IN: base64 r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; + >r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; inline : ch>base64 ( ch -- ch ) "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ; @@ -20,28 +19,26 @@ IN: base64 } nth ; : encode3 ( seq -- seq ) - be> 4 [ 3 swap - -6 * shift HEX: 3f bitand ch>base64 ] with map ; + be> 4 [ -6 * shift HEX: 3f bitand ch>base64 ] with B{ } map-as ; : decode4 ( str -- str ) - [ base64>ch ] map 0 [ swap 6 shift bitor ] reduce 3 >be ; + 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ; : >base64-rem ( str -- str ) - [ 3 0 pad-right encode3 ] keep length 1+ head 4 CHAR: = pad-right ; + [ 3 0 pad-right encode3 ] [ length 1+ ] bi head 4 CHAR: = pad-right ; PRIVATE> : >base64 ( seq -- base64 ) #! cut string into two pieces, convert 3 bytes at a time #! pad string with = when not enough bits - dup length dup 3 mod - cut swap - [ - 3 [ encode3 % ] each - dup empty? [ drop ] [ >base64-rem % ] if - ] "" make ; + dup length dup 3 mod - cut + [ 3 [ encode3 ] map concat ] + [ dup empty? [ drop "" ] [ >base64-rem ] if ] + bi* append ; : base64> ( base64 -- str ) #! input length must be a multiple of 4 - [ - [ 4 [ decode4 % ] each ] keep [ CHAR: = = not ] count-end - ] SBUF" " make swap [ dup pop* ] times >string ; - + [ 4 [ decode4 ] map concat ] + [ [ CHAR: = = not ] count-end ] + bi head* ; diff --git a/extra/cords/cords.factor b/extra/cords/cords.factor index f5cc89f8d5..a7f4246826 100644 --- a/extra/cords/cords.factor +++ b/extra/cords/cords.factor @@ -1,4 +1,4 @@ -! Copysecond (C) 2008 Slava Pestov. +! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs sequences sorting math math.order arrays combinators kernel ; diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 9cc1880cc3..4b431c83bc 100755 --- a/extra/furnace/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -8,6 +8,7 @@ http.server http.server.responses furnace furnace.flash +html.forms html.elements html.components html.components @@ -20,10 +21,10 @@ SYMBOL: params SYMBOL: rest : render-validation-messages ( -- ) - validation-messages get + form get errors>> dup empty? [ drop ] [
    - [
  • message>> escape-string write
    • ] each + [
  • escape-string write
    • ] each
] if ; @@ -37,8 +38,21 @@ TUPLE: action rest authorize init display validate submit ; : ( -- action ) action new-action ; -: flashed-variables ( -- seq ) - { validation-messages named-validation-messages } ; +: set-nested-form ( form name -- ) + dup empty? [ + drop form set + ] [ + dup length 1 = [ + first set-value + ] [ + unclip [ set-nested-form ] nest-form + ] if + ] if ; + +: restore-validation-errors ( -- ) + form fget [ + nested-forms fget set-nested-form + ] when* ; : handle-get ( action -- response ) '[ @@ -46,25 +60,12 @@ TUPLE: action rest authorize init display validate submit ; { [ init>> call ] [ authorize>> call ] - [ drop flashed-variables restore-flash ] + [ drop restore-validation-errors ] [ display>> call ] } cleave ] [ drop <400> ] if ] with-exit-continuation ; -: validation-failed ( -- * ) - post-request? [ f ] [ <400> ] if exit-with ; - -: (handle-post) ( action -- response ) - '[ - , dup submit>> [ - [ validate>> call ] - [ authorize>> call ] - [ submit>> call ] - tri - ] [ drop <400> ] if - ] with-exit-continuation ; - : param ( name -- value ) params get at ; @@ -74,24 +75,29 @@ TUPLE: action rest authorize init display validate submit ; revalidate-url-key param dup [ >url [ same-host? ] keep and ] when ; +: validation-failed ( -- * ) + post-request? revalidate-url and + [ + nested-forms-key param " " split harvest nested-forms set + { form nested-forms } + ] [ <400> ] if* + exit-with ; + : handle-post ( action -- response ) '[ - form-nesting-key params get at " " split harvest - [ , (handle-post) ] - [ swap '[ , , nest-values ] ] reduce - call - ] with-exit-continuation - [ - revalidate-url - [ flashed-variables ] [ <403> ] if* - ] unless* ; + , 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 -- ) - blank-values - init-validation + begin-form handle-rest request get request-params assoc-union params set ; @@ -110,8 +116,7 @@ M: action modify-form validation-failed? [ validation-failed ] when ; : validate-params ( validators -- ) - params get swap validate-values from-object - check-validation ; + params get swap validate-values check-validation ; : validate-integer-id ( -- ) { { "id" [ v-number ] } } validate-params ; diff --git a/extra/furnace/alloy/alloy.factor b/extra/furnace/alloy/alloy.factor index 14ffbaba9d..28c34e6715 100644 --- a/extra/furnace/alloy/alloy.factor +++ b/extra/furnace/alloy/alloy.factor @@ -7,7 +7,8 @@ furnace.flash furnace.sessions furnace.referrer furnace.db -furnace.auth.providers ; +furnace.auth.providers +furnace.auth.login.permits ; IN: furnace.alloy : ( responder db params -- responder' ) @@ -19,7 +20,7 @@ IN: furnace.alloy ] call ; -: state-classes { session flash-scope aside } ; inline +: state-classes { session flash-scope aside permit } ; inline : init-furnace-tables ( -- ) state-classes ensure-tables diff --git a/extra/furnace/auth/auth-tests.factor b/extra/furnace/auth/auth-tests.factor new file mode 100644 index 0000000000..220a8cd04c --- /dev/null +++ b/extra/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/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor index f78cea3835..d9f517aaf4 100755 --- a/extra/furnace/auth/auth.factor +++ b/extra/furnace/auth/auth.factor @@ -1,15 +1,24 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs namespaces kernel sequences sets +destructors combinators +io.encodings.utf8 io.encodings.string io.binary random +checksums checksums.sha2 +html.forms http.server http.server.filters http.server.dispatchers -furnace.sessions -furnace.auth.providers ; +furnace +furnace.actions +furnace.boilerplate +furnace.auth.providers +furnace.auth.providers.db ; IN: furnace.auth SYMBOL: logged-in-user +: logged-in? ( -- ? ) logged-in-user get >boolean ; + GENERIC: init-user-profile ( responder -- ) M: object init-user-profile drop ; @@ -20,6 +29,9 @@ M: dispatcher init-user-profile M: filter-responder init-user-profile responder>> init-user-profile ; +: have-capability? ( capability -- ? ) + logged-in-user get capabilities>> member? ; + : profile ( -- assoc ) logged-in-user get profile>> ; : user-changed ( -- ) @@ -41,3 +53,86 @@ SYMBOL: capabilities V{ } clone capabilities set-global : define-capability ( word -- ) capabilities get adjoin ; + +TUPLE: realm < dispatcher name users checksum ; + +GENERIC: login-required* ( realm -- response ) + +GENERIC: logged-in-username ( realm -- username ) + +: login-required ( -- * ) 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 ; 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* ; + +M: realm call-responder* ( path responder -- response ) + dup realm set + dup logged-in-username dup [ users get-user ] when init-user + 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 ; + +TUPLE: protected < filter-responder description capabilities ; + +: ( responder -- protected ) + protected new + swap >>responder ; + +: check-capabilities ( responder user/f -- ? ) + { + { [ dup not ] [ 2drop f ] } + { [ dup deleted>> 1 = ] [ 2drop f ] } + [ [ capabilities>> ] bi@ subset? ] + } cond ; + +M: protected call-responder* ( path responder -- response ) + dup protected set + dup logged-in-user get check-capabilities + [ call-next-method ] [ 2drop realm get login-required* ] if ; + +: ( 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/extra/furnace/auth/basic/basic.factor b/extra/furnace/auth/basic/basic.factor index c8d542c219..e478f70dcc 100755 --- a/extra/furnace/auth/basic/basic.factor +++ b/extra/furnace/auth/basic/basic.factor @@ -1,41 +1,29 @@ ! Copyright (c) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors quotations assocs kernel splitting -base64 html.elements io combinators sequences -http http.server.filters http.server.responses http.server -furnace.auth.providers furnace.auth.login ; +USING: accessors kernel splitting base64 namespaces strings +http http.server.responses furnace.auth ; IN: furnace.auth.basic -TUPLE: basic-auth < filter-responder realm provider ; +TUPLE: basic-auth-realm < realm ; -C: basic-auth +: ( responder name -- realm ) + basic-auth-realm new-realm ; -: authorization-ok? ( provider header -- ? ) - #! Given the realm and the 'Authorization' header, - #! authenticate the user. +: parse-basic-auth ( header -- username/f password/f ) dup [ " " split1 swap "Basic" = [ - base64> ":" split1 spin check-login - ] [ - 2drop f - ] if - ] [ - 2drop f - ] if ; + base64> >string ":" split1 + ] [ drop f f ] if + ] [ drop f f ] if ; : <401> ( realm -- response ) - 401 "Unauthorized" - "Basic realm=\"" rot "\"" 3append - "WWW-Authenticate" set-header - [ - - "Username or Password is invalid" write - - ] >>body ; + 401 "Invalid username or password" + [ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ; -: logged-in? ( request responder -- ? ) - provider>> swap "authorization" header authorization-ok? ; +M: basic-auth-realm login-required* ( realm -- response ) + name>> <401> ; -M: basic-auth call-responder* ( request path responder -- response ) - pick over logged-in? - [ call-next-method ] [ 2nip realm>> <401> ] if ; +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/extra/furnace/auth/login/boilerplate.xml b/extra/furnace/auth/boilerplate.xml similarity index 100% rename from extra/furnace/auth/login/boilerplate.xml rename to extra/furnace/auth/boilerplate.xml diff --git a/extra/furnace/auth/features/edit-profile/edit-profile-tests.factor b/extra/furnace/auth/features/edit-profile/edit-profile-tests.factor new file mode 100644 index 0000000000..d0fdf22c27 --- /dev/null +++ b/extra/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/extra/furnace/auth/features/edit-profile/edit-profile.factor b/extra/furnace/auth/features/edit-profile/edit-profile.factor new file mode 100644 index 0000000000..e03fca99a5 --- /dev/null +++ b/extra/furnace/auth/features/edit-profile/edit-profile.factor @@ -0,0 +1,67 @@ +! 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.asides +furnace.actions ; +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 + + [ + logged-in-user get 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 logged-in-user get 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" $login" 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/extra/furnace/auth/login/edit-profile.xml b/extra/furnace/auth/features/edit-profile/edit-profile.xml similarity index 96% rename from extra/furnace/auth/login/edit-profile.xml rename to extra/furnace/auth/features/edit-profile/edit-profile.xml index 6beaf5de6d..011cc2bdf8 100644 --- a/extra/furnace/auth/login/edit-profile.xml +++ b/extra/furnace/auth/features/edit-profile/edit-profile.xml @@ -4,7 +4,7 @@ Edit Profile - + diff --git a/extra/furnace/auth/login/recover-1.xml b/extra/furnace/auth/features/recover-password/recover-1.xml similarity index 100% rename from extra/furnace/auth/login/recover-1.xml rename to extra/furnace/auth/features/recover-password/recover-1.xml diff --git a/extra/furnace/auth/login/recover-2.xml b/extra/furnace/auth/features/recover-password/recover-2.xml similarity index 100% rename from extra/furnace/auth/login/recover-2.xml rename to extra/furnace/auth/features/recover-password/recover-2.xml diff --git a/extra/furnace/auth/login/recover-3.xml b/extra/furnace/auth/features/recover-password/recover-3.xml similarity index 100% rename from extra/furnace/auth/login/recover-3.xml rename to extra/furnace/auth/features/recover-password/recover-3.xml diff --git a/extra/furnace/auth/login/recover-4.xml b/extra/furnace/auth/features/recover-password/recover-4.xml similarity index 100% rename from extra/furnace/auth/login/recover-4.xml rename to extra/furnace/auth/features/recover-password/recover-4.xml diff --git a/extra/furnace/auth/features/recover-password/recover-password-tests.factor b/extra/furnace/auth/features/recover-password/recover-password-tests.factor new file mode 100644 index 0000000000..b589c52624 --- /dev/null +++ b/extra/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/extra/furnace/auth/features/recover-password/recover-password.factor b/extra/furnace/auth/features/recover-password/recover-password.factor new file mode 100644 index 0000000000..1e8d163e99 --- /dev/null +++ b/extra/furnace/auth/features/recover-password/recover-password.factor @@ -0,0 +1,123 @@ +! 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 +http http.server.responses http.server.dispatchers +furnace furnace.actions furnace.auth furnace.auth.providers ; +IN: furnace.auth.features.recover-password + +SYMBOL: lost-password-from + +: current-host ( -- string ) + request get url>> host>> host-name or ; + +: new-password-url ( user -- url ) + "recover-3" + swap [ + [ username>> "username" set ] + [ ticket>> "ticket" set ] + bi + ] H{ } make-assoc + derive-url ; + +: 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 % + "\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 "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" $login/recover-2" + ] >>submit ; + +: ( -- action ) + + { realm "recover-2" } >>template ; + +: ( -- action ) + + [ + { + { "username" [ v-username ] } + { "ticket" [ v-required ] } + } validate-params + ] >>init + + { realm "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" $login/recover-4" + ] [ + <403> + ] if* + ] >>submit ; + +: ( -- action ) + + { realm "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/extra/furnace/auth/login/register.xml b/extra/furnace/auth/features/registration/register.xml similarity index 100% rename from extra/furnace/auth/login/register.xml rename to extra/furnace/auth/features/registration/register.xml diff --git a/extra/furnace/auth/features/registration/registration-tests.factor b/extra/furnace/auth/features/registration/registration-tests.factor new file mode 100644 index 0000000000..e770f35586 --- /dev/null +++ b/extra/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/extra/furnace/auth/features/registration/registration.factor b/extra/furnace/auth/features/registration/registration.factor new file mode 100644 index 0000000000..2bc7688b10 --- /dev/null +++ b/extra/furnace/auth/features/registration/registration.factor @@ -0,0 +1,43 @@ +! 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 ; +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/extra/furnace/auth/login/login-tests.factor b/extra/furnace/auth/login/login-tests.factor index 5095ebdb85..64f7bd3b96 100755 --- a/extra/furnace/auth/login/login-tests.factor +++ b/extra/furnace/auth/login/login-tests.factor @@ -1,6 +1,4 @@ IN: furnace.auth.login.tests USING: tools.test furnace.auth.login ; -\ must-infer -\ allow-registration must-infer -\ allow-password-recovery must-infer +\ must-infer diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index a1d2bf47c3..e2b208de3a 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -1,99 +1,67 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors quotations assocs kernel splitting -combinators sequences namespaces hashtables sets -fry arrays threads qualified random validators words -io -io.sockets -io.encodings.utf8 -io.encodings.string -io.binary -continuations -destructors -checksums -checksums.sha2 -validators -html.components -html.elements -urls -http -http.server -http.server.dispatchers -http.server.filters -http.server.responses +USING: kernel accessors namespaces sequences math.parser +calendar validators urls html.forms +http http.server http.server.dispatchers furnace furnace.auth -furnace.auth.providers -furnace.auth.providers.db -furnace.actions -furnace.asides furnace.flash +furnace.asides +furnace.actions furnace.sessions -furnace.boilerplate ; -QUALIFIED: smtp +furnace.utilities +furnace.auth.login.permits ; IN: furnace.auth.login -: word>string ( word -- string ) - [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ; +SYMBOL: permit-id -: words>strings ( seq -- seq' ) - [ word>string ] map ; +: permit-id-key ( realm -- string ) + [ >hex 2 CHAR: 0 pad-left ] { } map-as concat + "__p_" prepend ; -: string>word ( string -- word ) - ":" split1 swap lookup ; +: client-permit-id ( realm -- id/f ) + permit-id-key client-state dup [ string>number ] when ; -: strings>words ( seq -- seq' ) - [ string>word ] map ; +TUPLE: login-realm < realm timeout domain ; -TUPLE: login < dispatcher users checksum ; +M: login-realm call-responder* + [ name>> client-permit-id permit-id set ] + [ call-next-method ] + bi ; -TUPLE: protected < filter-responder description capabilities ; +M: login-realm logged-in-username + drop permit-id get dup [ get-permit-uid ] when ; -: ( responder -- protected ) - protected new - swap >>responder ; +M: login-realm modify-form ( responder -- ) + drop permit-id get realm get name>> permit-id-key hidden-form-field ; -: users ( -- provider ) - login get users>> ; +: ( -- cookie ) + permit-id get realm get name>> permit-id-key + "$login-realm" resolve-base-path >>path + realm get timeout>> from-now >>expires + realm get domain>> >>domain ; -: encode-password ( string salt -- bytes ) - [ utf8 encode ] [ 4 >be ] bi* append - login get checksum>> checksum-bytes ; +: put-permit-cookie ( response -- response' ) + put-cookie ; -: >>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 ; - -! Destructor -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 ; - -! ! ! Login : successful-login ( user -- response ) - username>> set-uid URL" $login" end-aside ; + [ username>> make-permit permit-id set ] [ init-user ] bi + URL" $realm" end-aside + put-permit-cookie ; -: login-failed ( -- * ) - "invalid username or password" validation-error - validation-failed ; +: 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 ) [ @@ -102,7 +70,7 @@ SYMBOL: capabilities capabilities get words>strings "capabilities" set-value ] >>init - { login "login" } >>template + { login-realm "login" } >>template [ { @@ -115,286 +83,21 @@ SYMBOL: capabilities [ successful-login ] [ login-failed ] if* ] >>submit ; -! ! ! New user registration - -: user-exists ( -- * ) - "username taken" validation-error - validation-failed ; - -: password-mismatch ( -- * ) - "passwords do not match" validation-error - validation-failed ; - -: same-password-twice ( -- ) - "new-password" value "verify-password" value = - [ password-mismatch ] unless ; - -: ( -- action ) - - { login "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* - - login get init-user-profile - - successful-login - ] >>submit ; - -! ! ! Editing user profile - -: ( -- action ) - - [ - logged-in-user get - [ username>> "username" set-value ] - [ realname>> "realname" set-value ] - [ email>> "email" set-value ] - tri - ] >>init - - { login "edit-profile" } >>template - - [ - uid "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 uid 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" $login" end-aside - ] >>submit - - - "edit your profile" >>description ; - -! ! ! Password recovery - -SYMBOL: lost-password-from - -: current-host ( -- string ) - request get url>> host>> host-name or ; - -: new-password-url ( user -- url ) - "recover-3" - swap [ - [ username>> "username" set ] - [ ticket>> "ticket" set ] - bi - ] H{ } make-assoc - derive-url ; - -: password-email ( user -- email ) - smtp: - [ "[ " % 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 % - "\n\n" % - "Love,\n" % - "\n" % - " FactorBot\n" % - ] "" make >>body ; - -: send-password-email ( user -- ) - '[ , password-email smtp:send-email ] - "E-mail send thread" spawn drop ; - -: ( -- action ) - - { login "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" $login/recover-2" - ] >>submit ; - -: ( -- action ) - - { login "recover-2" } >>template ; - -: ( -- action ) - - [ - { - { "username" [ v-username ] } - { "ticket" [ v-required ] } - } validate-params - ] >>init - - { login "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" $login/recover-4" - ] [ - <403> - ] if* - ] >>submit ; - -: ( -- action ) - - { login "recover-4" } >>template ; - -! ! ! Logout : ( -- action ) - [ - f set-uid - URL" $login" end-aside - ] >>submit ; + [ logout ] >>submit + + "logout" >>description ; -! ! ! Authentication logic -: show-login-page ( -- response ) +M: login-realm login-required* + drop begin-aside protected get description>> description set protected get capabilities>> capabilities set - URL" $login/login" flashed-variables ; + URL" $realm/login" flashed-variables ; -: login-required ( -- * ) - show-login-page exit-with ; - -: have-capability? ( capability -- ? ) - logged-in-user get capabilities>> member? ; - -: check-capabilities ( responder user/f -- ? ) - dup [ [ capabilities>> ] bi@ subset? ] [ 2drop f ] if ; - -M: protected call-responder* ( path responder -- response ) - dup protected set - dup logged-in-user get check-capabilities - [ call-next-method ] [ 2drop show-login-page ] if ; - -: init-user ( -- ) - uid [ - users get-user - [ logged-in-user set ] - [ save-user-after ] bi - ] when* ; - -M: login call-responder* ( path responder -- response ) - dup login set - init-user - call-next-method ; - -: ( responder -- responder' ) - - { login "boilerplate" } >>template ; - -: ( responder -- auth ) - login new-dispatcher - swap >>default - "login" add-responder - "logout" add-responder - users-in-db >>users - sha-256 >>checksum ; - -! ! ! Configuration - -: allow-edit-profile ( login -- login ) - "edit-profile" add-responder ; - -: allow-registration ( login -- login ) - - "register" add-responder ; - -: allow-password-recovery ( login -- login ) - - "recover-password" add-responder - - "recover-2" add-responder - - "recover-3" add-responder - - "recover-4" add-responder ; - -: allow-edit-profile? ( -- ? ) - login get responders>> "edit-profile" swap key? ; - -: allow-registration? ( -- ? ) - login get responders>> "register" swap key? ; - -: allow-password-recovery? ( -- ? ) - login get responders>> "recover-password" swap key? ; +: ( responder name -- auth ) + login-realm new-realm + "login" add-responder + "logout" add-responder + 20 minutes >>timeout ; diff --git a/extra/furnace/auth/login/login.xml b/extra/furnace/auth/login/login.xml index a7ac92bf44..81f9520e76 100644 --- a/extra/furnace/auth/login/login.xml +++ b/extra/furnace/auth/login/login.xml @@ -43,11 +43,11 @@

- + Register | - + Recover Password

diff --git a/extra/furnace/auth/login/permits/permits.factor b/extra/furnace/auth/login/permits/permits.factor new file mode 100644 index 0000000000..49cf98e0e3 --- /dev/null +++ b/extra/furnace/auth/login/permits/permits.factor @@ -0,0 +1,30 @@ +USING: accessors namespaces combinators.lib kernel +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/extra/furnace/auth/providers/assoc/assoc-tests.factor b/extra/furnace/auth/providers/assoc/assoc-tests.factor index 8f9eeaa7a5..8fe1dd4dd4 100755 --- a/extra/furnace/auth/providers/assoc/assoc-tests.factor +++ b/extra/furnace/auth/providers/assoc/assoc-tests.factor @@ -1,11 +1,11 @@ IN: furnace.auth.providers.assoc.tests -USING: furnace.actions furnace.auth.providers +USING: furnace.actions furnace.auth furnace.auth.providers furnace.auth.providers.assoc furnace.auth.login tools.test namespaces accessors kernel ; - + "Test" >>users -login set +realm set [ t ] [ "slava" diff --git a/extra/furnace/auth/providers/db/db-tests.factor b/extra/furnace/auth/providers/db/db-tests.factor index e5914c7ab3..fac5c23e4a 100755 --- a/extra/furnace/auth/providers/db/db-tests.factor +++ b/extra/furnace/auth/providers/db/db-tests.factor @@ -1,14 +1,13 @@ 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 ; - - users-in-db >>users -login set + "test" realm set [ "auth-test.db" temp-file delete-file ] ignore-errors diff --git a/extra/furnace/boilerplate/boilerplate.factor b/extra/furnace/boilerplate/boilerplate.factor index 7c5b7a0c81..a976199661 100644 --- a/extra/furnace/boilerplate/boilerplate.factor +++ b/extra/furnace/boilerplate/boilerplate.factor @@ -1,19 +1,26 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces -html.templates html.templates.chloe +html.forms +html.templates +html.templates.chloe locals http.server http.server.filters furnace ; IN: furnace.boilerplate -TUPLE: boilerplate < filter-responder template ; +TUPLE: boilerplate < filter-responder template init ; -: ( responder -- boilerplate ) f boilerplate boa ; +: ( responder -- boilerplate ) + boilerplate new + swap >>responder + [ ] >>init ; M:: boilerplate call-responder* ( path responder -- ) + begin-form path responder call-next-method + responder init>> call dup content-type>> "text/html" = [ clone [| body | [ diff --git a/extra/furnace/db/db.factor b/extra/furnace/db/db.factor index 8487b4b3fc..b4a4386015 100755 --- a/extra/furnace/db/db.factor +++ b/extra/furnace/db/db.factor @@ -1,8 +1,7 @@ ! 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 -furnace.sessions ; +db db.pools io.pools http.server http.server.filters ; IN: furnace.db TUPLE: db-persistence < filter-responder pool ; diff --git a/extra/furnace/flash/flash.factor b/extra/furnace/flash/flash.factor index 43e0d293a5..e06cdac090 100644 --- a/extra/furnace/flash/flash.factor +++ b/extra/furnace/flash/flash.factor @@ -25,7 +25,9 @@ TUPLE: flash-scopes < server-state-manager ; SYMBOL: flash-scope -: fget ( key -- value ) flash-scope get at ; +: fget ( key -- value ) + flash-scope get dup + [ namespace>> at ] [ 2drop f ] if ; : get-flash-scope ( id -- flash-scope ) dup [ flash-scope get-state ] when diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index a51841d4ad..521f8a3bc1 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -10,6 +10,7 @@ xml.entities xml.writer html.components html.elements +html.forms html.templates html.templates.chloe html.templates.chloe.syntax @@ -30,7 +31,7 @@ IN: furnace : base-path ( string -- pair ) dup responder-nesting get - [ second class word-name = ] with find nip + [ second class superclasses [ word-name = ] with contains? ] with find nip [ first ] [ "No such responder: " swap append throw ] ?if ; : resolve-base-path ( string -- string' ) @@ -95,6 +96,19 @@ M: object modify-form drop ; request get url>> [ [ 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 -- ) @@ -154,11 +168,11 @@ CHLOE: a input/> ] [ 2drop ] if ; -: form-nesting-key "__n" ; +: nested-forms-key "__n" ; : form-magic ( tag -- ) [ modify-form ] each-responder - nested-values get " " join f like form-nesting-key hidden-form-field + nested-forms get " " join f like nested-forms-key hidden-form-field "for" optional-attr [ "," split [ hidden render ] each ] when* ; : form-start-tag ( tag -- ) diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 4be7403e39..863b8f87cb 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -9,14 +9,13 @@ html.elements furnace furnace.cache ; IN: furnace.sessions -TUPLE: session < server-state uid namespace user-agent client changed? ; +TUPLE: session < server-state namespace user-agent client changed? ; : ( id -- session ) session new-server-state ; session "SESSIONS" { - { "uid" "UID" { VARCHAR 255 } } { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ } { "user-agent" "USER_AGENT" TEXT +not-null+ } { "client" "CLIENT" TEXT +not-null+ } @@ -57,12 +56,6 @@ TUPLE: sessions < server-state-manager domain verify? ; [ namespace>> swap change-at ] keep (session-changed) ; inline -: uid ( -- uid ) - session get uid>> ; - -: set-uid ( uid -- ) - session get [ (>>uid) ] [ (session-changed) ] bi ; - : init-session ( session -- ) session [ sessions get init-session* ] with-variable ; @@ -104,20 +97,6 @@ M: session-saver dispose : session-id-key "__s" ; -: cookie-session-id ( request -- id/f ) - session-id-key get-cookie - dup [ value>> string>number ] when ; - -: post-session-id ( request -- id/f ) - session-id-key swap request-params at string>number ; - -: request-session-id ( -- id/f ) - request get dup method>> { - { "GET" [ cookie-session-id ] } - { "HEAD" [ cookie-session-id ] } - { "POST" [ post-session-id ] } - } case ; - : verify-session ( session -- session ) sessions get verify?>> [ dup [ @@ -129,16 +108,18 @@ M: session-saver dispose ] when ; : request-session ( -- session/f ) - request-session-id get-session verify-session ; + session-id-key + client-state dup [ string>number ] when + get-session verify-session ; -: ( id -- cookie ) - session-id-key +: ( -- cookie ) + session get id>> session-id-key "$sessions" resolve-base-path >>path sessions get timeout>> from-now >>expires sessions get domain>> >>domain ; : put-session-cookie ( response -- response' ) - session get id>> number>string put-cookie ; + put-cookie ; M: sessions modify-form ( responder -- ) drop session get id>> session-id-key hidden-form-field ; @@ -147,6 +128,3 @@ M: sessions call-responder* ( path responder -- response ) sessions set request-session [ begin-session ] unless* existing-session put-session-cookie ; - -: logout-all-sessions ( uid -- ) - session new swap >>uid delete-tuples ; diff --git a/extra/furnace/utilities/utilities.factor b/extra/furnace/utilities/utilities.factor new file mode 100644 index 0000000000..20c05d459f --- /dev/null +++ b/extra/furnace/utilities/utilities.factor @@ -0,0 +1,19 @@ +! Copyright (c) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: words kernel sequences splitting ; +IN: furnace.utilities + +: word>string ( word -- string ) + [ word-vocabulary ] [ word-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/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor index 8ec3a58611..5779371078 100644 --- a/extra/html/components/components-tests.factor +++ b/extra/html/components/components-tests.factor @@ -1,9 +1,9 @@ IN: html.components.tests USING: tools.test kernel io.streams.string io.streams.null accessors inspector html.streams -html.elements html.components namespaces ; +html.elements html.components html.forms namespaces ; -[ ] [ blank-values ] unit-test +[ ] [ begin-form ] unit-test [ ] [ 3 "hi" set-value ] unit-test @@ -63,7 +63,7 @@ TUPLE: color red green blue ; ] with-null-writer ] unit-test -[ ] [ blank-values ] unit-test +[ ] [ begin-form ] unit-test [ ] [ "new york" "city1" set-value ] unit-test @@ -101,7 +101,7 @@ TUPLE: color red green blue ; ] with-null-writer ] unit-test -[ ] [ blank-values ] unit-test +[ ] [ begin-form ] unit-test [ ] [ t "delivery" set-value ] unit-test @@ -167,12 +167,19 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ; = ] unit-test -[ ] [ blank-values ] unit-test +[ ] [ begin-form ] unit-test [ ] [ "factor" [ "concatenative" "model" set-value - ] nest-values + ] nest-form ] unit-test -[ H{ { "factor" H{ { "model" "concatenative" } } } } ] [ values get ] unit-test +[ + H{ + { + "factor" + T{ form f V{ } H{ { "model" "concatenative" } } } + } + } +] [ values ] unit-test diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor index 7355cd153d..b6b7f22b1d 100644 --- a/extra/html/components/components.factor +++ b/extra/html/components/components.factor @@ -1,85 +1,26 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces io math.parser assocs classes -classes.tuple words arrays sequences sequences.lib splitting -mirrors hashtables combinators continuations math strings -fry locals calendar calendar.format xml.entities validators -html.elements html.streams xmode.code2html farkup inspector -lcs.diff2html urls present ; +classes.tuple words arrays sequences splitting mirrors +hashtables combinators continuations math strings inspector +fry locals calendar calendar.format xml.entities +validators urls present +xmode.code2html lcs.diff2html farkup +html.elements html.streams html.forms ; IN: html.components -SYMBOL: values - -: check-value-name ( name -- name ) - dup string? [ "Value name not a string" throw ] unless ; - -: 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 ; - -: prepare-value ( name object -- value name object ) - [ [ value ] keep ] dip ; inline - -: from-object ( object -- ) - dup assoc? [ ] unless - values get swap update ; - -: deposit-values ( destination names -- ) - [ dup value ] H{ } map>assoc update ; - -: deposit-slots ( destination names -- ) - [ ] dip deposit-values ; - -: with-each-value ( name quot -- ) - [ value ] dip '[ - [ - values [ clone ] change - 1+ "index" set-value - "value" set-value - @ - ] with-scope - ] each-index ; inline - -: with-each-object ( name quot -- ) - [ value ] dip '[ - [ - blank-values - 1+ "index" set-value - from-object - @ - ] with-scope - ] each-index ; inline - -SYMBOL: nested-values - -: with-values ( name quot -- ) - '[ - , - [ nested-values [ swap prefix ] change ] - [ value blank-values from-object ] - bi - @ - ] with-scope ; inline - -: nest-values ( name quot -- ) - swap [ - [ - H{ } clone [ values set call ] keep - ] with-scope - ] dip set-value ; inline - GENERIC: render* ( value name render -- ) : render ( name renderer -- ) - over named-validation-messages get at [ - [ value>> ] [ message>> ] bi - [ -rot render* ] dip - render-error - ] [ - prepare-value render* - ] if* ; + prepare-value + [ + dup validation-error? + [ [ message>> ] [ value>> ] bi ] + [ f swap ] + if + ] 2dip + render* + [ render-error ] when* ; > "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/extra/html/forms/forms.factor b/extra/html/forms/forms.factor new file mode 100644 index 0000000000..0da3fcb0b3 --- /dev/null +++ b/extra/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 ; + +:
( -- form ) + form new + V{ } clone >>errors + H{ } clone >>values ; + +M: form clone + call-next-method + [ clone ] change-errors + [ clone ] change-values ; + +: check-value-name ( name -- name ) + dup string? [ "Value name not a string" throw ] unless ; + +: values ( -- assoc ) + form get values>> ; + +: value ( name -- value ) + check-value-name values at ; + +: set-value ( value name -- ) + check-value-name values set-at ; + +: begin-form ( -- ) form set ; + +: prepare-value ( name object -- value name object ) + [ [ value ] keep ] dip ; inline + +: from-object ( object -- ) + [ values ] [ make-mirror ] bi* update ; + +: to-object ( destination names -- ) + [ make-mirror ] [ values extract-keys ] bi* update ; + +: with-each-value ( name quot -- ) + [ value ] dip '[ + [ + form [ clone ] change + 1+ "index" set-value + "value" set-value + @ + ] with-scope + ] each-index ; inline + +: with-each-object ( name quot -- ) + [ value ] dip '[ + [ + begin-form + 1+ "index" set-value + from-object + @ + ] with-scope + ] each-index ; inline + +SYMBOL: nested-forms + +: with-form ( name quot -- ) + '[ + , + [ nested-forms [ swap prefix ] change ] + [ value form set ] + bi + @ + ] with-scope ; inline + +: nest-form ( name quot -- ) + swap [ + [ + form set + call + form get + ] with-scope + ] dip set-value ; inline + +TUPLE: validation-error value message ; + +C: validation-error + +: validation-error ( message -- ) + form get + t >>validation-failed + errors>> push ; + +: validation-failed? ( -- ? ) + form get validation-failed>> ; + +: define-validators ( class validators -- ) + >hashtable "validators" set-word-prop ; + +: validate ( value quot -- result ) + [ ] recover ; inline + +: validate-value ( name value quot -- ) + validate + dup validation-error? [ form get t >>validation-failed drop ] when + swap set-value ; + +: validate-values ( assoc validators -- assoc' ) + swap '[ dup , at _ validate-value ] assoc-each ; diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor index 433aedbc9a..4048836cfe 100644 --- a/extra/html/templates/chloe/chloe-tests.factor +++ b/extra/html/templates/chloe/chloe-tests.factor @@ -1,7 +1,7 @@ USING: html.templates html.templates.chloe tools.test io.streams.string kernel sequences ascii boxes -namespaces xml html.components -splitting unicode.categories furnace ; +namespaces xml html.components html.forms +splitting unicode.categories furnace accessors ; IN: html.templates.chloe.tests [ f ] [ f parse-query-attr ] unit-test @@ -9,13 +9,13 @@ IN: html.templates.chloe.tests [ f ] [ "" parse-query-attr ] unit-test [ H{ { "a" "b" } } ] [ - blank-values + begin-form "b" "a" set-value "a" parse-query-attr ] unit-test [ H{ { "a" "b" } { "c" "d" } } ] [ - blank-values + begin-form "b" "a" set-value "d" "c" set-value "a,c" parse-query-attr @@ -69,7 +69,7 @@ IN: html.templates.chloe.tests ] run-template ] unit-test -[ ] [ blank-values ] unit-test +[ ] [ begin-form ] unit-test [ ] [ "A label" "label" set-value ] unit-test @@ -157,10 +157,10 @@ TUPLE: person first-name last-name ; ] run-template ] unit-test -[ ] [ blank-values ] unit-test +[ ] [ begin-form ] unit-test [ ] [ - H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "person" set-value + H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } >>values "person" set-value ] unit-test [ "
RBaxterUnknown
" ] [ @@ -170,7 +170,7 @@ TUPLE: person first-name last-name ; ] unit-test [ ] [ - blank-values + begin-form { "a" "b" } "choices" set-value "true" "b" set-value ] unit-test diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor index 936c06ae7e..32fe954178 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/extra/html/templates/chloe/chloe.factor @@ -5,6 +5,7 @@ classes.tuple assocs splitting words arrays memoize io io.files io.encodings.utf8 io.streams.string unicode.case tuple-syntax mirrors fry math urls present multiline xml xml.data xml.writer xml.utilities +html.forms html.elements html.components html.templates @@ -76,7 +77,7 @@ CHLOE: each [ with-each-value ] (bind-tag) ; CHLOE: bind-each [ with-each-object ] (bind-tag) ; -CHLOE: bind [ with-values ] (bind-tag) ; +CHLOE: bind [ with-form ] (bind-tag) ; : error-message-tag ( tag -- ) children>string render-error ; diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index daf4ad88d3..28a605174a 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -14,7 +14,7 @@ tuple-syntax namespaces urls ; method: "GET" version: "1.1" cookies: V{ } - header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } } + header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } } } ] [ "http://www.apple.com/index.html" @@ -27,7 +27,7 @@ tuple-syntax namespaces urls ; method: "GET" version: "1.1" cookies: V{ } - header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } } + header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } } } ] [ "https://www.amazon.com/index.html" diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index bc206f08b7..73d26aa327 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -122,7 +122,7 @@ read-response-test-1' 1array [ ! Live-fire exercise USING: http.server http.server.static furnace.sessions furnace.alloy -furnace.actions furnace.auth.login furnace.db http.client +furnace.actions furnace.auth furnace.auth.login furnace.db http.client io.server io.files io io.encodings.ascii accessors namespaces threads http.server.responses http.server.redirection @@ -176,7 +176,7 @@ test-db [ [ - + "Test" "" add-responder add-quit-action @@ -206,7 +206,7 @@ test-db [ [ [ [ "Hi" write ] "text/plain" ] >>display - + "Test" "" add-responder add-quit-action @@ -223,7 +223,8 @@ test-db [ [ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test -USING: html.components html.elements xml xml.utilities validators +USING: html.components html.elements html.forms +xml xml.utilities validators furnace furnace.flash ; SYMBOL: a @@ -275,3 +276,7 @@ SYMBOL: a [ 4 ] [ a get-global ] unit-test [ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test + +! Test cloning +[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test +[ f ] [ <404> dup clone "b" "a" put-cookie drop "a" get-cookie ] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 521c18c703..025e2c8441 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -6,7 +6,8 @@ assocs sequences splitting sorting sets debugger strings vectors hashtables quotations arrays byte-arrays math.parser calendar calendar.format present -io io.encodings.iana io.encodings.binary io.encodings.8-bit +io io.encodings io.encodings.iana io.encodings.binary +io.encodings.8-bit unicode.case unicode.categories qualified @@ -98,23 +99,29 @@ TUPLE: cookie name value path domain expires max-age http-only ; drop ] { } make ; +: check-cookie-string ( string -- string' ) + dup "=;'\"" intersect empty? + [ "Bad cookie name or value" throw ] unless ; + : (unparse-cookie) ( key value -- ) { { f [ drop ] } - { t [ , ] } + { t [ check-cookie-string , ] } [ { { [ dup timestamp? ] [ timestamp>cookie-string ] } { [ dup duration? ] [ dt>seconds number>string ] } + { [ dup real? ] [ number>string ] } [ ] } cond - "=" swap 3append , + check-cookie-string "=" swap check-cookie-string 3append , ] } case ; : unparse-cookie ( cookie -- strings ) [ - dup name>> >lower over value>> (unparse-cookie) + dup name>> check-cookie-string >lower + over value>> (unparse-cookie) "path" over path>> (unparse-cookie) "domain" over domain>> (unparse-cookie) "expires" over expires>> (unparse-cookie) @@ -146,7 +153,7 @@ cookies ; H{ } clone >>header V{ } clone >>cookies "close" "connection" set-header - "Factor http.client vocabulary" "user-agent" set-header ; + "Factor http.client" "user-agent" set-header ; : read-method ( request -- request ) " " read-until [ "Bad request: method" throw ] unless @@ -295,9 +302,15 @@ body ; H{ } clone >>header "close" "connection" set-header now timestamp>http-string "date" set-header + "Factor http.server" "server" set-header latin1 >>content-charset V{ } clone >>cookies ; +M: response clone + call-next-method + [ clone ] change-header + [ clone ] change-cookies ; + : read-response-version ( response -- response ) " \t" read-until [ "Bad response: version" throw ] unless @@ -363,7 +376,11 @@ M: response write-response ( respose -- ) M: response write-full-response ( request response -- ) dup write-response - swap method>> "HEAD" = [ write-response-body ] unless ; + swap method>> "HEAD" = [ + [ content-charset>> encode-output ] + [ write-response-body ] + bi + ] unless ; : get-cookie ( request/response name -- cookie/f ) [ cookies>> ] dip '[ , _ name>> = ] find nip ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 03822ec854..f709939e21 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences arrays namespaces splitting vocabs.loader destructors assocs debugger continuations -combinators tools.vocabs math +combinators tools.vocabs tools.time math io io.server io.sockets @@ -26,7 +26,9 @@ SYMBOL: responder-nesting SYMBOL: main-responder -SYMBOL: development-mode +SYMBOL: development? + +SYMBOL: benchmark? ! path is a sequence of path component strings GENERIC: call-responder* ( path responder -- response ) @@ -55,26 +57,19 @@ main-responder global [ <404> or ] change-at : <500> ( error -- response ) 500 "Internal server error" - swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ; + swap development? get [ '[ , http-error. ] >>body ] [ drop ] if ; : do-response ( response -- ) - [ write-response ] + [ request get swap write-full-response ] [ - request get method>> "HEAD" = [ drop ] [ - '[ - , - [ content-charset>> encode-output ] - [ write-response-body ] - bi - ] - [ - utf8 [ - development-mode get - [ http-error. ] [ drop "Response error" rethrow ] if - ] with-encoded-output - ] recover - ] if - ] bi ; + [ \ do-response log-error ] + [ + utf8 [ + development? get + [ http-error. ] [ drop "Response error" write ] if + ] with-encoded-output + ] bi + ] recover ; LOG: httpd-hit NOTICE @@ -84,7 +79,7 @@ LOG: httpd-header NOTICE tuck header 2array httpd-header ; : log-request ( request -- ) - [ [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi 3array httpd-hit ] + [ [ method>> ] [ url>> ] bi 2array httpd-hit ] [ { "user-agent" "x-forwarded-for" } [ log-header ] with each ] bi ; @@ -121,13 +116,20 @@ LOG: httpd-header NOTICE ] [ [ \ do-request log-error ] [ <500> ] bi ] recover ; : ?refresh-all ( -- ) - development-mode get-global - [ global [ refresh-all ] bind ] when ; + development? get-global [ global [ refresh-all ] bind ] when ; : setup-limits ( -- ) 1 minutes timeouts 64 1024 * limit-input ; +LOG: httpd-benchmark DEBUG + +: ?benchmark ( quot -- ) + benchmark? get [ + [ benchmark ] [ first ] bi request get url>> rot 3array + httpd-benchmark + ] [ call ] if ; inline + : handle-client ( -- ) [ setup-limits @@ -135,8 +137,8 @@ LOG: httpd-header NOTICE ascii encode-output ?refresh-all read-request - do-request - do-response + [ do-request ] ?benchmark + [ do-response ] ?benchmark ] with-destructors ; : httpd ( port -- ) diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 9d76c82e4a..83fcf6f4a9 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -82,7 +82,7 @@ TUPLE: file-responder root hook special allow-listings ; "index.html" append-path dup exists? [ drop f ] unless ; : serve-directory ( filename -- response ) - request get path>> "/" tail? [ + request get url>> path>> "/" tail? [ dup find-index [ serve-file ] [ list-directory ] ?if ] [ diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 131cadfaf0..bd90072039 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -4,7 +4,7 @@ USING: system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader init threads continuations math accessors concurrency.flags destructors io io.backend io.timeouts io.pipes io.pipes.private io.encodings -io.streams.duplex io.ports ; +io.streams.duplex io.ports debugger prettyprint inspector ; IN: io.launcher TUPLE: process < identity-tuple @@ -131,11 +131,16 @@ HOOK: run-process* io-backend ( process -- handle ) run-detached dup detached>> [ dup wait-for-process drop ] unless ; -ERROR: process-failed code ; +ERROR: process-failed process code ; + +M: process-failed error. + dup "Process exited with error code " write code>> . nl + "Launch descriptor:" print nl + process>> describe ; : try-process ( desc -- ) - run-process wait-for-process dup zero? - [ drop ] [ process-failed ] if ; + run-process dup wait-for-process dup zero? + [ 2drop ] [ process-failed ] if ; HOOK: kill-process* io-backend ( handle -- ) diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index c855fba6be..e975880a14 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -4,7 +4,7 @@ USING: io io.sockets io.sockets.secure io.files io.streams.duplex logging continuations destructors kernel math math.parser namespaces parser sequences strings prettyprint debugger quotations calendar threads concurrency.combinators -assocs fry accessors ; +assocs fry accessors arrays ; IN: io.server SYMBOL: servers @@ -17,13 +17,13 @@ LOG: accepted-connection NOTICE : with-connection ( client remote local quot -- ) '[ - , [ remote-address set ] [ accepted-connection ] bi - , local-address set + , , + [ [ remote-address set ] [ local-address set ] bi* ] + [ 2array accepted-connection ] + 2bi @ ] with-stream ; inline -\ with-connection DEBUG add-error-logging - : accept-loop ( server quot -- ) [ [ [ accept ] [ addr>> ] bi ] dip diff --git a/extra/io/unix/sockets/secure/secure-tests.factor b/extra/io/unix/sockets/secure/secure-tests.factor index cbda002354..dca8fbbbc7 100644 --- a/extra/io/unix/sockets/secure/secure-tests.factor +++ b/extra/io/unix/sockets/secure/secure-tests.factor @@ -9,7 +9,7 @@ concurrency.promises byte-arrays locals calendar io.timeouts ; [ ] [ "port" set ] unit-test -: with-test-context +: with-test-context ( quot -- ) "resource:extra/openssl/test/server.pem" >>key-file "resource:extra/openssl/test/dh1024.pem" >>dh-file @@ -28,7 +28,7 @@ concurrency.promises byte-arrays locals calendar io.timeouts ; ] with-test-context ] "SSL server test" spawn drop ; -: client-test +: client-test ( -- string ) [ "127.0.0.1" "port" get ?promise ascii drop contents ] with-secure-context ; diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor index 946e0e7be5..a0acbebb3a 100755 --- a/extra/io/unix/sockets/secure/secure.factor +++ b/extra/io/unix/sockets/secure/secure.factor @@ -118,13 +118,27 @@ M: secure (get-local-address) addrspec>> (get-local-address) ; dup dup handle>> SSL_connect check-connect-response dup [ dupd wait-for-fd do-ssl-connect ] [ 2drop ] if ; +: resume-session ( ssl-handle ssl-session -- ) + [ [ handle>> ] dip SSL_set_session ssl-error ] + [ drop do-ssl-connect ] + 2bi ; + +: begin-session ( ssl-handle addrspec -- ) + [ drop do-ssl-connect ] + [ [ handle>> SSL_get1_session ] dip save-session ] + 2bi ; + +: secure-connection ( ssl-handle addrspec -- ) + dup get-session [ resume-session ] [ begin-session ] ?if ; + M: secure establish-connection ( client-out remote -- ) - [ addrspec>> establish-connection ] + addrspec>> + [ establish-connection ] [ - drop handle>> - [ [ do-ssl-connect ] with-timeout ] - [ t >>connected drop ] - bi + [ handle>> ] dip + [ [ secure-connection ] curry with-timeout ] + [ drop t >>connected drop ] + 2bi ] 2bi ; M: secure (server) addrspec>> (server) ; diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor index 3218d67b5c..dced2e5c0c 100755 --- a/extra/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -1,12 +1,8 @@ ! Copyright (C) 2007 Elie CHAFTARI +! Portions copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -! -! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC -! -! export LD_LIBRARY_PATH=/opt/local/lib - USING: alien alien.syntax combinators kernel system namespaces -assocs parser sequences words quotations ; +assocs parser sequences words quotations math.bitfields ; IN: openssl.libssl @@ -24,11 +20,47 @@ IN: openssl.libssl : SSL_FILETYPE_ASN1 X509_FILETYPE_ASN1 ; inline : SSL_FILETYPE_PEM X509_FILETYPE_PEM ; inline -: SSL_CTRL_NEED_TMP_RSA 1 ; inline -: SSL_CTRL_SET_TMP_RSA 2 ; inline -: SSL_CTRL_SET_TMP_DH 3 ; inline -: SSL_CTRL_SET_TMP_RSA_CB 4 ; inline -: SSL_CTRL_SET_TMP_DH_CB 5 ; inline +: SSL_CTRL_NEED_TMP_RSA 1 ; inline +: SSL_CTRL_SET_TMP_RSA 2 ; inline +: SSL_CTRL_SET_TMP_DH 3 ; inline +: SSL_CTRL_SET_TMP_RSA_CB 4 ; inline +: SSL_CTRL_SET_TMP_DH_CB 5 ; inline + +: SSL_CTRL_GET_SESSION_REUSED 6 ; inline +: SSL_CTRL_GET_CLIENT_CERT_REQUEST 7 ; inline +: SSL_CTRL_GET_NUM_RENEGOTIATIONS 8 ; inline +: SSL_CTRL_CLEAR_NUM_RENEGOTIATIONS 9 ; inline +: SSL_CTRL_GET_TOTAL_RENEGOTIATIONS 10 ; inline +: SSL_CTRL_GET_FLAGS 11 ; inline +: SSL_CTRL_EXTRA_CHAIN_CERT 12 ; inline + +: SSL_CTRL_SET_MSG_CALLBACK 13 ; inline +: SSL_CTRL_SET_MSG_CALLBACK_ARG 14 ; inline + +: SSL_CTRL_SESS_NUMBER 20 ; inline +: SSL_CTRL_SESS_CONNECT 21 ; inline +: SSL_CTRL_SESS_CONNECT_GOOD 22 ; inline +: SSL_CTRL_SESS_CONNECT_RENEGOTIATE 23 ; inline +: SSL_CTRL_SESS_ACCEPT 24 ; inline +: SSL_CTRL_SESS_ACCEPT_GOOD 25 ; inline +: SSL_CTRL_SESS_ACCEPT_RENEGOTIATE 26 ; inline +: SSL_CTRL_SESS_HIT 27 ; inline +: SSL_CTRL_SESS_CB_HIT 28 ; inline +: SSL_CTRL_SESS_MISSES 29 ; inline +: SSL_CTRL_SESS_TIMEOUTS 30 ; inline +: SSL_CTRL_SESS_CACHE_FULL 31 ; inline +: SSL_CTRL_OPTIONS 32 ; inline +: SSL_CTRL_MODE 33 ; inline + +: SSL_CTRL_GET_READ_AHEAD 40 ; inline +: SSL_CTRL_SET_READ_AHEAD 41 ; inline +: SSL_CTRL_SET_SESS_CACHE_SIZE 42 ; inline +: SSL_CTRL_GET_SESS_CACHE_SIZE 43 ; inline +: SSL_CTRL_SET_SESS_CACHE_MODE 44 ; inline +: SSL_CTRL_GET_SESS_CACHE_MODE 45 ; inline + +: SSL_CTRL_GET_MAX_CERT_LIST 50 ; inline +: SSL_CTRL_SET_MAX_CERT_LIST 51 ; inline : SSL_ERROR_NONE 0 ; inline : SSL_ERROR_SSL 1 ; inline @@ -55,8 +87,9 @@ IN: openssl.libssl } ; TYPEDEF: void* ssl-method -TYPEDEF: void* ssl-ctx -TYPEDEF: void* ssl-pointer +TYPEDEF: void* SSL_CTX* +TYPEDEF: void* SSL_SESSION* +TYPEDEF: void* SSL* LIBRARY: libssl @@ -64,7 +97,7 @@ LIBRARY: libssl ! ssl.h ! =============================================== -FUNCTION: char* SSL_get_version ( ssl-pointer ssl ) ; +FUNCTION: char* SSL_get_version ( SSL* ssl ) ; ! Maps OpenSSL errors to strings FUNCTION: void SSL_load_error_strings ( ) ; @@ -94,42 +127,50 @@ FUNCTION: ssl-method TLSv1_server_method ( ) ; FUNCTION: ssl-method TLSv1_method ( ) ; ! Creates the context -FUNCTION: ssl-ctx SSL_CTX_new ( ssl-method method ) ; +FUNCTION: SSL_CTX* SSL_CTX_new ( ssl-method method ) ; ! Load the certificates and private keys into the SSL_CTX -FUNCTION: int SSL_CTX_use_certificate_chain_file ( ssl-ctx ctx, +FUNCTION: int SSL_CTX_use_certificate_chain_file ( SSL_CTX* ctx, char* file ) ; ! PEM type -FUNCTION: ssl-pointer SSL_new ( ssl-ctx ctx ) ; +FUNCTION: SSL* SSL_new ( SSL_CTX* ctx ) ; -FUNCTION: int SSL_set_fd ( ssl-pointer ssl, int fd ) ; +FUNCTION: int SSL_set_fd ( SSL* ssl, int fd ) ; -FUNCTION: void SSL_set_bio ( ssl-pointer ssl, void* rbio, void* wbio ) ; +FUNCTION: void SSL_set_bio ( SSL* ssl, void* rbio, void* wbio ) ; -FUNCTION: int SSL_get_error ( ssl-pointer ssl, int ret ) ; +FUNCTION: int SSL_set_session ( SSL* to, SSL_SESSION* session ) ; -FUNCTION: void SSL_set_connect_state ( ssl-pointer ssl ) ; +FUNCTION: int SSL_get_error ( SSL* ssl, int ret ) ; -FUNCTION: void SSL_set_accept_state ( ssl-pointer ssl ) ; +FUNCTION: void SSL_set_connect_state ( SSL* ssl ) ; -FUNCTION: int SSL_connect ( ssl-pointer ssl ) ; +FUNCTION: void SSL_set_accept_state ( SSL* ssl ) ; -FUNCTION: int SSL_accept ( ssl-pointer ssl ) ; +FUNCTION: int SSL_connect ( SSL* ssl ) ; -FUNCTION: int SSL_write ( ssl-pointer ssl, void* buf, int num ) ; +FUNCTION: int SSL_accept ( SSL* ssl ) ; -FUNCTION: int SSL_read ( ssl-pointer ssl, void* buf, int num ) ; +FUNCTION: int SSL_write ( SSL* ssl, void* buf, int num ) ; -FUNCTION: int SSL_shutdown ( ssl-pointer ssl ) ; +FUNCTION: int SSL_read ( SSL* ssl, void* buf, int num ) ; + +FUNCTION: int SSL_shutdown ( SSL* ssl ) ; : SSL_SENT_SHUTDOWN 1 ; : SSL_RECEIVED_SHUTDOWN 2 ; -FUNCTION: int SSL_get_shutdown ( ssl-pointer ssl ) ; +FUNCTION: int SSL_get_shutdown ( SSL* ssl ) ; -FUNCTION: void SSL_free ( ssl-pointer ssl ) ; +FUNCTION: int SSL_CTX_set_session_id_context ( SSL_CTX* ctx, char* sid_ctx, uint len ) ; -FUNCTION: int SSL_want ( ssl-pointer ssl ) ; +FUNCTION: SSL_SESSION* SSL_get1_session ( SSL* ssl ) ; + +FUNCTION: void SSL_free ( SSL* ssl ) ; + +FUNCTION: void SSL_SESSION_free ( SSL_SESSION* ses ) ; + +FUNCTION: int SSL_want ( SSL* ssl ) ; : SSL_NOTHING 1 ; inline : SSL_WRITING 2 ; inline @@ -140,55 +181,55 @@ FUNCTION: long SSL_get_verify_result ( SSL* ssl ) ; FUNCTION: X509* SSL_get_peer_certificate ( SSL* s ) ; -FUNCTION: void SSL_CTX_free ( ssl-ctx ctx ) ; +FUNCTION: void SSL_CTX_free ( SSL_CTX* ctx ) ; FUNCTION: void RAND_seed ( void* buf, int num ) ; -FUNCTION: int SSL_set_cipher_list ( ssl-pointer ssl, char* str ) ; +FUNCTION: int SSL_set_cipher_list ( SSL* ssl, char* str ) ; -FUNCTION: int SSL_use_RSAPrivateKey_file ( ssl-pointer ssl, char* str ) ; +FUNCTION: int SSL_use_RSAPrivateKey_file ( SSL* ssl, char* str ) ; -FUNCTION: int SSL_CTX_use_RSAPrivateKey_file ( ssl-ctx ctx, int type ) ; +FUNCTION: int SSL_CTX_use_RSAPrivateKey_file ( SSL_CTX* ctx, int type ) ; -FUNCTION: int SSL_use_certificate_file ( ssl-pointer ssl, +FUNCTION: int SSL_use_certificate_file ( SSL* ssl, char* str, int type ) ; -FUNCTION: int SSL_CTX_load_verify_locations ( ssl-ctx ctx, char* CAfile, +FUNCTION: int SSL_CTX_load_verify_locations ( SSL_CTX* ctx, char* CAfile, char* CApath ) ; -FUNCTION: int SSL_CTX_set_default_verify_paths ( ssl-ctx ctx ) ; +FUNCTION: int SSL_CTX_set_default_verify_paths ( SSL_CTX* ctx ) ; : SSL_VERIFY_NONE 0 ; inline : SSL_VERIFY_PEER 1 ; inline : SSL_VERIFY_FAIL_IF_NO_PEER_CERT 2 ; inline : SSL_VERIFY_CLIENT_ONCE 4 ; inline -FUNCTION: void SSL_CTX_set_verify ( ssl-ctx ctx, int mode, void* callback ) ; +FUNCTION: void SSL_CTX_set_verify ( SSL_CTX* ctx, int mode, void* callback ) ; -FUNCTION: void SSL_CTX_set_client_CA_list ( ssl-ctx ctx, ssl-pointer list ) ; +FUNCTION: void SSL_CTX_set_client_CA_list ( SSL_CTX* ctx, SSL* list ) ; -FUNCTION: ssl-pointer SSL_load_client_CA_file ( char* file ) ; +FUNCTION: SSL* SSL_load_client_CA_file ( char* file ) ; ! Used to manipulate settings of the SSL_CTX and SSL objects. ! This function should never be called directly -FUNCTION: long SSL_CTX_ctrl ( ssl-ctx ctx, int cmd, long larg, void* parg ) ; +FUNCTION: long SSL_CTX_ctrl ( SSL_CTX* ctx, int cmd, long larg, void* parg ) ; -FUNCTION: void SSL_CTX_set_default_passwd_cb ( ssl-ctx ctx, void* cb ) ; +FUNCTION: void SSL_CTX_set_default_passwd_cb ( SSL_CTX* ctx, void* cb ) ; -FUNCTION: void SSL_CTX_set_default_passwd_cb_userdata ( ssl-ctx ctx, +FUNCTION: void SSL_CTX_set_default_passwd_cb_userdata ( SSL_CTX* ctx, void* u ) ; -FUNCTION: int SSL_CTX_use_PrivateKey_file ( ssl-ctx ctx, char* file, +FUNCTION: int SSL_CTX_use_PrivateKey_file ( SSL_CTX* ctx, char* file, int type ) ; -! Sets the maximum depth for the allowed ctx certificate chain verification -FUNCTION: void SSL_CTX_set_verify_depth ( ssl-ctx ctx, int depth ) ; +! Sets the maximum depth for the allowed ctx certificate chain verification +FUNCTION: void SSL_CTX_set_verify_depth ( SSL_CTX* ctx, int depth ) ; ! Sets DH parameters to be used to be dh. ! The key is inherited by all ssl objects created from ctx -FUNCTION: void SSL_CTX_set_tmp_dh_callback ( ssl-ctx ctx, void* dh ) ; +FUNCTION: void SSL_CTX_set_tmp_dh_callback ( SSL_CTX* ctx, void* dh ) ; -FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( ssl-ctx ctx, void* rsa ) ; +FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( SSL_CTX* ctx, void* rsa ) ; FUNCTION: void* BIO_f_ssl ( ) ; @@ -198,6 +239,23 @@ FUNCTION: void* BIO_f_ssl ( ) ; : SSL_CTX_set_tmp_dh ( ctx dh -- n ) >r SSL_CTRL_SET_TMP_DH 0 r> SSL_CTX_ctrl ; +: SSL_CTX_set_session_cache_mode ( ctx mode -- n ) + >r SSL_CTRL_SET_SESS_CACHE_MODE r> f SSL_CTX_ctrl ; + +: SSL_SESS_CACHE_OFF HEX: 0000 ; inline +: SSL_SESS_CACHE_CLIENT HEX: 0001 ; inline +: SSL_SESS_CACHE_SERVER HEX: 0002 ; inline + +: SSL_SESS_CACHE_BOTH ( -- n ) + { SSL_SESS_CACHE_CLIENT SSL_SESS_CACHE_SERVER } flags ; inline + +: SSL_SESS_CACHE_NO_AUTO_CLEAR HEX: 0080 ; inline +: SSL_SESS_CACHE_NO_INTERNAL_LOOKUP HEX: 0100 ; inline +: SSL_SESS_CACHE_NO_INTERNAL_STORE HEX: 0200 ; inline + +: SSL_SESS_CACHE_NO_INTERNAL ( -- n ) + { SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } flags ; inline + ! =============================================== ! x509.h ! =============================================== diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index b2dbda7d2e..6d750bd8e0 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors byte-arrays kernel debugger sequences namespaces math math.order combinators init alien alien.c-types alien.strings libc -continuations destructors debugger inspector splitting -locals unicode.case +continuations destructors debugger inspector splitting assocs +random math.parser locals unicode.case openssl.libcrypto openssl.libssl io.backend io.ports io.files io.encodings.8-bit io.sockets.secure io.timeouts ; @@ -48,7 +48,13 @@ SYMBOL: ssl-initialized? [ f ssl-initialized? set-global ] "openssl" add-init-hook -TUPLE: openssl-context < secure-context aliens ; +TUPLE: openssl-context < secure-context aliens sessions ; + +: set-session-cache ( ctx -- ) + handle>> + [ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ] + [ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ] + bi ; : load-certificate-chain ( ctx -- ) dup config>> key-file>> [ @@ -133,12 +139,20 @@ M: rsa dispose* handle>> RSA_free ; ] bi SSL_CTX_set_tmp_rsa ssl-error ; +: ( config ctx -- context ) + openssl-context new + swap >>handle + swap >>config + V{ } clone >>aliens + H{ } clone >>sessions ; + M: openssl ( config -- context ) maybe-init-ssl [ dup method>> ssl-method SSL_CTX_new - dup ssl-error f V{ } clone openssl-context boa |dispose + dup ssl-error |dispose { + [ set-session-cache ] [ load-certificate-chain ] [ set-default-password ] [ use-private-key-file ] @@ -152,8 +166,9 @@ M: openssl ( config -- context ) M: openssl-context dispose* [ aliens>> [ free ] each ] + [ sessions>> values [ SSL_SESSION_free ] each ] [ handle>> SSL_CTX_free ] - bi ; + tri ; TUPLE: ssl-handle file handle connected disposed ; @@ -204,4 +219,11 @@ M: openssl check-certificate ( host ssl -- ) 2bi ] [ 2drop ] if ; +: get-session ( addrspec -- session/f ) + current-secure-context sessions>> at + dup expired? [ drop f ] when ; + +: save-session ( session addrspec -- ) + current-secure-context sessions>> set-at ; + openssl secure-socket-backend set-global diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index ed4c337a92..56488818ab 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -201,9 +201,6 @@ USE: continuations >r >r 0 max r> r> [ length tuck min >r min r> ] keep subseq ; -: accumulator ( quot -- quot vec ) - V{ } clone [ [ push ] curry compose ] keep ; inline - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! List the positions of obj in seq diff --git a/extra/tangle/sandbox/sandbox.factor b/extra/tangle/sandbox/sandbox.factor index b6e110ada5..b44acb7617 100644 --- a/extra/tangle/sandbox/sandbox.factor +++ b/extra/tangle/sandbox/sandbox.factor @@ -12,7 +12,7 @@ IN: tangle.sandbox ] with-tangle ; : new-sandbox ( -- ) - development-mode on + development? on delete-db sandbox-db f [ make-sandbox ] [ ] bi main-responder set ; diff --git a/extra/validators/validators-tests.factor b/extra/validators/validators-tests.factor index 7d4325cbb6..bd24323f20 100644 --- a/extra/validators/validators-tests.factor +++ b/extra/validators/validators-tests.factor @@ -2,14 +2,6 @@ IN: validators.tests USING: kernel sequences tools.test validators accessors namespaces assocs ; -: with-validation ( quot -- messages ) - [ - init-validation - call - validation-messages get - named-validation-messages get >alist append - ] with-scope ; inline - [ "" v-one-line ] must-fail [ "hello world" ] [ "hello world" v-one-line ] unit-test [ "hello\nworld" v-one-line ] must-fail @@ -60,59 +52,3 @@ namespaces assocs ; [ "4561_2612_1234_5467" v-credit-card ] must-fail [ "4561-2621-1234-5467" v-credit-card ] must-fail - - -[ 14 V{ } ] [ - [ - "14" "age" [ v-number 13 v-min-value 100 v-max-value ] validate - ] with-validation -] unit-test - -[ f t ] [ - [ - "140" "age" [ v-number 13 v-min-value 100 v-max-value ] validate - ] with-validation first - [ first "age" = ] - [ second validation-error? ] - [ second value>> "140" = ] - tri and and -] unit-test - -TUPLE: person name age ; - -person { - { "name" [ ] } - { "age" [ v-number 13 v-min-value 100 v-max-value ] } -} define-validators - -[ t t ] [ - [ - { { "age" "" } } required-values - validation-failed? - ] with-validation first - [ first "age" = ] - [ second validation-error? ] - [ second message>> "required" = ] - tri and and -] unit-test - -[ H{ { "a" 123 } } f V{ } ] [ - [ - H{ - { "a" "123" } - { "b" "c" } - { "c" "d" } - } - H{ - { "a" [ v-integer ] } - } validate-values - validation-failed? - ] with-validation -] unit-test - -[ t "foo" ] [ - [ - "foo" validation-error - validation-failed? - ] with-validation first message>> -] unit-test diff --git a/extra/validators/validators.factor b/extra/validators/validators.factor index aeb2dc2f80..37c0216740 100644 --- a/extra/validators/validators.factor +++ b/extra/validators/validators.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel continuations sequences sequences.lib math -namespaces sets math.parser math.ranges assocs regexp fry -unicode.categories arrays hashtables words combinators mirrors +namespaces sets math.parser math.ranges assocs regexp +unicode.categories arrays hashtables words classes quotations xmode.catalog ; IN: validators @@ -107,53 +107,3 @@ IN: validators ] [ "invalid credit card number format" throw ] if ; - -SYMBOL: validation-messages -SYMBOL: named-validation-messages - -: init-validation ( -- ) - V{ } clone validation-messages set - H{ } clone named-validation-messages set ; - -: (validation-message) ( obj -- ) - validation-messages get push ; - -: (validation-message-for) ( obj name -- ) - named-validation-messages get set-at ; - -TUPLE: validation-message message ; - -C: validation-message - -: validation-message ( string -- ) - (validation-message) ; - -: validation-message-for ( string name -- ) - [ ] dip (validation-message-for) ; - -TUPLE: validation-error message value ; - -C: validation-error - -: validation-error ( message -- ) - f (validation-message) ; - -: validation-error-for ( message value name -- ) - [ ] dip (validation-message-for) ; - -: validation-failed? ( -- ? ) - validation-messages get [ validation-error? ] contains? - named-validation-messages get [ nip validation-error? ] assoc-contains? - or ; - -: define-validators ( class validators -- ) - >hashtable "validators" set-word-prop ; - -: validate ( value name quot -- result ) - '[ drop @ ] [ -rot validation-error-for f ] recover ; inline - -: required-values ( assoc -- ) - [ swap [ v-required ] validate drop ] assoc-each ; - -: validate-values ( assoc validators -- assoc' ) - swap '[ [ [ dup , at ] keep ] dip validate ] assoc-map ; diff --git a/extra/webapps/blogs/blogs-common.xml b/extra/webapps/blogs/blogs-common.xml index 965f059abd..e809c0e7f5 100644 --- a/extra/webapps/blogs/blogs-common.xml +++ b/extra/webapps/blogs/blogs-common.xml @@ -12,13 +12,13 @@ | My Posts | New Post - + - - | Edit Profile + + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor index d0c651c71f..aa1aa5edc7 100644 --- a/extra/webapps/blogs/blogs.factor +++ b/extra/webapps/blogs/blogs.factor @@ -1,14 +1,15 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences sorting math.order math.parser -urls validators html.components db db.types db.tuples calendar -present http.server.dispatchers +urls validators db db.types db.tuples calendar present namespaces +html.forms +html.components +http.server.dispatchers furnace furnace.actions furnace.auth furnace.auth.login furnace.boilerplate -furnace.sessions furnace.syndication ; IN: webapps.blogs @@ -142,7 +143,7 @@ M: comment entity-url "id" value "new-comment" [ "parent" set-value - ] nest-values + ] nest-form ] >>init { blogs "view-post" } >>template ; @@ -158,13 +159,13 @@ M: comment entity-url [ validate-post - uid "author" set-value + logged-in-user get username>> "author" set-value ] >>validate [ f - dup { "title" "content" } deposit-slots - uid >>author + dup { "title" "content" } to-object + logged-in-user get username>> >>author now >>date [ insert-tuple ] [ entity-url ] bi ] >>submit @@ -175,7 +176,8 @@ M: comment entity-url "make a new blog post" >>description ; : authorize-author ( author -- ) - uid = can-administer-blogs? have-capability? or + logged-in-user get username>> = + can-administer-blogs? have-capability? or [ login-required ] unless ; : do-post-action ( -- ) @@ -195,7 +197,7 @@ M: comment entity-url [ "id" value - dup { "title" "author" "date" "content" } deposit-slots + dup { "title" "author" "date" "content" } to-object [ update-tuple ] [ entity-url ] bi ] >>submit @@ -251,13 +253,13 @@ M: comment entity-url [ validate-comment - uid "author" set-value + logged-in-user get username>> "author" set-value ] >>validate [ "parent" value f "content" value >>content - uid >>author + logged-in-user get username>> >>author now >>date [ insert-tuple ] [ entity-url ] bi ] >>submit diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor index da646fb76f..30c5d403de 100644 --- a/extra/webapps/counter/counter.factor +++ b/extra/webapps/counter/counter.factor @@ -1,6 +1,6 @@ USING: math kernel accessors http.server http.server.dispatchers furnace furnace.actions furnace.sessions -html.components html.templates.chloe +html.components html.forms html.templates.chloe fry urls ; IN: webapps.counter diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index 04fc0487b8..c0bd856d5d 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -7,12 +7,11 @@ logging.insomniac http.server http.server.dispatchers furnace.alloy -furnace.db -furnace.asides -furnace.flash -furnace.sessions furnace.auth.login furnace.auth.providers.db +furnace.auth.features.edit-profile +furnace.auth.features.recover-password +furnace.auth.features.registration furnace.boilerplate webapps.blogs webapps.pastebin @@ -50,8 +49,8 @@ TUPLE: factor-website < dispatcher ; "wiki" add-responder "wee-url" add-responder "user-admin" add-responder - - users-in-db >>users + "Factor website" + "Factor website" >>name allow-registration allow-password-recovery allow-edit-profile diff --git a/extra/webapps/pastebin/pastebin-common.xml b/extra/webapps/pastebin/pastebin-common.xml index 47f7666b22..b95f3f7b64 100644 --- a/extra/webapps/pastebin/pastebin-common.xml +++ b/extra/webapps/pastebin/pastebin-common.xml @@ -11,13 +11,13 @@ Pastes | New Paste - + - - | Edit Profile + + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index d381adafcd..251872d1ac 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -4,6 +4,7 @@ USING: namespaces assocs sorting sequences kernel accessors hashtables sequences.lib db.types db.tuples db combinators calendar calendar.format math.parser syndication urls xml.writer xmode.catalog validators +html.forms html.components html.templates.chloe http.server @@ -126,7 +127,7 @@ M: annotation entity-url "parent" set-value mode-names "modes" set-value "factor" "mode" set-value - ] nest-values + ] nest-form ] >>init { pastebin "paste" } >>template ; @@ -149,7 +150,7 @@ M: annotation entity-url : deposit-entity-slots ( tuple -- ) now >>date - { "summary" "author" "mode" "contents" } deposit-slots ; + { "summary" "author" "mode" "contents" } to-object ; : ( -- action ) @@ -160,11 +161,12 @@ M: annotation entity-url { pastebin "new-paste" } >>template - [ mode-names "modes" set-value ] >>validate + [ + mode-names "modes" set-value + validate-entity + ] >>validate [ - validate-entity - f [ deposit-entity-slots ] [ insert-tuple ] @@ -196,6 +198,7 @@ M: annotation entity-url : ( -- action ) [ + mode-names "modes" set-value { { "parent" [ v-integer ] } } validate-params validate-entity ] >>validate diff --git a/extra/webapps/planet/planet-common.xml b/extra/webapps/planet/planet-common.xml index 34ee73da67..6c0affd17f 100644 --- a/extra/webapps/planet/planet-common.xml +++ b/extra/webapps/planet/planet-common.xml @@ -9,12 +9,12 @@ | Atom Feed | Admin - - - | Edit Profile + + + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 90b2411fc1..b472881e73 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -3,9 +3,9 @@ USING: kernel accessors sequences sorting math math.order calendar alarms logging concurrency.combinators namespaces sequences.lib db.types db.tuples db fry locals hashtables +syndication urls xml.writer validators +html.forms html.components -syndication urls xml.writer -validators http.server http.server.dispatchers furnace @@ -130,7 +130,7 @@ posting "POSTINGS" } validate-params ; : deposit-blog-slots ( blog -- ) - { "name" "www-url" "feed-url" } deposit-slots ; + { "name" "www-url" "feed-url" } to-object ; : ( -- action ) diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 0770765754..4b1b59e80f 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -2,12 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sequences namespaces db db.types db.tuples validators hashtables urls +html.forms html.components html.templates.chloe http.server http.server.dispatchers furnace -furnace.sessions furnace.boilerplate furnace.auth furnace.actions @@ -31,7 +31,7 @@ todo "TODO" : ( id -- todo ) todo new swap >>id - uid >>uid ; + logged-in-user get username>> >>uid ; : ( -- action ) @@ -62,7 +62,7 @@ todo "TODO" [ f - dup { "summary" "priority" "description" } deposit-slots + dup { "summary" "priority" "description" } to-object [ insert-tuple ] [ id>> view-todo-url ] bi ] >>submit ; @@ -82,7 +82,7 @@ todo "TODO" [ f - dup { "id" "summary" "priority" "description" } deposit-slots + dup { "id" "summary" "priority" "description" } to-object [ update-tuple ] [ id>> view-todo-url ] bi ] >>submit ; diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml index e087fbfcfc..f7500cdad2 100644 --- a/extra/webapps/todo/todo.xml +++ b/extra/webapps/todo/todo.xml @@ -8,11 +8,11 @@ List Items | Add Item - - | Edit Profile + + | Edit Profile - | Logout + | Logout

diff --git a/extra/webapps/user-admin/edit-user.xml b/extra/webapps/user-admin/edit-user.xml index 0c55f8ca76..252667462b 100644 --- a/extra/webapps/user-admin/edit-user.xml +++ b/extra/webapps/user-admin/edit-user.xml @@ -50,11 +50,11 @@

- +

- Delete + Delete diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index 19153e1354..8c7b1b21c9 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors namespaces combinators words assocs db.tuples arrays splitting strings validators urls +html.forms html.elements html.components furnace @@ -10,8 +11,8 @@ furnace.auth.providers furnace.auth.providers.db furnace.auth.login furnace.auth -furnace.sessions furnace.actions +furnace.utilities http.server http.server.dispatchers ; IN: webapps.user-admin @@ -26,10 +27,19 @@ TUPLE: user-admin < dispatcher ; : init-capabilities ( -- ) capabilities get words>strings "capabilities" set-value ; -: selected-capabilities ( -- seq ) +: validate-capabilities ( -- ) "capabilities" value - [ param empty? not ] filter - [ string>word ] map ; + [ [ param empty? not ] keep set-value ] each ; + +: selected-capabilities ( -- seq ) + "capabilities" value [ value ] filter [ string>word ] map ; + +: validate-user ( -- ) + { + { "username" [ v-username ] } + { "realname" [ [ v-one-line ] v-optional ] } + { "email" [ [ v-email ] v-optional ] } + } validate-params ; : ( -- action ) @@ -42,14 +52,13 @@ TUPLE: user-admin < dispatcher ; [ init-capabilities + validate-capabilities + + validate-user { - { "username" [ v-username ] } - { "realname" [ v-one-line ] } { "new-password" [ v-password ] } { "verify-password" [ v-password ] } - { "email" [ [ v-email ] v-optional ] } - { "capabilities" [ ] } } validate-params same-password-twice @@ -74,14 +83,16 @@ TUPLE: user-admin < dispatcher ; : validate-username ( -- ) { { "username" [ v-username ] } } validate-params ; +: select-capabilities ( seq -- ) + [ t swap word>string set-value ] each ; + : ( -- action ) [ validate-username "username" value select-tuple - [ from-object ] - [ capabilities>> [ "true" swap word>string set-value ] each ] bi + [ from-object ] [ capabilities>> select-capabilities ] bi init-capabilities ] >>init @@ -89,14 +100,17 @@ TUPLE: user-admin < dispatcher ; { user-admin "edit-user" } >>template [ + "username" value select-tuple + [ from-object ] [ capabilities>> select-capabilities ] bi + init-capabilities + validate-capabilities + + validate-user { - { "username" [ v-username ] } - { "realname" [ v-one-line ] } { "new-password" [ [ v-password ] v-optional ] } { "verify-password" [ [ v-password ] v-optional ] } - { "email" [ [ v-email ] v-optional ] } } validate-params "new-password" "verify-password" @@ -124,11 +138,7 @@ TUPLE: user-admin < dispatcher ; [ validate-username - - [ select-tuple 1 >>deleted update-tuple ] - [ logout-all-sessions ] - bi - + select-tuple 1 >>deleted update-tuple URL" $user-admin" ] >>submit ; diff --git a/extra/webapps/user-admin/user-admin.xml b/extra/webapps/user-admin/user-admin.xml index 9cb9ef0a0a..2141fdc1d9 100644 --- a/extra/webapps/user-admin/user-admin.xml +++ b/extra/webapps/user-admin/user-admin.xml @@ -6,11 +6,11 @@ List Users | Add User - - | Edit Profile + + | Edit Profile - | Logout + | Logout

diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor index 29c4a60bef..2396e98b2a 100644 --- a/extra/webapps/wee-url/wee-url.factor +++ b/extra/webapps/wee-url/wee-url.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: math.ranges sequences random accessors combinators.lib kernel namespaces fry db.types db.tuples urls validators -html.components http http.server.dispatchers furnace +html.components html.forms http http.server.dispatchers furnace furnace.actions furnace.boilerplate ; IN: webapps.wee-url diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml index 4c6d1a5b5c..0abd36a7cd 100644 --- a/extra/webapps/wiki/wiki-common.xml +++ b/extra/webapps/wiki/wiki-common.xml @@ -14,13 +14,13 @@ | All Articles | Recent Changes - + - - | Edit Profile + + | Edit Profile - | Logout + | Logout @@ -28,6 +28,23 @@

- + + + + + + + +
+ +

+ + + +

+ + + +
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 8dd62c8761..13c445b0a8 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel hashtables calendar namespaces splitting sequences sorting math.order present -html.components syndication +syndication +html.components html.forms http.server http.server.dispatchers furnace @@ -77,6 +78,10 @@ M: revision feed-entry-url id>> revision-url ; [ "Front Page" view-url ] >>display ; +: latest-revision ( title -- revision/f ) +
select-tuple + dup [ revision>> select-tuple ] when ; + : ( -- action ) @@ -87,8 +92,8 @@ M: revision feed-entry-url id>> revision-url ; ] >>init [ - "title" value dup
select-tuple [ - revision>> select-tuple from-object + "title" value dup latest-revision [ + from-object { wiki "view" } ] [ edit-url @@ -231,8 +236,8 @@ M: revision feed-entry-url id>> revision-url ; "old-id" "new-id" [ value select-tuple ] bi@ [ - [ [ title>> "title" set-value ] [ "old" set-value ] bi ] - [ "new" set-value ] bi* + [ [ title>> "title" set-value ] [ "old" [ from-object ] nest-form ] bi ] + [ "new" [ from-object ] nest-form ] bi* ] [ [ content>> string-lines ] bi@ diff "diff" set-value ] 2bi @@ -279,6 +284,11 @@ M: revision feed-entry-url id>> revision-url ; { wiki "page-common" } >>template ; +: init-sidebar ( -- ) + "Sidebar" latest-revision [ + "sidebar" [ from-object ] nest-form + ] when* ; + : ( -- dispatcher ) wiki new-dispatcher "" add-responder @@ -296,4 +306,5 @@ M: revision feed-entry-url id>> revision-url ; "changes.atom" add-responder "delete" add-responder + [ init-sidebar ] >>init { wiki "wiki-common" } >>template ; diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor index 8c6025f726..98276caf83 100755 --- a/extra/xmode/catalog/catalog.factor +++ b/extra/xmode/catalog/catalog.factor @@ -5,7 +5,7 @@ IN: xmode.catalog TUPLE: mode file file-name-glob first-line-glob ; -r diff --git a/extra/xmode/loader/loader.factor b/extra/xmode/loader/loader.factor index 5cf3675941..8039db0ac9 100755 --- a/extra/xmode/loader/loader.factor +++ b/extra/xmode/loader/loader.factor @@ -7,15 +7,15 @@ IN: xmode.loader ! Based on org.gjt.sp.jedit.XModeHandler ! RULES and its children -number swap set-rule-set-terminate-char ; RULE: SEQ seq-rule diff --git a/extra/xmode/loader/syntax/syntax.factor b/extra/xmode/loader/syntax/syntax.factor index 175c8ed22f..b3adf5cb60 100644 --- a/extra/xmode/loader/syntax/syntax.factor +++ b/extra/xmode/loader/syntax/syntax.factor @@ -75,7 +75,7 @@ SYMBOL: ignore-case? [ parse-literal-matcher swap set-rule-end ] , ; ! SPAN's children - tag-handler-word get tag-handlers get >alist [ >r dup name-tag r> case ] curry - (( tag -- )) define-declared ; parsing + define ; parsing