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

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

db4
Alex Chapman 2008-03-18 00:38:39 +11:00
parent aef914b6ce 7bd91f68c9
commit 3ad90aa9bd
26 changed files with 610 additions and 235 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
extra/db/db.factor
View File

@ -33,6 +33,19 @@ HOOK: db-close db ( handle -- )
TUPLE: statement handle sql in-params out-params bind-params bound? ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
TUPLE: nonthrowable-statement ;
: make-nonthrowable ( obj -- obj' )
dup sequence? [
[ make-nonthrowable ] map
] [
nonthrowable-statement construct-delegate
] if ;
MIXIN: throwable-statement
INSTANCE: statement throwable-statement
INSTANCE: simple-statement throwable-statement
INSTANCE: prepared-statement throwable-statement
TUPLE: result-set sql in-params out-params handle n max ;
: <statement> ( sql in out -- statement )
{ (>>sql) (>>in-params) (>>out-params) } statement construct ;
@ -50,13 +63,22 @@ GENERIC# row-column-typed 1 ( result-set column -- sql )
GENERIC: advance-row ( result-set -- )
GENERIC: more-rows? ( result-set -- ? )
: execute-statement ( statement -- )
GENERIC: execute-statement ( statement -- )
M: throwable-statement execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each
] [
query-results dispose
] if ;
M: nonthrowable-statement execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each
] [
[ query-results dispose ] [ 2drop ] recover
] if ;
: bind-statement ( obj statement -- )
swap >>bind-params
[ bind-statement* ] keep

4
extra/db/postgresql/lib/lib.factor
View File

@ -73,7 +73,7 @@ IN: db.postgresql.lib
sql-spec-type {
{ FACTOR-BLOB [
dup [
binary [ serialize ] with-byte-writer
object>bytes
malloc-byte-array/length ] [ 0 ] if ] }
{ BLOB [
dup [ malloc-byte-array/length ] [ 0 ] if ] }
@ -164,7 +164,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
{ BLOB [ pq-get-blob ] }
{ FACTOR-BLOB [
pq-get-blob
dup [ binary [ deserialize ] with-byte-reader ] when ] }
dup [ bytes>object ] when ] }
[ no-sql-type ]
} case ;
! PQgetlength PQgetisnull

3
extra/db/postgresql/postgresql.factor
View File

@ -10,6 +10,7 @@ IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
TUPLE: postgresql-statement ;
INSTANCE: postgresql-statement throwable-statement
TUPLE: postgresql-result-set ;
: <postgresql-statement> ( statement in out -- postgresql-statement )
<statement>
@ -194,7 +195,7 @@ M: postgresql-db <insert-native-statement> ( class -- statement )
");" 0%
] postgresql-make ;
M: postgresql-db <insert-assigned-statement> ( class -- statement )
M: postgresql-db <insert-nonnative-statement> ( class -- statement )
[
"insert into " 0% 0%
"(" 0%

8
extra/db/sqlite/lib/lib.factor
View File

@ -94,7 +94,7 @@ IN: db.sqlite.lib
{ TIMESTAMP [ sqlite-bind-text-by-name ] }
{ BLOB [ sqlite-bind-blob-by-name ] }
{ FACTOR-BLOB [
binary [ serialize ] with-byte-writer
object>bytes
sqlite-bind-blob-by-name
] }
{ +native-id+ [ sqlite-bind-int-by-name ] }
@ -106,6 +106,8 @@ IN: db.sqlite.lib
: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
: sqlite-#columns ( query -- int ) sqlite3_column_count ;
: sqlite-column ( handle index -- string ) sqlite3_column_text ;
: sqlite-column-name ( handle index -- string ) sqlite3_column_name ;
: sqlite-column-type ( handle index -- string ) sqlite3_column_type ;
: sqlite-column-blob ( handle index -- byte-array/f )
[ sqlite3_column_bytes ] 2keep
@ -131,7 +133,7 @@ IN: db.sqlite.lib
{ BLOB [ sqlite-column-blob ] }
{ FACTOR-BLOB [
sqlite-column-blob
dup [ binary [ deserialize ] with-byte-reader ] when
dup [ bytes>object ] when
] }
! { NULL [ 2drop f ] }
[ no-sql-type ]
@ -140,7 +142,7 @@ IN: db.sqlite.lib
: sqlite-row ( handle -- seq )
dup sqlite-#columns [ sqlite-column ] with map ;
: sqlite-step-has-more-rows? ( step-result -- bool )
: sqlite-step-has-more-rows? ( prepared -- bool )
dup SQLITE_ROW = [
drop t
] [

26
extra/db/sqlite/sqlite.factor
View File

@ -6,6 +6,7 @@ prettyprint sequences strings tuples alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators
combinators.cleave io namespaces.lib ;
USE: tools.walker
IN: db.sqlite
TUPLE: sqlite-db path ;
@ -22,6 +23,8 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
TUPLE: sqlite-statement ;
INSTANCE: sqlite-statement throwable-statement
TUPLE: sqlite-result-set has-more? ;
M: sqlite-db <simple-statement> ( str in out -- obj )
@ -33,12 +36,20 @@ M: sqlite-db <prepared-statement> ( str in out -- obj )
set-statement-in-params
set-statement-out-params
} statement construct
db get db-handle over statement-sql sqlite-prepare
over set-statement-handle
sqlite-statement construct-delegate ;
: sqlite-maybe-prepare ( statement -- statement )
dup statement-handle [
[
delegate
db get db-handle over statement-sql sqlite-prepare
swap set-statement-handle
] keep
] unless ;
M: sqlite-statement dispose ( statement -- )
statement-handle sqlite-finalize ;
statement-handle
[ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
M: sqlite-result-set dispose ( result-set -- )
f swap set-result-set-handle ;
@ -46,9 +57,12 @@ M: sqlite-result-set dispose ( result-set -- )
: sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ;
: reset-statement ( statement -- ) statement-handle sqlite-reset ;
: reset-statement ( statement -- )
sqlite-maybe-prepare
statement-handle sqlite-reset ;
M: sqlite-statement bind-statement* ( statement -- )
sqlite-maybe-prepare
dup statement-bound? [ dup reset-statement ] when
[ statement-bind-params ] [ statement-handle ] bi
sqlite-bind ;
@ -89,6 +103,7 @@ M: sqlite-result-set more-rows? ( result-set -- ? )
sqlite-result-set-has-more? ;
M: sqlite-statement query-results ( query -- result-set )
sqlite-maybe-prepare
dup statement-handle sqlite-result-set <result-set>
dup advance-row ;
@ -125,7 +140,7 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
");" 0%
] sqlite-make ;
M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
<insert-native-statement> ;
: where-primary-key% ( specs -- )
@ -175,6 +190,7 @@ M: sqlite-db modifier-table ( -- hashtable )
H{
{ +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
! { +nonnative-id+ "primary key" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
{ +default+ "default" }

15
extra/db/tuples/tuples-tests.factor
View File

@ -9,7 +9,7 @@ IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real
ts date time blob factor-blob ;
: <person> ( name age real ts date time blob -- person )
: <person> ( name age real ts date time blob factor-blob -- person )
{
set-person-the-name
set-person-the-number
@ -190,11 +190,18 @@ TUPLE: annotation n paste-id summary author mode contents ;
: test-postgresql ( -- )
>r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
: test-repeated-insert
[ ] [ person ensure-table ] unit-test
[ ] [ person1 get insert-tuple ] unit-test
[ person1 get insert-tuple ] must-fail ;
[ native-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-tuples ] test-sqlite
! [ native-person-schema test-tuples ] test-postgresql
! [ assigned-person-schema test-tuples ] test-postgresql
[ native-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-repeated-insert ] test-sqlite
[ assigned-person-schema test-repeated-insert ] test-postgresql
TUPLE: serialize-me id data ;

16
extra/db/tuples/tuples.factor
View File

@ -28,7 +28,7 @@ HOOK: create-sql-statement db ( class -- obj )
HOOK: drop-sql-statement db ( class -- obj )
HOOK: <insert-native-statement> db ( class -- obj )
HOOK: <insert-assigned-statement> db ( class -- obj )
HOOK: <insert-nonnative-statement> db ( class -- obj )
HOOK: <update-tuple-statement> db ( class -- obj )
HOOK: <update-tuples-statement> db ( class -- obj )
@ -75,21 +75,25 @@ HOOK: insert-tuple* db ( tuple statement -- )
drop-sql-statement [ execute-statement ] with-disposals ;
: ensure-table ( class -- )
[ dup drop-table ] ignore-errors create-table ;
[
drop-sql-statement make-nonthrowable
[ execute-statement ] with-disposals
] [ create-table ] bi ;
: insert-native ( tuple -- )
dup class
db get db-insert-statements [ <insert-native-statement> ] cache
[ bind-tuple ] 2keep insert-tuple* ;
: insert-assigned ( tuple -- )
: insert-nonnative ( tuple -- )
! TODO logic here for unique ids
dup class
db get db-insert-statements [ <insert-assigned-statement> ] cache
db get db-insert-statements [ <insert-nonnative-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: insert-tuple ( tuple -- )
dup class db-columns find-primary-key assigned-id? [
insert-assigned
dup class db-columns find-primary-key nonnative-id? [
insert-nonnative
] [
insert-native
] if ;

37
extra/db/types/types.factor
View File

@ -3,7 +3,8 @@
USING: arrays assocs db kernel math math.parser
sequences continuations sequences.deep sequences.lib
words namespaces tools.walker slots slots.private classes
mirrors tuples combinators calendar.format symbols ;
mirrors tuples combinators calendar.format symbols
singleton ;
IN: db.types
HOOK: modifier-table db ( -- hash )
@ -14,22 +15,32 @@ HOOK: compound-type db ( str n -- hash )
TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
SYMBOLS: +native-id+ +assigned-id+ +autoincrement+
+serial+ +unique+ +default+ +null+ +not-null+
SINGLETON: +native-id+
SINGLETON: +assigned-id+
SINGLETON: +random-id+
UNION: +primary-key+ +native-id+ +assigned-id+ +random-id+ ;
UNION: +nonnative-id+ +random-id+ +assigned-id+ ;
! +native-id+ +assigned-id+ +random-assigned-id+
SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
+foreign-id+ +has-many+ ;
: (primary-key?) ( obj -- ? )
{ +native-id+ +assigned-id+ } member? ;
: primary-key? ( spec -- ? )
sql-spec-primary-key (primary-key?) ;
sql-spec-primary-key +primary-key+? ;
: native-id? ( spec -- ? )
sql-spec-primary-key +native-id+? ;
: nonnative-id? ( spec -- ? )
sql-spec-primary-key +nonnative-id+? ;
: normalize-spec ( spec -- )
dup sql-spec-type dup (primary-key?) [
dup sql-spec-type dup +primary-key+? [
swap set-sql-spec-primary-key
] [
drop dup sql-spec-modifiers [
(primary-key?)
+primary-key+?
] deep-find
[ swap set-sql-spec-primary-key ] [ drop ] if*
] if ;
@ -37,12 +48,6 @@ SYMBOLS: +native-id+ +assigned-id+ +autoincrement+
: find-primary-key ( specs -- obj )
[ sql-spec-primary-key ] find nip ;
: native-id? ( spec -- ? )
sql-spec-primary-key +native-id+ = ;
: assigned-id? ( spec -- ? )
sql-spec-primary-key +assigned-id+ = ;
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR
@ -69,7 +74,7 @@ TUPLE: no-sql-modifier ;
dup number? [ number>string ] when ;
: maybe-remove-id ( specs -- obj )
[ native-id? not ] subset ;
[ +native-id+? not ] subset ;
: remove-relations ( specs -- newcolumns )
[ relation? not ] subset ;

8
extra/delegate/delegate.factor
View File

@ -27,11 +27,11 @@ M: tuple-class group-words
swap [ slot-spec-writer ] map append ;
: define-consult-method ( word class quot -- )
pick add spin define-method ;
pick add >r swap create-method r> define ;
: define-consult ( class group quot -- )
>r group-words r>
swapd [ define-consult-method ] 2curry each ;
>r group-words swap r>
[ define-consult-method ] 2curry each ;
: CONSULT:
scan-word scan-word parse-definition swapd define-consult ; parsing
@ -39,7 +39,7 @@ M: tuple-class group-words
: define-mimic ( group mimicker mimicked -- )
>r >r group-words r> r> [
pick "methods" word-prop at dup
[ "method-def" word-prop spin define-method ]
[ >r swap create-method r> word-def define ]
[ 3drop ] if
] 2curry each ;

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

@ -5,8 +5,8 @@ IN: http.tests
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
[ "" ] [ "%XX%XX%XX" url-decode ] unit-test
[ "" ] [ "%XX%XX%X" url-decode ] unit-test
[ f ] [ "%XX%XX%XX" url-decode ] unit-test
[ f ] [ "%XX%XX%X" url-decode ] unit-test
[ "hello world" ] [ "hello+world" url-decode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test

17
extra/http/server/actions/actions.factor
View File

@ -38,10 +38,13 @@ TUPLE: action init display submit get-params post-params ;
action get display>> call exit-with ;
M: action call-responder ( path action -- response )
[ +path+ associate request-params union params set ]
[ action set ] bi*
request get method>> {
{ "GET" [ handle-get ] }
{ "HEAD" [ handle-get ] }
{ "POST" [ handle-post ] }
} case ;
'[
, ,
[ +path+ associate request-params union params set ]
[ action set ] bi*
request get method>> {
{ "GET" [ handle-get ] }
{ "HEAD" [ handle-get ] }
{ "POST" [ handle-post ] }
} case
] with-exit-continuation ;

19
extra/http/server/auth/auth.factor
View File

@ -1,9 +1,26 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: http.server.sessions accessors
http.server.auth.providers ;
http.server.auth.providers assocs namespaces kernel ;
IN: http.server.auth
SYMBOL: logged-in-user
SYMBOL: user-profile-changed?
GENERIC: init-user-profile ( responder -- )
M: object init-user-profile drop ;
: uid ( -- string ) logged-in-user sget username>> ;
: profile ( -- assoc ) logged-in-user sget profile>> ;
: uget ( key -- value )
profile at ;
: uset ( value key -- )
profile set-at user-profile-changed? on ;
: uchange ( quot key -- )
profile swap change-at
user-profile-changed? on ; inline

34
extra/http/server/auth/login/login.factor
View File

@ -7,16 +7,29 @@ http.server.actions http.server.components http.server.sessions
http.server.templating.fhtml http.server.validators
http.server.auth http sequences io.files namespaces hashtables
fry io.sockets combinators.cleave arrays threads locals
qualified ;
qualified continuations destructors ;
IN: http.server.auth.login
QUALIFIED: smtp
SYMBOL: post-login-url
SYMBOL: login-failed?
TUPLE: login users ;
: users login get users>> ;
SYMBOL: post-login-url
SYMBOL: login-failed?
! Destructor
TUPLE: user-saver user ;
C: <user-saver> user-saver
M: user-saver dispose
user-profile-changed? get [
user>> users update-user
] [ drop ] if ;
: save-user-after ( user -- )
<user-saver> add-always-destructor ;
! ! ! Login
@ -116,6 +129,8 @@ SYMBOL: user-exists?
] unless*
successful-login
login get responder>> init-user-profile
] >>submit
] ;
@ -155,23 +170,21 @@ SYMBOL: previous-page
form validate-form
logged-in-user sget
"password" value empty? [
logged-in-user sget
] [
same-password-twice
"password" value uid users check-login
[ login-failed? on validation-failed ] unless
"new-password" value uid users set-password
[ "User deleted" throw ] unless*
] if
"new-password" value set-password
] unless
"realname" value >>realname
"email" value >>email
dup users update-user
logged-in-user sset
user-profile-changed? on
previous-page sget f <permanent-redirect>
] >>submit
@ -330,6 +343,7 @@ C: <protected> protected
M: protected call-responder ( path responder -- response )
logged-in-user sget [
dup save-user-after
request get request-url previous-page sset
responder>> call-responder
] [

6
extra/http/server/auth/providers/assoc/assoc-tests.factor
View File

@ -22,11 +22,11 @@ namespaces accessors kernel ;
[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
[ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test
[ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test
[ f ] [ "xx" "blah" "provider" get set-password ] unit-test
[ t ] [ "user" get >boolean ] unit-test
[ t ] [ "fdasf" "slava" "provider" get set-password >boolean ] unit-test
[ ] [ "user" get "fdasf" set-password drop ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test

20
extra/http/server/auth/providers/db/db-tests.factor
View File

@ -12,26 +12,28 @@ users-in-db "provider" set
[ t ] [
<user>
"slava" >>username
"foobar" >>password
"slava@factorcode.org" >>email
"provider" get new-user
username>> "slava" =
"slava" >>username
"foobar" >>password
"slava@factorcode.org" >>email
"provider" get new-user
username>> "slava" =
] unit-test
[ f ] [
<user>
"slava" >>username
"slava" >>username
"provider" get new-user
] unit-test
[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
[ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test
[ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test
[ f ] [ "xx" "blah" "provider" get set-password ] unit-test
[ t ] [ "user" get >boolean ] unit-test
[ t ] [ "fdasf" "slava" "provider" get set-password >boolean ] unit-test
[ ] [ "user" get "fdasf" set-password drop ] unit-test
[ ] [ "user" get "provider" get update-user ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test

11
extra/http/server/auth/providers/providers.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel new-slots accessors random math.parser locals
sequences math ;
sequences math crypto.sha2 ;
IN: http.server.auth.providers
TUPLE: user username realname password email ticket profile ;
@ -17,14 +17,7 @@ GENERIC: new-user ( user provider -- user/f )
: check-login ( password username provider -- user/f )
get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;
:: set-password ( password username provider -- user/f )
[let | user [ username provider get-user ] |
user [
user
password >>password
dup provider update-user
] [ f ] if
] ;
: set-password ( user password -- user ) >>password ;
! Password recovery support

15
extra/http/server/callbacks/callbacks.factor
View File

@ -98,11 +98,18 @@ SYMBOL: current-show
cont-id query-param swap callbacks>> at ;
M: callback-responder call-responder ( path responder -- response )
[ callback-responder set ]
[ request get resuming-callback ] bi
'[
, ,
[ invoke-callback ]
[ callback-responder get responder>> call-responder ] ?if ;
[ callback-responder set ]
[ request get resuming-callback ] bi
[
invoke-callback
] [
callback-responder get responder>> call-responder
] ?if
] with-exit-continuation ;
: show-page ( quot -- )
>r redirect-to-here store-current-show r>

27
extra/http/server/server.factor
View File

@ -185,21 +185,20 @@ SYMBOL: exit-continuation
: exit-with exit-continuation get continue-with ;
: with-exit-continuation ( quot -- )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
: do-request ( request -- response )
'[
exit-continuation set ,
[
[ log-request ]
[ request set ]
[ path>> main-responder get call-responder ] tri
[ <404> ] unless*
] [
[ \ do-request log-error ]
[ <500> ]
bi
] recover
] callcc1
exit-continuation off ;
[
[ log-request ]
[ request set ]
[ path>> main-responder get call-responder ] tri
[ <404> ] unless*
] [
[ \ do-request log-error ]
[ <500> ]
bi
] recover ;
: default-timeout 1 minutes stdio get set-timeout ;

41
extra/http/server/sessions/sessions-tests.factor
View File

@ -1,8 +1,8 @@
IN: http.server.sessions.tests
USING: tools.test http http.server.sessions
http.server.sessions.storage http.server.sessions.storage.assoc
http.server math namespaces kernel accessors prettyprint
io.streams.string splitting destructors ;
http.server.actions http.server math namespaces kernel accessors
prettyprint io.streams.string splitting destructors sequences ;
[ H{ } ] [ H{ } add-session-id ] unit-test
@ -72,9 +72,9 @@ M: foo call-responder
: url-responder-mock-test
[
<request>
"GET" >>method
"id" get session-id-key set-query-param
"/" >>path
"GET" >>method
"id" get session-id-key set-query-param
"/" >>path
request set
"/" "manager" get call-responder
[ write-response-body drop ] with-string-writer
@ -107,9 +107,9 @@ response set
: cookie-responder-mock-test
[
<request>
"GET" >>method
"cookies" get >>cookies
"/" >>path
"GET" >>method
"cookies" get >>cookies
"/" >>path
request set
"/" "manager" get call-responder
[ write-response-body drop ] with-string-writer
@ -118,3 +118,28 @@ response set
[ "2" ] [ cookie-responder-mock-test ] unit-test
[ "3" ] [ cookie-responder-mock-test ] unit-test
[ "4" ] [ cookie-responder-mock-test ] unit-test
: <exiting-action>
<action>
[
"text/plain" <content> exit-with
] >>display ;
[
[ ] [
<request>
"GET" >>method
"id" get session-id-key set-query-param
"/" >>path
request set
[
"/" <exiting-action> <cookie-sessions>
call-responder
] with-destructors response set
] unit-test
[ "text/plain" ] [ response get "content-type" header ] unit-test
[ f ] [ response get cookies>> empty? ] unit-test
] with-scope

7
extra/http/server/sessions/sessions.factor
View File

@ -13,7 +13,7 @@ IN: http.server.sessions
GENERIC: init-session* ( responder -- )
M: dispatcher init-session* drop ;
M: object init-session* drop ;
TUPLE: session-manager responder sessions ;
@ -56,8 +56,11 @@ M: session-saver dispose
sessions update-session
] [ drop ] if ;
: save-session-after ( id session -- )
<session-saver> add-always-destructor ;
: call-responder/session ( path responder id session -- response )
[ <session-saver> add-always-destructor ]
[ save-session-after ]
[ [ session-id set ] [ session set ] bi* ] 2bi
[ session-manager set ] [ responder>> call-responder ] bi ;

14
extra/http/server/sessions/storage/db/db.factor
View File

@ -21,23 +21,18 @@ session "SESSIONS"
session construct-empty
swap dup [ string>number ] when >>id ;
USING: namespaces io prettyprint ;
M: sessions-in-db get-session ( id storage -- namespace/f )
global [ "get " write over print flush ] bind
drop
dup [
<session>
select-tuple dup [ namespace>> ] when global [ dup . ] bind
select-tuple dup [ namespace>> ] when
] when ;
M: sessions-in-db update-session ( namespace id storage -- )
global [ "update " write over print flush ] bind
drop
<session>
swap global [ dup . ] bind >>namespace
dup update-tuple
id>> <session> select-tuple global [ . flush ] bind
;
swap >>namespace
update-tuple ;
M: sessions-in-db delete-session ( id storage -- )
drop
@ -45,8 +40,7 @@ M: sessions-in-db delete-session ( id storage -- )
delete-tuple ;
M: sessions-in-db new-session ( namespace storage -- id )
global [ "new " print flush ] bind
drop
f <session>
swap global [ dup . ] bind >>namespace
swap >>namespace
[ insert-tuple ] [ id>> number>string ] bi ;

38
extra/openssl/openssl-tests.factor
View File

@ -21,55 +21,55 @@ namespaces math math.parser openssl prettyprint sequences tools.test ;
! Initialize context
! =========================================================
init load-error-strings
[ ] [ init load-error-strings ] unit-test
ssl-v23 new-ctx
[ ] [ ssl-v23 new-ctx ] unit-test
get-ctx "/extra/openssl/test/server.pem" resource-path use-cert-chain
[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path use-cert-chain ] unit-test
! TODO: debug 'Memory protection fault at address 6c'
! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd
get-ctx "password" string>char-alien set-default-passwd-userdata
[ ] [ get-ctx "password" string>char-alien set-default-passwd-userdata ] unit-test
! Enter PEM pass phrase: password
get-ctx "/extra/openssl/test/server.pem" resource-path
SSL_FILETYPE_PEM use-private-key
[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path
SSL_FILETYPE_PEM use-private-key ] unit-test
get-ctx "/extra/openssl/test/root.pem" resource-path f
verify-load-locations
[ ] [ get-ctx "/extra/openssl/test/root.pem" resource-path f
verify-load-locations ] unit-test
get-ctx 1 set-verify-depth
[ ] [ get-ctx 1 set-verify-depth ] unit-test
! =========================================================
! Load Diffie-Hellman parameters
! =========================================================
"/extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file
[ ] [ "/extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file ] unit-test
get-bio f f f read-pem-dh-params
[ ] [ get-bio f f f read-pem-dh-params ] unit-test
get-bio bio-free
[ ] [ get-bio bio-free ] unit-test
! TODO: debug SSL_CTX_set_tmp_dh 'No such symbol'
! get-ctx get-dh set-tmp-dh-callback
[ ] [ get-ctx get-dh set-tmp-dh-callback ] unit-test
! Workaround (this function should never be called directly)
get-ctx SSL_CTRL_SET_TMP_DH 0 get-dh set-ctx-ctrl
! [ ] [ get-ctx SSL_CTRL_SET_TMP_DH 0 get-dh set-ctx-ctrl ] unit-test
! =========================================================
! Generate ephemeral RSA key
! =========================================================
512 RSA_F4 f f generate-rsa-key
[ ] [ 512 RSA_F4 f f generate-rsa-key ] unit-test
! TODO: debug SSL_CTX_set_tmp_rsa 'No such symbol'
! get-ctx get-rsa set-tmp-rsa-callback
! Workaround (this function should never be called directly)
get-ctx SSL_CTRL_SET_TMP_RSA 0 get-rsa set-ctx-ctrl
[ ] [ get-ctx SSL_CTRL_SET_TMP_RSA 0 get-rsa set-ctx-ctrl ] unit-test
get-rsa free-rsa
[ ] [ get-rsa free-rsa ] unit-test
! =========================================================
! Listen and accept on socket
@ -129,11 +129,11 @@ get-rsa free-rsa
! Dump errors to file
! =========================================================
"/extra/openssl/test/errors.txt" resource-path "w" bio-new-file
[ ] [ "/extra/openssl/test/errors.txt" resource-path "w" bio-new-file ] unit-test
[ 6 ] [ get-bio "Hello\n" bio-print ] unit-test
get-bio bio-free
[ ] [ get-bio bio-free ] unit-test
! =========================================================
! Clean-up

174
extra/reports/noise/noise.factor Executable file
View File

@ -0,0 +1,174 @@
USING: assocs math kernel shuffle combinators.lib
words quotations arrays combinators sequences math.vectors
io.styles combinators.cleave prettyprint vocabs sorting io
generic locals.private math.statistics ;
IN: reports.noise
: badness ( word -- n )
H{
{ -nrot 5 }
{ -roll 4 }
{ -rot 3 }
{ 2apply 1 }
{ 2curry 1 }
{ 2drop 1 }
{ 2dup 1 }
{ 2keep 1 }
{ 2nip 2 }
{ 2over 4 }
{ 2slip 2 }
{ 2swap 3 }
{ 2with 2 }
{ 2with* 3 }
{ 3apply 1/2 }
{ 3curry 2 }
{ 3drop 1 }
{ 3dup 2 }
{ 3keep 3 }
{ 3nip 4 }
{ 3slip 3 }
{ 3with 3 }
{ 3with* 4 }
{ 4drop 2 }
{ 4dup 3 }
{ 4slip 4 }
{ compose 1/2 }
{ curry 1/3 }
{ dip 1 }
{ dipd 2 }
{ drop 1/3 }
{ dup 1/3 }
{ if 1/3 }
{ when 1/4 }
{ unless 1/4 }
{ when* 1/3 }
{ unless* 1/3 }
{ ?if 1/2 }
{ cond 1/2 }
{ case 1/2 }
{ keep 1 }
{ napply 2 }
{ ncurry 3 }
{ ndip 5 }
{ ndrop 2 }
{ ndup 3 }
{ nip 2 }
{ nipd 3 }
{ nkeep 5 }
{ npick 6 }
{ nrev 5 }
{ nrot 5 }
{ nslip 5 }
{ ntuck 6 }
{ nwith 4 }
{ over 2 }
{ pick 4 }
{ roll 4 }
{ rot 3 }
{ slip 1 }
{ spin 3 }
{ swap 1 }
{ swapd 3 }
{ tuck 2 }
{ tuckd 4 }
{ with 1/2 }
{ with* 2 }
{ r> 1 }
{ >r 1 }
{ bi 1/2 }
{ tri 1 }
{ bi* 1/2 }
{ tri* 1 }
{ cleave 2 }
{ spread 2 }
} at 0 or ;
: vsum { 0 0 } [ v+ ] reduce ;
GENERIC: noise ( obj -- pair )
M: word noise badness 1 2array ;
M: wrapper noise wrapped noise ;
M: let noise let-body noise ;
M: wlet noise wlet-body noise ;
M: lambda noise lambda-body noise ;
M: object noise drop { 0 0 } ;
M: quotation noise [ noise ] map vsum { 1/4 1/2 } v+ ;
M: array noise [ noise ] map vsum ;
: noise-factor / 100 * >integer ;
: quot-noise-factor ( quot -- n )
#! For very short words, noise doesn't count so much
#! (so dup foo swap bar isn't penalized as badly).
noise first2 {
{ [ over 4 <= ] [ >r drop 0 r> ] }
{ [ over 15 >= ] [ >r 2 * r> ] }
{ [ t ] [ ] }
} cond
{
! short words are easier to read
{ [ dup 10 <= ] [ >r 2 / r> ] }
{ [ dup 5 <= ] [ >r 3 / r> ] }
! long words are penalized even more
{ [ dup 25 >= ] [ >r 2 * r> 20 max ] }
{ [ dup 20 >= ] [ >r 5/3 * r> ] }
{ [ dup 15 >= ] [ >r 3/2 * r> ] }
{ [ t ] [ ] }
} cond noise-factor ;
GENERIC: word-noise-factor ( word -- factor )
M: word word-noise-factor
word-def quot-noise-factor ;
M: lambda-word word-noise-factor
"lambda" word-prop quot-noise-factor ;
: flatten-generics ( words -- words' )
[
dup generic? [ methods values ] [ 1array ] if
] map concat ;
: noisy-words ( -- alist )
all-words flatten-generics
[ dup word-noise-factor ] { } map>assoc
sort-values reverse ;
: noise. ( alist -- )
standard-table-style [
[
[ [ pprint-cell ] [ pprint-cell ] bi* ] with-row
] assoc-each
] tabular-output ;
: vocab-noise-factor ( vocab -- factor )
words flatten-generics
[ word-noise-factor dup 20 < [ drop 0 ] when ] map
dup empty? [ drop 0 ] [
[ [ sum ] [ length 5 max ] bi /i ]
[ supremum ]
bi +
] if ;
: noisy-vocabs ( -- alist )
vocabs [ dup vocab-noise-factor ] { } map>assoc
sort-values reverse ;
: noise-report ( -- )
"NOISY WORDS:" print
noisy-words 80 head noise.
nl
"NOISY VOCABS:" print
noisy-vocabs 80 head noise. ;
MAIN: noise-report

33
extra/reports/optimizer/optimizer.factor Executable file
View File

@ -0,0 +1,33 @@
USING: assocs words sequences arrays compiler tools.time
io.styles io prettyprint vocabs kernel sorting generator
optimizer math combinators.cleave ;
IN: report.optimizer
: count-optimization-passes ( nodes n -- n )
>r optimize-1
[ r> 1+ count-optimization-passes ] [ drop r> ] if ;
: results
[ [ second ] swap compose compare ] curry sort 20 tail*
print
standard-table-style
[
[ [ [ pprint-cell ] each ] with-row ] each
] tabular-output ; inline
: optimizer-measurements ( -- alist )
all-words [ compiled? ] subset
[
dup [
word-dataflow nip 1 count-optimization-passes
] benchmark nip 2array
] { } map>assoc ;
: optimizer-measurements. ( alist -- )
[ [ first ] "Worst number of optimizer passes:" results ]
[ [ second ] "Worst compile times:" results ] bi ;
: optimizer-report ( -- )
optimizer-measurements optimizer-measurements. ;
MAIN: optimizer-report

30
extra/serialize/serialize-tests.factor
View File

@ -4,7 +4,7 @@
USING: tools.test kernel serialize io io.streams.byte-array math
alien arrays byte-arrays sequences math prettyprint parser
classes math.constants io.encodings.binary random
combinators.lib ;
combinators.lib assocs ;
IN: serialize.tests
: test-serialize-cell
@ -56,19 +56,23 @@ C: <serialize-test> serialize-test
} ;
: check-serialize-1 ( obj -- ? )
"=====" print
dup class .
dup .
dup
binary [ serialize ] with-byte-writer
binary [ deserialize ] with-byte-reader = ;
object>bytes
bytes>object
dup . = ;
: check-serialize-2 ( obj -- ? )
dup number? over wrapper? or [
drop t ! we don't care if numbers aren't interned
] [
"=====" print
dup class .
dup 2array
binary [ serialize ] with-byte-writer
binary [ deserialize ] with-byte-reader
dup 2array dup .
object>bytes
bytes>object dup .
first2 eq?
] if ;
@ -79,3 +83,17 @@ C: <serialize-test> serialize-test
[ t ] [ pi check-serialize-1 ] unit-test
[ serialize ] must-infer
[ deserialize ] must-infer
[ t ] [
V{ } dup dup push
object>bytes
bytes>object
dup first eq?
] unit-test
[ t ] [
H{ } dup dup dup set-at
object>bytes
bytes>object
dup keys first eq?
] unit-test

214
extra/serialize/serialize.factor
View File

@ -6,13 +6,14 @@
!
! See http://factorcode.org/license.txt for BSD license.
!
IN: serialize
USING: namespaces sequences kernel math io math.functions
io.binary strings classes words sbufs tuples arrays
vectors byte-arrays bit-arrays quotations hashtables
assocs help.syntax help.markup float-arrays splitting
io.encodings.string io.encodings.utf8 combinators new-slots
accessors ;
io.binary strings classes words sbufs tuples arrays vectors
byte-arrays bit-arrays quotations hashtables assocs help.syntax
help.markup float-arrays splitting io.streams.byte-array
io.encodings.string io.encodings.utf8 io.encodings.binary
combinators combinators.cleave new-slots accessors locals
prettyprint compiler.units sequences.private tuples.private ;
IN: serialize
! Variable holding a assoc of objects already serialized
SYMBOL: serialized
@ -69,7 +70,8 @@ GENERIC: (serialize) ( obj -- )
: serialize-shared ( obj quot -- )
>r dup object-id
[ CHAR: o write1 serialize-cell drop ] r> if* ; inline
[ CHAR: o write1 serialize-cell drop ]
r> if* ; inline
M: f (serialize) ( obj -- )
drop CHAR: n write1 ;
@ -96,75 +98,93 @@ M: ratio (serialize) ( obj -- )
dup numerator (serialize)
denominator (serialize) ;
: serialize-string ( obj code -- )
write1
dup utf8 encode dup length serialize-cell write
add-object ;
M: string (serialize) ( obj -- )
[ CHAR: s serialize-string ] serialize-shared ;
: serialize-elements ( seq -- )
[ (serialize) ] each CHAR: . write1 ;
: serialize-seq ( obj code -- )
[
write1
[ add-object ]
[ length serialize-cell ]
[ [ (serialize) ] each ] tri
] curry serialize-shared ;
M: tuple (serialize) ( obj -- )
[
CHAR: T write1
dup tuple>array serialize-elements
add-object
[ class (serialize) ]
[ add-object ]
[ tuple>array 1 tail (serialize) ]
tri
] serialize-shared ;
: serialize-seq ( seq code -- )
[
write1
dup serialize-elements
add-object
] curry serialize-shared ;
M: array (serialize) ( obj -- )
CHAR: a serialize-seq ;
M: byte-array (serialize) ( obj -- )
[
CHAR: A write1
dup dup length serialize-cell write
add-object
] serialize-shared ;
M: bit-array (serialize) ( obj -- )
[
CHAR: b write1
dup length serialize-cell
dup [ 1 0 ? ] B{ } map-as write
add-object
] serialize-shared ;
M: quotation (serialize) ( obj -- )
CHAR: q serialize-seq ;
M: float-array (serialize) ( obj -- )
[
CHAR: f write1
dup length serialize-cell
dup [ double>bits 8 >be write ] each
add-object
CHAR: q write1 [ >array (serialize) ] [ add-object ] bi
] serialize-shared ;
M: hashtable (serialize) ( obj -- )
[
CHAR: h write1
dup >alist (serialize)
add-object
[ add-object ] [ >alist (serialize) ] bi
] serialize-shared ;
M: word (serialize) ( obj -- )
M: bit-array (serialize) ( obj -- )
CHAR: b serialize-seq ;
M: byte-array (serialize) ( obj -- )
[
CHAR: w write1
dup word-name (serialize)
dup word-vocabulary (serialize)
add-object
CHAR: A write1
[ add-object ]
[ length serialize-cell ]
[ write ] tri
] serialize-shared ;
M: float-array (serialize) ( obj -- )
[
CHAR: f write1
[ add-object ]
[ length serialize-cell ]
[ [ double>bits 8 >be write ] each ]
tri
] serialize-shared ;
M: string (serialize) ( obj -- )
[
CHAR: s write1
[ add-object ]
[
utf8 encode
[ length serialize-cell ]
[ write ] bi
] bi
] serialize-shared ;
: serialize-true ( word -- )
drop CHAR: t write1 ;
: serialize-gensym ( word -- )
[
CHAR: G write1
[ add-object ]
[ word-def (serialize) ]
[ word-props (serialize) ]
tri
] serialize-shared ;
: serialize-word ( word -- )
CHAR: w write1
[ word-name (serialize) ]
[ word-vocabulary (serialize) ]
bi ;
M: word (serialize) ( obj -- )
{
{ [ dup t eq? ] [ serialize-true ] }
{ [ dup word-vocabulary not ] [ serialize-gensym ] }
{ [ t ] [ serialize-word ] }
} cond ;
M: wrapper (serialize) ( obj -- )
CHAR: W write1
wrapped (serialize) ;
@ -179,6 +199,9 @@ SYMBOL: deserialized
: deserialize-false ( -- f )
f ;
: deserialize-true ( -- f )
t ;
: deserialize-positive-integer ( -- number )
deserialize-cell ;
@ -204,53 +227,63 @@ SYMBOL: deserialized
(deserialize-string) dup intern-object ;
: deserialize-word ( -- word )
(deserialize) dup (deserialize) lookup
[ dup intern-object ] [ "Unknown word" throw ] ?if ;
(deserialize) (deserialize) 2dup lookup
dup [ 2nip ] [
"Unknown word: " -rot
2array unparse append throw
] if ;
: deserialize-gensym ( -- word )
gensym
dup intern-object
dup (deserialize) define
dup (deserialize) swap set-word-props ;
: deserialize-wrapper ( -- wrapper )
(deserialize) <wrapper> ;
SYMBOL: +stop+
: (deserialize-seq) ( -- seq )
[ (deserialize) dup +stop+ get eq? not ] [ ] [ drop ] unfold ;
: deserialize-seq ( seq -- array )
>r (deserialize-seq) r> like dup intern-object ;
:: (deserialize-seq) ( exemplar quot -- seq )
deserialize-cell exemplar new
[ intern-object ]
[ dup [ drop quot call ] change-each ] bi ; inline
: deserialize-array ( -- array )
{ } deserialize-seq ;
{ } [ (deserialize) ] (deserialize-seq) ;
: deserialize-quotation ( -- array )
[ ] deserialize-seq ;
: (deserialize-byte-array) ( -- byte-array )
deserialize-cell read B{ } like ;
(deserialize) >quotation dup intern-object ;
: deserialize-byte-array ( -- byte-array )
(deserialize-byte-array) dup intern-object ;
B{ } [ read1 ] (deserialize-seq) ;
: deserialize-bit-array ( -- bit-array )
(deserialize-byte-array) [ 0 > ] ?{ } map-as
dup intern-object ;
?{ } [ (deserialize) ] (deserialize-seq) ;
: deserialize-float-array ( -- float-array )
deserialize-cell
8 * read 8 <groups> [ be> bits>double ] F{ } map-as
dup intern-object ;
F{ } [ 8 read be> bits>double ] (deserialize-seq) ;
: deserialize-hashtable ( -- hashtable )
(deserialize) >hashtable dup intern-object ;
H{ } clone
[ intern-object ]
[ (deserialize) update ]
[ ] tri ;
: copy-seq-to-tuple ( seq tuple -- )
>r dup length [ 1+ ] map r> [ set-array-nth ] curry 2each ;
: deserialize-tuple ( -- array )
(deserialize-seq) >tuple dup intern-object ;
#! Ugly because we have to intern the tuple before reading
#! slots
(deserialize) construct-empty
[ intern-object ]
[
[ (deserialize) ]
[ [ copy-seq-to-tuple ] keep ] bi*
] bi ;
: deserialize-unknown ( -- object )
deserialize-cell deserialized get nth ;
: deserialize-stop ( -- object )
+stop+ get ;
: deserialize* ( -- object ? )
read1 [
{
@ -265,14 +298,15 @@ SYMBOL: +stop+
{ CHAR: h [ deserialize-hashtable ] }
{ CHAR: m [ deserialize-negative-integer ] }
{ CHAR: n [ deserialize-false ] }
{ CHAR: t [ deserialize-true ] }
{ CHAR: o [ deserialize-unknown ] }
{ CHAR: p [ deserialize-positive-integer ] }
{ CHAR: q [ deserialize-quotation ] }
{ CHAR: r [ deserialize-ratio ] }
{ CHAR: s [ deserialize-string ] }
{ CHAR: w [ deserialize-word ] }
{ CHAR: G [ deserialize-word ] }
{ CHAR: z [ deserialize-zero ] }
{ CHAR: . [ deserialize-stop ] }
} case t
] [
f f
@ -283,13 +317,15 @@ SYMBOL: +stop+
: deserialize ( -- obj )
[
V{ } clone deserialized set
gensym +stop+ set
(deserialize)
] with-scope ;
V{ } clone deserialized
[ (deserialize) ] with-variable
] with-compilation-unit ;
: serialize ( obj -- )
[
H{ } clone serialized set
(serialize)
] with-scope ;
H{ } clone serialized [ (serialize) ] with-variable ;
: bytes>object ( bytes -- obj )
binary [ deserialize ] with-byte-reader ;
: object>bytes ( obj -- bytes )
binary [ serialize ] with-byte-writer ;