Working on HTTP server
Slava Pestov
parent
604a895f99
commit
d4be6ea98c
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue