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

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5,8 +5,8 @@ IN: http.tests
[ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test [ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
[ "" ] [ "%XX%XX%XX" url-decode ] unit-test [ f ] [ "%XX%XX%XX" url-decode ] unit-test
[ "" ] [ "%XX%XX%X" url-decode ] unit-test [ f ] [ "%XX%XX%X" url-decode ] unit-test
[ "hello world" ] [ "hello+world" url-decode ] unit-test [ "hello world" ] [ "hello+world" url-decode ] unit-test
[ "hello world" ] [ "hello%20world" 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 ; action get display>> call exit-with ;
M: action call-responder ( path action -- response ) M: action call-responder ( path action -- response )
[ +path+ associate request-params union params set ] '[
[ action set ] bi* , ,
request get method>> { [ +path+ associate request-params union params set ]
{ "GET" [ handle-get ] } [ action set ] bi*
{ "HEAD" [ handle-get ] } request get method>> {
{ "POST" [ handle-post ] } { "GET" [ handle-get ] }
} case ; { "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 ! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: http.server.sessions accessors USING: http.server.sessions accessors
http.server.auth.providers ; http.server.auth.providers assocs namespaces kernel ;
IN: http.server.auth IN: http.server.auth
SYMBOL: logged-in-user 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>> ; : 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.templating.fhtml http.server.validators
http.server.auth http sequences io.files namespaces hashtables http.server.auth http sequences io.files namespaces hashtables
fry io.sockets combinators.cleave arrays threads locals fry io.sockets combinators.cleave arrays threads locals
qualified ; qualified continuations destructors ;
IN: http.server.auth.login IN: http.server.auth.login
QUALIFIED: smtp QUALIFIED: smtp
SYMBOL: post-login-url
SYMBOL: login-failed?
TUPLE: login users ; TUPLE: login users ;
: users login get users>> ; : users login get users>> ;
SYMBOL: post-login-url ! Destructor
SYMBOL: login-failed? 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 ! ! ! Login
@ -116,6 +129,8 @@ SYMBOL: user-exists?
] unless* ] unless*
successful-login successful-login
login get responder>> init-user-profile
] >>submit ] >>submit
] ; ] ;
@ -155,23 +170,21 @@ SYMBOL: previous-page
form validate-form form validate-form
logged-in-user sget
"password" value empty? [ "password" value empty? [
logged-in-user sget
] [
same-password-twice same-password-twice
"password" value uid users check-login "password" value uid users check-login
[ login-failed? on validation-failed ] unless [ login-failed? on validation-failed ] unless
"new-password" value uid users set-password "new-password" value set-password
[ "User deleted" throw ] unless* ] unless
] if
"realname" value >>realname "realname" value >>realname
"email" value >>email "email" value >>email
dup users update-user user-profile-changed? on
logged-in-user sset
previous-page sget f <permanent-redirect> previous-page sget f <permanent-redirect>
] >>submit ] >>submit
@ -330,6 +343,7 @@ C: <protected> protected
M: protected call-responder ( path responder -- response ) M: protected call-responder ( path responder -- response )
logged-in-user sget [ logged-in-user sget [
dup save-user-after
request get request-url previous-page sset request get request-url previous-page sset
responder>> call-responder 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 [ 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 [ 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 ] [ [ t ] [
<user> <user>
"slava" >>username "slava" >>username
"foobar" >>password "foobar" >>password
"slava@factorcode.org" >>email "slava@factorcode.org" >>email
"provider" get new-user "provider" get new-user
username>> "slava" = username>> "slava" =
] unit-test ] unit-test
[ f ] [ [ f ] [
<user> <user>
"slava" >>username "slava" >>username
"provider" get new-user "provider" get new-user
] unit-test ] unit-test
[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] 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 [ 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. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel new-slots accessors random math.parser locals USING: kernel new-slots accessors random math.parser locals
sequences math ; sequences math crypto.sha2 ;
IN: http.server.auth.providers IN: http.server.auth.providers
TUPLE: user username realname password email ticket profile ; 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 ) : check-login ( password username provider -- user/f )
get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ; get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;
:: set-password ( password username provider -- user/f ) : set-password ( user password -- user ) >>password ;
[let | user [ username provider get-user ] |
user [
user
password >>password
dup provider update-user
] [ f ] if
] ;
! Password recovery support ! 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 ; cont-id query-param swap callbacks>> at ;
M: callback-responder call-responder ( path responder -- response ) M: callback-responder call-responder ( path responder -- response )
[ callback-responder set ] '[
[ request get resuming-callback ] bi , ,
[ invoke-callback ] [ callback-responder set ]
[ callback-responder get responder>> call-responder ] ?if ; [ request get resuming-callback ] bi
[
invoke-callback
] [
callback-responder get responder>> call-responder
] ?if
] with-exit-continuation ;
: show-page ( quot -- ) : show-page ( quot -- )
>r redirect-to-here store-current-show r> >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 ; : exit-with exit-continuation get continue-with ;
: with-exit-continuation ( quot -- )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
: do-request ( request -- response ) : do-request ( request -- response )
'[ [
exit-continuation set , [ log-request ]
[ [ request set ]
[ log-request ] [ path>> main-responder get call-responder ] tri
[ request set ] [ <404> ] unless*
[ path>> main-responder get call-responder ] tri ] [
[ <404> ] unless* [ \ do-request log-error ]
] [ [ <500> ]
[ \ do-request log-error ] bi
[ <500> ] ] recover ;
bi
] recover
] callcc1
exit-continuation off ;
: default-timeout 1 minutes stdio get set-timeout ; : 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 IN: http.server.sessions.tests
USING: tools.test http http.server.sessions USING: tools.test http http.server.sessions
http.server.sessions.storage http.server.sessions.storage.assoc http.server.sessions.storage http.server.sessions.storage.assoc
http.server math namespaces kernel accessors prettyprint http.server.actions http.server math namespaces kernel accessors
io.streams.string splitting destructors ; prettyprint io.streams.string splitting destructors sequences ;
[ H{ } ] [ H{ } add-session-id ] unit-test [ H{ } ] [ H{ } add-session-id ] unit-test
@ -72,9 +72,9 @@ M: foo call-responder
: url-responder-mock-test : url-responder-mock-test
[ [
<request> <request>
"GET" >>method "GET" >>method
"id" get session-id-key set-query-param "id" get session-id-key set-query-param
"/" >>path "/" >>path
request set request set
"/" "manager" get call-responder "/" "manager" get call-responder
[ write-response-body drop ] with-string-writer [ write-response-body drop ] with-string-writer
@ -107,9 +107,9 @@ response set
: cookie-responder-mock-test : cookie-responder-mock-test
[ [
<request> <request>
"GET" >>method "GET" >>method
"cookies" get >>cookies "cookies" get >>cookies
"/" >>path "/" >>path
request set request set
"/" "manager" get call-responder "/" "manager" get call-responder
[ write-response-body drop ] with-string-writer [ write-response-body drop ] with-string-writer
@ -118,3 +118,28 @@ response set
[ "2" ] [ cookie-responder-mock-test ] unit-test [ "2" ] [ cookie-responder-mock-test ] unit-test
[ "3" ] [ cookie-responder-mock-test ] unit-test [ "3" ] [ cookie-responder-mock-test ] unit-test
[ "4" ] [ 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 -- ) GENERIC: init-session* ( responder -- )
M: dispatcher init-session* drop ; M: object init-session* drop ;
TUPLE: session-manager responder sessions ; TUPLE: session-manager responder sessions ;
@ -56,8 +56,11 @@ M: session-saver dispose
sessions update-session sessions update-session
] [ drop ] if ; ] [ drop ] if ;
: save-session-after ( id session -- )
<session-saver> add-always-destructor ;
: call-responder/session ( path responder id session -- response ) : call-responder/session ( path responder id session -- response )
[ <session-saver> add-always-destructor ] [ save-session-after ]
[ [ session-id set ] [ session set ] bi* ] 2bi [ [ session-id set ] [ session set ] bi* ] 2bi
[ session-manager set ] [ responder>> call-responder ] bi ; [ 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 session construct-empty
swap dup [ string>number ] when >>id ; swap dup [ string>number ] when >>id ;
USING: namespaces io prettyprint ;
M: sessions-in-db get-session ( id storage -- namespace/f ) M: sessions-in-db get-session ( id storage -- namespace/f )
global [ "get " write over print flush ] bind
drop drop
dup [ dup [
<session> <session>
select-tuple dup [ namespace>> ] when global [ dup . ] bind select-tuple dup [ namespace>> ] when
] when ; ] when ;
M: sessions-in-db update-session ( namespace id storage -- ) M: sessions-in-db update-session ( namespace id storage -- )
global [ "update " write over print flush ] bind
drop drop
<session> <session>
swap global [ dup . ] bind >>namespace swap >>namespace
dup update-tuple update-tuple ;
id>> <session> select-tuple global [ . flush ] bind
;
M: sessions-in-db delete-session ( id storage -- ) M: sessions-in-db delete-session ( id storage -- )
drop drop
@ -45,8 +40,7 @@ M: sessions-in-db delete-session ( id storage -- )
delete-tuple ; delete-tuple ;
M: sessions-in-db new-session ( namespace storage -- id ) M: sessions-in-db new-session ( namespace storage -- id )
global [ "new " print flush ] bind
drop drop
f <session> f <session>
swap global [ dup . ] bind >>namespace swap >>namespace
[ insert-tuple ] [ id>> number>string ] bi ; [ 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 ! 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' ! TODO: debug 'Memory protection fault at address 6c'
! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd ! 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 ! Enter PEM pass phrase: password
get-ctx "/extra/openssl/test/server.pem" resource-path [ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path
SSL_FILETYPE_PEM use-private-key SSL_FILETYPE_PEM use-private-key ] unit-test
get-ctx "/extra/openssl/test/root.pem" resource-path f [ ] [ get-ctx "/extra/openssl/test/root.pem" resource-path f
verify-load-locations verify-load-locations ] unit-test
get-ctx 1 set-verify-depth [ ] [ get-ctx 1 set-verify-depth ] unit-test
! ========================================================= ! =========================================================
! Load Diffie-Hellman parameters ! 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' ! 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) ! 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 ! 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' ! TODO: debug SSL_CTX_set_tmp_rsa 'No such symbol'
! get-ctx get-rsa set-tmp-rsa-callback ! get-ctx get-rsa set-tmp-rsa-callback
! Workaround (this function should never be called directly) ! 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 ! Listen and accept on socket
@ -129,11 +129,11 @@ get-rsa free-rsa
! Dump errors to file ! 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 [ 6 ] [ get-bio "Hello\n" bio-print ] unit-test
get-bio bio-free [ ] [ get-bio bio-free ] unit-test
! ========================================================= ! =========================================================
! Clean-up ! Clean-up

83
extra/reports/noise/noise.factor
View File

@ -1,7 +1,7 @@
USING: assocs math kernel shuffle combinators.lib USING: assocs math kernel shuffle combinators.lib
words quotations arrays combinators sequences math.vectors words quotations arrays combinators sequences math.vectors
io.styles combinators.cleave prettyprint vocabs sorting io io.styles combinators.cleave prettyprint vocabs sorting io
generic locals.private ; generic locals.private math.statistics ;
IN: reports.noise IN: reports.noise
: badness ( word -- n ) : badness ( word -- n )
@ -12,9 +12,9 @@ IN: reports.noise
{ 2apply 1 } { 2apply 1 }
{ 2curry 1 } { 2curry 1 }
{ 2drop 1 } { 2drop 1 }
{ 2dup 2 } { 2dup 1 }
{ 2keep 2 } { 2keep 1 }
{ 2nip 3 } { 2nip 2 }
{ 2over 4 } { 2over 4 }
{ 2slip 2 } { 2slip 2 }
{ 2swap 3 } { 2swap 3 }
@ -33,11 +33,19 @@ IN: reports.noise
{ 4dup 3 } { 4dup 3 }
{ 4slip 4 } { 4slip 4 }
{ compose 1/2 } { compose 1/2 }
{ curry 1/2 } { curry 1/3 }
{ dip 1 } { dip 1 }
{ dipd 2 } { dipd 2 }
{ drop 1/2 } { drop 1/3 }
{ dup 1/2 } { 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 } { keep 1 }
{ napply 2 } { napply 2 }
{ ncurry 3 } { ncurry 3 }
@ -62,11 +70,11 @@ IN: reports.noise
{ swap 1 } { swap 1 }
{ swapd 3 } { swapd 3 }
{ tuck 2 } { tuck 2 }
{ tuckd 3 } { tuckd 4 }
{ with 1 } { with 1/2 }
{ with* 2 } { with* 2 }
{ r> 1/2 } { r> 1 }
{ >r 1/2 } { >r 1 }
{ bi 1/2 } { bi 1/2 }
{ tri 1 } { tri 1 }
@ -93,14 +101,30 @@ M: lambda noise lambda-body noise ;
M: object noise drop { 0 0 } ; 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 ) : quot-noise-factor ( quot -- n )
#! For very short words, noise doesn't count so much #! For very short words, noise doesn't count so much
#! (so dup foo swap bar isn't penalized as badly). #! (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 ) GENERIC: word-noise-factor ( word -- factor )
@ -110,20 +134,41 @@ M: word word-noise-factor
M: lambda-word word-noise-factor M: lambda-word word-noise-factor
"lambda" word-prop quot-noise-factor ; "lambda" word-prop quot-noise-factor ;
: noisy-words ( -- alist ) : flatten-generics ( words -- words' )
all-words [ [
dup generic? [ methods values ] [ 1array ] if 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 ; sort-values reverse ;
: noisy-words. ( alist -- ) : noise. ( alist -- )
standard-table-style [ standard-table-style [
[ [
[ [ pprint-cell ] [ pprint-cell ] bi* ] with-row [ [ pprint-cell ] [ pprint-cell ] bi* ] with-row
] assoc-each ] assoc-each
] tabular-output ; ] 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 ( -- ) : 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 MAIN: noise-report

24
extra/tools/walker/walker.factor
View File

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