steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Doug Coleman 2008-07-10 00:28:55 -05:00
parent 2ed0d561ae 42f54c8014
commit b0ee7c03e6
17 changed files with 118 additions and 253 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
extra/furnace/actions/actions.factor
View File

@ -7,7 +7,8 @@ xml.entities
http.server
http.server.responses
furnace
furnace.flash
furnace.redirection
furnace.conversations
html.forms
html.elements
html.components
@ -38,20 +39,23 @@ TUPLE: action rest authorize init display validate submit ;
: <action> ( -- action )
action new-action ;
: merge-forms ( form -- )
form get
[ [ errors>> ] bi@ push-all ]
[ [ values>> ] bi@ swap update ]
[ swap validation-failed>> >>validation-failed drop ]
2tri ;
: set-nested-form ( form name -- )
dup empty? [
drop form set
drop merge-forms
] [
dup length 1 = [
first set-value
] [
unclip [ set-nested-form ] nest-form
] if
unclip [ set-nested-form ] nest-form
] if ;
: restore-validation-errors ( -- )
form fget [
nested-forms fget set-nested-form
form cget [
nested-forms cget set-nested-form
] when* ;
: handle-get ( action -- response )
@ -75,11 +79,13 @@ TUPLE: action rest authorize init display validate submit ;
revalidate-url-key param
dup [ >url [ same-host? ] keep and ] when ;
: validation-failed ( flashed -- * )
post-request? revalidate-url and dup [
nested-forms-key param " " split harvest nested-forms set
swap { form nested-forms } append <flash-redirect>
] [ 2drop <400> ] if
: validation-failed ( -- * )
post-request? revalidate-url and [
begin-conversation
nested-forms-key param " " split harvest nested-forms cset
form get form cset
<redirect>
] [ <400> ] if*
exit-with ;
: handle-post ( action -- response )
@ -112,7 +118,7 @@ M: action modify-form
drop url get revalidate-url-key hidden-form-field ;
: check-validation ( -- )
validation-failed? [ { } validation-failed ] when ;
validation-failed? [ validation-failed ] when ;
: validate-params ( validators -- )
params get swap validate-values check-validation ;

14
extra/furnace/alloy/alloy.factor
View File

@ -1,26 +1,24 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences db.tuples alarms calendar db fry
furnace.cache
furnace.asides
furnace.flash
furnace.sessions
furnace.referrer
furnace.db
furnace.cache
furnace.referrer
furnace.sessions
furnace.conversations
furnace.auth.providers
furnace.auth.login.permits ;
IN: furnace.alloy
: <alloy> ( responder db params -- responder' )
'[
<asides>
<flash-scopes>
<conversations>
<sessions>
, , <db-persistence>
<check-form-submissions>
] call ;
: state-classes { session flash-scope aside permit } ; inline
: state-classes { session conversation permit } ; inline
: init-furnace-tables ( -- )
state-classes ensure-tables

104
extra/furnace/asides/asides.factor
View File

@ -1,104 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces sequences arrays kernel
assocs hashtables math.parser urls combinators
logging db.types db.tuples
html.elements
html.templates.chloe.syntax
http
http.server
http.server.filters
furnace
furnace.cache
furnace.sessions
furnace.redirection ;
IN: furnace.asides
TUPLE: aside < server-state session method url post-data ;
: <aside> ( id -- aside )
aside new-server-state ;
aside "ASIDES"
{
{ "session" "SESSION" BIG-INTEGER +not-null+ }
{ "method" "METHOD" { VARCHAR 10 } +not-null+ }
{ "url" "URL" URL +not-null+ }
{ "post-data" "POST_DATA" FACTOR-BLOB }
} define-persistent
TUPLE: asides < server-state-manager ;
: <asides> ( responder -- responder' )
asides new-server-state-manager ;
: begin-aside* ( -- id )
f <aside>
session get id>> >>session
request get
[ method>> >>method ]
[ url>> >>url ]
[ post-data>> >>post-data ]
tri
[ asides get touch-state ] [ insert-tuple ] [ id>> ] tri ;
: end-aside-post ( aside -- response )
request [
clone
over post-data>> >>post-data
over url>> >>url
] change
url>> path>> split-path
asides get responder>> call-responder ;
\ end-aside-post DEBUG add-input-logging
ERROR: end-aside-in-get-error ;
: get-aside ( id -- aside )
dup [ aside get-state ] when
dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
: end-aside* ( url id -- response )
post-request? [ end-aside-in-get-error ] unless
aside get-state [
dup method>> {
{ "GET" [ url>> <redirect> ] }
{ "HEAD" [ url>> <redirect> ] }
{ "POST" [ end-aside-post ] }
} case
] [ <redirect> ] ?if ;
SYMBOL: aside-id
: aside-id-key "__a" ;
: begin-aside ( -- )
begin-aside* aside-id set ;
: end-aside ( default -- response )
aside-id [ f ] change end-aside* ;
: request-aside-id ( request -- aside-id )
aside-id-key swap request-params at string>number ;
M: asides call-responder*
dup asides set
request get request-aside-id aside-id set
call-next-method ;
M: asides link-attr ( tag -- )
drop
"aside" optional-attr {
{ "none" [ aside-id off ] }
{ "begin" [ begin-aside ] }
{ "current" [ ] }
{ f [ ] }
} case ;
M: asides modify-query ( query responder -- query' )
drop
aside-id get [ aside-id-key associate assoc-union ] when* ;
M: asides modify-form ( responder -- )
drop aside-id get aside-id-key hidden-form-field ;

14
extra/furnace/auth/auth.factor
View File

@ -58,13 +58,14 @@ V{ } clone capabilities set-global
TUPLE: realm < dispatcher name users checksum secure ;
GENERIC: login-required* ( realm -- response )
GENERIC: login-required* ( description capabilities realm -- response )
GENERIC: init-realm ( realm -- )
GENERIC: logged-in-username ( realm -- username )
: login-required ( -- * ) realm get login-required* exit-with ;
: login-required ( description capabilities -- * )
realm get login-required* exit-with ;
: new-realm ( responder name class -- realm )
new-dispatcher
@ -144,7 +145,10 @@ M: protected call-responder* ( path responder -- response )
, ,
dup protected set
dup capabilities>> have-capabilities?
[ call-next-method ] [ 2drop realm get login-required* ] if
[ call-next-method ] [
[ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
realm get login-required*
] if
] if-secure-realm ;
: <auth-boilerplate> ( responder -- responder' )
@ -152,7 +156,7 @@ M: protected call-responder* ( path responder -- response )
: password-mismatch ( -- * )
"passwords do not match" validation-error
{ } validation-failed ;
validation-failed ;
: same-password-twice ( -- )
"new-password" value "verify-password" value =
@ -160,4 +164,4 @@ M: protected call-responder* ( path responder -- response )
: user-exists ( -- * )
"username taken" validation-error
{ } validation-failed ;
validation-failed ;

4
extra/furnace/auth/basic/basic.factor
View File

@ -20,8 +20,8 @@ TUPLE: basic-auth-realm < realm ;
401 "Invalid username or password" <trivial-response>
[ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ;
M: basic-auth-realm login-required* ( realm -- response )
name>> <401> ;
M: basic-auth-realm login-required* ( description capabilities realm -- response )
2nip name>> <401> ;
M: basic-auth-realm logged-in-username ( realm -- uid )
drop

5
extra/furnace/auth/features/deactivate-user/deactivate-user.factor
View File

@ -2,7 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs namespaces accessors db db.tuples urls
http.server.dispatchers
furnace.asides furnace.actions furnace.auth furnace.auth.providers ;
furnace.conversations
furnace.actions
furnace.auth
furnace.auth.providers ;
IN: furnace.auth.features.deactivate-user
: <deactivate-user-action> ( -- action )

10
extra/furnace/auth/features/edit-profile/edit-profile.factor
View File

@ -1,12 +1,10 @@
! 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
validators urls html.forms http.server.dispatchers
furnace.auth
furnace.asides
furnace.actions ;
furnace.actions
furnace.conversations ;
IN: furnace.auth.features.edit-profile
: <edit-profile-action> ( -- action )
@ -54,7 +52,7 @@ IN: furnace.auth.features.edit-profile
drop
URL" $login" end-aside
URL" $realm" end-aside
] >>submit
<protected>

22
extra/furnace/auth/login/login.factor
View File

@ -5,12 +5,11 @@ calendar validators urls logging html.forms
http http.server http.server.dispatchers
furnace
furnace.auth
furnace.flash
furnace.asides
furnace.actions
furnace.sessions
furnace.utilities
furnace.redirection
furnace.conversations
furnace.auth.login.permits ;
IN: furnace.auth.login
@ -65,14 +64,13 @@ SYMBOL: capabilities
: login-failed ( -- * )
"invalid username or password" validation-error
flashed-variables validation-failed ;
validation-failed ;
: <login-action> ( -- action )
<page-action>
[
flashed-variables restore-flash
description get "description" set-value
capabilities get words>strings "capabilities" set-value
description cget "description" set-value
capabilities cget words>strings "capabilities" set-value
] >>init
{ login-realm "login" } >>template
@ -92,16 +90,12 @@ SYMBOL: capabilities
: <logout-action> ( -- action )
<action>
[ logout ] >>submit
<protected>
"logout" >>description ;
[ logout ] >>submit ;
M: login-realm login-required*
drop
M: login-realm login-required* ( description capabilities login -- response )
begin-aside
protected get description>> description set
protected get capabilities>> capabilities set
URL" $realm/login" >secure-url flashed-variables <flash-redirect> ;
[ description cset ] [ capabilities cset ] [ drop ] tri*
URL" $realm/login" >secure-url <redirect> ;
: <login-realm> ( responder name -- auth )
login-realm new-realm

81
extra/furnace/conversations/conversations.factor
View File

@ -25,7 +25,7 @@ conversation "CONVERSATIONS" {
{ "post-data" "POST_DATA" FACTOR-BLOB }
} define-persistent
: conversation-id-key "__f" ;
: conversation-id-key "__c" ;
TUPLE: conversations < server-state-manager ;
@ -55,28 +55,51 @@ SYMBOL: conversation-id
: request-conversation ( request -- conversation )
request-conversation-id get-conversation ;
: init-conversations ( -- )
: save-conversation-after ( conversation -- )
conversations get save-scope-after ;
: set-conversation ( conversation -- )
[
[ conversation set ]
[ id>> conversation-id set ]
[ save-conversation-after ]
tri
] when* ;
: init-conversations ( conversations -- )
conversations set
request get request-conversation-id
[ conversation-id set ]
[ get-conversation conversation set ]
bi ;
get-conversation
set-conversation ;
M: conversations call-responder*
init-conversations
[ conversations set ] [ call-next-method ] bi ;
[ init-conversations ]
[ conversations set ]
[ call-next-method ]
tri ;
: empty-conversastion ( -- conversation )
conversation empty-scope
session get id>> >>session ;
: add-conversation ( conversation -- id )
[ conversations get touch-state ] [ insert-tuple ] [ id>> ] tri ;
: touch-conversation ( conversation -- )
conversations get touch-state ;
: begin-conversation* ( -- id )
empty-conversastion add-conversation ;
: add-conversation ( conversation -- )
[ touch-conversation ] [ insert-tuple ] bi ;
: begin-conversation* ( -- conversation )
empty-conversastion dup add-conversation ;
: begin-conversation ( -- )
conversation-id [ [ begin-conversation* ] unless* ] change ;
conversation get [
begin-conversation*
set-conversation
] unless ;
: end-conversation ( -- )
conversation off
conversation-id off ;
: <conversation-redirect> ( url seq -- response )
begin-conversation
@ -91,17 +114,15 @@ M: conversations call-responder*
bi
] [ 2drop ] if ;
: begin-aside* ( -- id )
empty-conversastion
: begin-aside ( -- )
begin-conversation
conversation get
request get
[ method>> >>method ]
[ url>> >>url ]
[ post-data>> >>post-data ]
tri
add-conversation ;
: begin-aside ( -- )
begin-aside* conversation-id set ;
touch-conversation ;
: end-aside-post ( aside -- response )
request [
@ -116,18 +137,24 @@ M: conversations call-responder*
ERROR: end-aside-in-get-error ;
: end-aside* ( url id -- response )
: move-on ( id -- response )
post-request? [ end-aside-in-get-error ] unless
get-conversation [
dup method>> {
{ "GET" [ url>> <redirect> ] }
{ "HEAD" [ url>> <redirect> ] }
{ "POST" [ end-aside-post ] }
} case
] [ <redirect> ] ?if ;
dup method>> {
{ "GET" [ url>> <redirect> ] }
{ "HEAD" [ url>> <redirect> ] }
{ "POST" [ end-aside-post ] }
} case ;
: get-aside ( id -- conversation )
get-conversation dup [ dup method>> [ drop f ] unless ] when ;
: end-aside* ( url id -- response )
get-aside [ move-on ] [ <redirect> ] ?if ;
: end-aside ( default -- response )
conversation-id [ f ] change end-aside* ;
conversation-id get
end-conversation
end-aside* ;
M: conversations link-attr ( tag -- )
drop

61
extra/furnace/flash/flash.factor
View File

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

2
extra/furnace/sessions/sessions.factor
View File

@ -69,7 +69,7 @@ TUPLE: sessions < server-state-manager domain verify? ;
empty-session [ init-session ] [ insert-tuple ] [ ] tri ;
: save-session-after ( session -- )
sessions get <scope-saver> &dispose drop ;
sessions get save-scope-after ;
: existing-session ( path session -- response )
[ session set ] [ save-session-after ] bi

4
extra/http/http-tests.factor
View File

@ -275,7 +275,7 @@ test-db [
USING: html.components html.elements html.forms
xml xml.utilities validators
furnace furnace.flash ;
furnace furnace.conversations ;
SYMBOL: a
@ -287,7 +287,7 @@ SYMBOL: a
[ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
[ { { "a" [ v-integer ] } } validate-params ] >>validate
[ "a" value a set-global URL" " <redirect> ] >>submit
<flash-scopes>
<conversations>
<sessions>
>>default
add-quit-action

3
extra/http/server/redirection/redirection-tests.factor
View File

@ -1,6 +1,6 @@
IN: http.server.redirection.tests
USING: http http.server.redirection urls accessors
namespaces tools.test present ;
namespaces tools.test present kernel ;
\ relative-to-request must-infer
@ -11,6 +11,7 @@ namespaces tools.test present ;
"www.apple.com" >>host
"/xxx/bar" >>path
{ { "a" "b" } } >>query
dup url set
>>url
request set

1
extra/math/blas/cblas/cblas.factor
View File

@ -4,6 +4,7 @@ IN: math.blas.cblas
<< "cblas" {
{ [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] }
{ [ os windows? ] [ "blas.dll" "cdecl" add-library ] }
{ [ os openbsd? ] [ "libcblas.so" "cdecl" add-library ] }
[ "libblas.so" "cdecl" add-library ]
} cond >>

6
extra/unix/types/freebsd/freebsd.factor
View File

@ -4,8 +4,6 @@ IN: unix.types
! FreeBSD 7 x86.32
! Need to verify on 64-bit
TYPEDEF: ushort __uint16_t
TYPEDEF: uint __uint32_t
TYPEDEF: int __int32_t
@ -21,6 +19,6 @@ TYPEDEF: __int64_t off_t
TYPEDEF: __int64_t blkcnt_t
TYPEDEF: __uint32_t blksize_t
TYPEDEF: __uint32_t fflags_t
TYPEDEF: int ssize_t
TYPEDEF: long ssize_t
TYPEDEF: int pid_t
TYPEDEF: int time_t
TYPEDEF: int time_t

2
extra/unix/types/openbsd/openbsd.factor
View File

@ -27,6 +27,6 @@ TYPEDEF: __int64_t off_t
TYPEDEF: __int64_t blkcnt_t
TYPEDEF: __uint32_t blksize_t
TYPEDEF: __uint32_t fflags_t
TYPEDEF: int ssize_t
TYPEDEF: long ssize_t
TYPEDEF: int pid_t
TYPEDEF: int time_t

2
extra/webapps/blogs/blogs.factor
View File

@ -179,7 +179,7 @@ M: comment entity-url
: authorize-author ( author -- )
username =
{ can-administer-blogs? } have-capabilities? or
[ login-required ] unless ;
[ "edit a blog post" f login-required ] unless ;
: do-post-action ( -- )
validate-integer-id