Working on HTTP server

db4
Slava Pestov 2008-03-17 04:31:13 -05:00
parent 604a895f99
commit d4be6ea98c
15 changed files with 239 additions and 121 deletions

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

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 ;

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

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
] [

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

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

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

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>

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 ;

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

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 ;

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 ;

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

View File

@ -1,7 +1,7 @@
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 ;
generic locals.private math.statistics ;
IN: reports.noise
: badness ( word -- n )
@ -12,9 +12,9 @@ IN: reports.noise
{ 2apply 1 }
{ 2curry 1 }
{ 2drop 1 }
{ 2dup 2 }
{ 2keep 2 }
{ 2nip 3 }
{ 2dup 1 }
{ 2keep 1 }
{ 2nip 2 }
{ 2over 4 }
{ 2slip 2 }
{ 2swap 3 }
@ -33,11 +33,19 @@ IN: reports.noise
{ 4dup 3 }
{ 4slip 4 }
{ compose 1/2 }
{ curry 1/2 }
{ curry 1/3 }
{ dip 1 }
{ dipd 2 }
{ drop 1/2 }
{ dup 1/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 }
@ -62,11 +70,11 @@ IN: reports.noise
{ swap 1 }
{ swapd 3 }
{ tuck 2 }
{ tuckd 3 }
{ with 1 }
{ tuckd 4 }
{ with 1/2 }
{ with* 2 }
{ r> 1/2 }
{ >r 1/2 }
{ r> 1 }
{ >r 1 }
{ bi 1/2 }
{ tri 1 }
@ -93,14 +101,30 @@ M: lambda noise lambda-body noise ;
M: object noise drop { 0 0 } ;
M: quotation noise [ noise ] map vsum { 1/3 0 } v+ ;
M: quotation noise [ noise ] map vsum { 1/4 1/2 } v+ ;
M: array noise [ noise ] map vsum { 1/3 0 } 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 15 max / 100 * >integer ;
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 )
@ -110,20 +134,41 @@ M: word word-noise-factor
M: lambda-word word-noise-factor
"lambda" word-prop quot-noise-factor ;
: noisy-words ( -- alist )
all-words [
: flatten-generics ( words -- words' )
[
dup generic? [ methods values ] [ 1array ] if
] map concat [ dup word-noise-factor ] { } map>assoc
] map concat ;
: noisy-words ( -- alist )
all-words flatten-generics
[ dup word-noise-factor ] { } map>assoc
sort-values reverse ;
: noisy-words. ( alist -- )
: 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 40 head noisy-words. ;
"NOISY WORDS:" print
noisy-words 80 head noise.
nl
"NOISY VOCABS:" print
noisy-vocabs 80 head noise. ;
MAIN: noise-report

View File

@ -24,7 +24,11 @@ SYMBOL: walking-thread
: break ( -- )
continuation callstack over set-continuation-call
get-walker-thread send-synchronous {
USE: prettyprint USE: io.streams.c
"BREAK" show
get-walker-thread dup unparse-short show "SS" show send-synchronous
USE: prettyprint USE: io.streams.c
unparse-short show {
{ [ dup continuation? ] [ (continue) ] }
{ [ dup quotation? ] [ call ] }
{ [ dup not ] [ "Single stepping abandoned" throw ] }
@ -146,10 +150,18 @@ SYMBOL: +detached+
walker-status tget set-model ;
: unassociate-thread ( -- )
walker-thread walking-thread tget thread-variables delete-at
[ ] walking-thread tget set-thread-exit-handler ;
walker-thread walking-thread tget thread-variables at self eq? [
walker-thread walking-thread tget thread-variables delete-at
[ ] walking-thread tget set-thread-exit-handler
] [
USE: io
global [ "OOPS" print flush ] bind
] if ;
: xshow self unparse-short append show ;
: detach-msg ( -- )
"DETACH" xshow
+detached+ set-status
unassociate-thread ;
@ -195,6 +207,7 @@ SYMBOL: +detached+
: walker-suspended ( continuation -- continuation' )
+suspended+ set-status
[ status +suspended+ eq? ] [
"SUSPENDED" xshow
dup walker-history tget push
dup walker-continuation tget set-model
[
@ -222,6 +235,7 @@ SYMBOL: +detached+
: walker-loop ( -- )
+running+ set-status
[ status +detached+ eq? not ] [
"RUNNING" xshow
[
{
{ detach [ detach-msg f ] }
@ -241,7 +255,9 @@ SYMBOL: +detached+
[ walker-suspended ]
} case
] handle-synchronous
] [ ] while ;
] [ ] while USE: dlists USE: concurrency.mailboxes
"EXIT" xshow
my-mailbox mailbox-data dlist-empty? [ "Crap" print flush ] unless ;
: associate-thread ( walker -- )
walker-thread tset