Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
c4b5e783db
|
|
@ -98,26 +98,36 @@ H{ } clone class<map set
|
|||
H{ } clone update-map set
|
||||
|
||||
! Builtin classes
|
||||
: builtin-predicate ( class predicate -- )
|
||||
: builtin-predicate-quot ( class -- quot )
|
||||
[
|
||||
over "type" word-prop dup
|
||||
"type" word-prop dup
|
||||
\ tag-mask get < \ tag \ type ? , , \ eq? ,
|
||||
] [ ] make define-predicate* ;
|
||||
] [ ] make ;
|
||||
|
||||
: register-builtin ( class -- )
|
||||
dup "type" word-prop builtins get set-nth ;
|
||||
: define-builtin-predicate ( class -- )
|
||||
dup
|
||||
dup builtin-predicate-quot define-predicate
|
||||
predicate-word make-inline ;
|
||||
|
||||
: lookup-type-number ( word -- n )
|
||||
global [ target-word ] bind type-number ;
|
||||
|
||||
: define-builtin ( symbol predicate slotspec -- )
|
||||
>r dup make-inline >r
|
||||
dup dup lookup-type-number "type" set-word-prop
|
||||
: register-builtin ( class -- )
|
||||
dup
|
||||
dup lookup-type-number "type" set-word-prop
|
||||
dup "type" word-prop builtins get set-nth ;
|
||||
|
||||
: define-builtin-slots ( symbol slotspec -- )
|
||||
dupd 1 simple-slots
|
||||
2dup "slots" set-word-prop
|
||||
define-slots ;
|
||||
|
||||
: define-builtin ( symbol slotspec -- )
|
||||
>r
|
||||
dup register-builtin
|
||||
dup f f builtin-class define-class
|
||||
dup r> builtin-predicate
|
||||
dup r> 1 simple-slots 2dup "slots" set-word-prop
|
||||
dupd define-slots
|
||||
register-builtin ;
|
||||
dup define-builtin-predicate
|
||||
r> define-builtin-slots ;
|
||||
|
||||
H{ } clone typemap set
|
||||
num-types get f <array> builtins set
|
||||
|
|
@ -128,17 +138,15 @@ num-types get f <array> builtins set
|
|||
|
||||
"null" "kernel" create drop
|
||||
|
||||
"fixnum" "math" create "fixnum?" "math" create { } define-builtin
|
||||
"fixnum" "math" create { } define-builtin
|
||||
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
|
||||
|
||||
"bignum" "math" create "bignum?" "math" create { } define-builtin
|
||||
"bignum" "math" create { } define-builtin
|
||||
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
|
||||
|
||||
"tuple" "kernel" create "tuple?" "kernel" create
|
||||
{ } define-builtin
|
||||
"tuple" "kernel" create { } define-builtin
|
||||
|
||||
"ratio" "math" create "ratio?" "math" create
|
||||
{
|
||||
"ratio" "math" create {
|
||||
{
|
||||
{ "integer" "math" }
|
||||
"numerator"
|
||||
|
|
@ -153,11 +161,10 @@ num-types get f <array> builtins set
|
|||
}
|
||||
} define-builtin
|
||||
|
||||
"float" "math" create "float?" "math" create { } define-builtin
|
||||
"float" "math" create { } define-builtin
|
||||
"float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop
|
||||
|
||||
"complex" "math" create "complex?" "math" create
|
||||
{
|
||||
"complex" "math" create {
|
||||
{
|
||||
{ "real" "math" }
|
||||
"real-part"
|
||||
|
|
@ -172,14 +179,13 @@ num-types get f <array> builtins set
|
|||
}
|
||||
} define-builtin
|
||||
|
||||
"f" "syntax" lookup "not" "kernel" create
|
||||
{ } define-builtin
|
||||
"f" "syntax" lookup { } define-builtin
|
||||
|
||||
"array" "arrays" create "array?" "arrays" create
|
||||
{ } define-builtin
|
||||
! do not word...
|
||||
|
||||
"wrapper" "kernel" create "wrapper?" "kernel" create
|
||||
{
|
||||
"array" "arrays" create { } define-builtin
|
||||
|
||||
"wrapper" "kernel" create {
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
"wrapped"
|
||||
|
|
@ -188,8 +194,7 @@ num-types get f <array> builtins set
|
|||
}
|
||||
} define-builtin
|
||||
|
||||
"string" "strings" create "string?" "strings" create
|
||||
{
|
||||
"string" "strings" create {
|
||||
{
|
||||
{ "array-capacity" "sequences.private" }
|
||||
"length"
|
||||
|
|
@ -203,8 +208,7 @@ num-types get f <array> builtins set
|
|||
}
|
||||
} define-builtin
|
||||
|
||||
"quotation" "quotations" create "quotation?" "quotations" create
|
||||
{
|
||||
"quotation" "quotations" create {
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
"array"
|
||||
|
|
@ -219,8 +223,7 @@ num-types get f <array> builtins set
|
|||
}
|
||||
} define-builtin
|
||||
|
||||
"dll" "alien" create "dll?" "alien" create
|
||||
{
|
||||
"dll" "alien" create {
|
||||
{
|
||||
{ "byte-array" "byte-arrays" }
|
||||
"path"
|
||||
|
|
@ -230,8 +233,7 @@ num-types get f <array> builtins set
|
|||
}
|
||||
define-builtin
|
||||
|
||||
"alien" "alien" create "alien?" "alien" create
|
||||
{
|
||||
"alien" "alien" create {
|
||||
{
|
||||
{ "c-ptr" "alien" }
|
||||
"alien"
|
||||
|
|
@ -246,8 +248,7 @@ define-builtin
|
|||
}
|
||||
define-builtin
|
||||
|
||||
"word" "words" create "word?" "words" create
|
||||
{
|
||||
"word" "words" create {
|
||||
f
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
|
|
@ -287,20 +288,13 @@ define-builtin
|
|||
}
|
||||
} define-builtin
|
||||
|
||||
"byte-array" "byte-arrays" create
|
||||
"byte-array?" "byte-arrays" create
|
||||
{ } define-builtin
|
||||
"byte-array" "byte-arrays" create { } define-builtin
|
||||
|
||||
"bit-array" "bit-arrays" create
|
||||
"bit-array?" "bit-arrays" create
|
||||
{ } define-builtin
|
||||
"bit-array" "bit-arrays" create { } define-builtin
|
||||
|
||||
"float-array" "float-arrays" create
|
||||
"float-array?" "float-arrays" create
|
||||
{ } define-builtin
|
||||
"float-array" "float-arrays" create { } define-builtin
|
||||
|
||||
"callstack" "kernel" create "callstack?" "kernel" create
|
||||
{ } define-builtin
|
||||
"callstack" "kernel" create { } define-builtin
|
||||
|
||||
! Define general-t type, which is any object that is not f.
|
||||
"general-t" "kernel" create
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ IN: builder.benchmark
|
|||
[ benchmark-difference ] with map ;
|
||||
|
||||
: benchmark-deltas ( -- table )
|
||||
"../../benchmarks" "../benchmarks" [ eval-file ] 2apply
|
||||
"../benchmarks" "benchmarks" [ eval-file ] 2apply
|
||||
compare-tables
|
||||
sort-values ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@ USING: kernel namespaces sequences splitting system combinators continuations
|
|||
bootstrap.image benchmark vars bake smtp builder.util accessors
|
||||
io.encodings.utf8
|
||||
calendar
|
||||
tools.test
|
||||
builder.common
|
||||
builder.benchmark
|
||||
builder.release ;
|
||||
|
|
@ -131,7 +132,10 @@ SYMBOL: build-status
|
|||
"Test time: " write "test-time" eval-file milli-seconds>time print nl
|
||||
|
||||
"Did not pass load-everything: " print "load-everything-vocabs" cat
|
||||
|
||||
"Did not pass test-all: " print "test-all-vocabs" cat
|
||||
"test-all-vocabs" eval-file test-failures.
|
||||
|
||||
"help-lint results:" print "help-lint" cat
|
||||
|
||||
"Benchmarks: " print "benchmarks" eval-file benchmarks.
|
||||
|
|
|
|||
|
|
@ -16,18 +16,18 @@ IN: builder.test
|
|||
: do-load ( -- )
|
||||
try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ;
|
||||
|
||||
! : do-tests ( -- )
|
||||
! run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ;
|
||||
|
||||
: do-tests ( -- )
|
||||
run-all-tests
|
||||
"../test-all-vocabs" utf8
|
||||
[
|
||||
[ keys . ]
|
||||
[ test-failures. ]
|
||||
bi
|
||||
]
|
||||
with-file-writer ;
|
||||
run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ;
|
||||
|
||||
! : do-tests ( -- )
|
||||
! run-all-tests
|
||||
! "../test-all-vocabs" utf8
|
||||
! [
|
||||
! [ keys . ]
|
||||
! [ test-failures. ]
|
||||
! bi
|
||||
! ]
|
||||
! with-file-writer ;
|
||||
|
||||
: do-help-lint ( -- )
|
||||
"" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ;
|
||||
|
|
|
|||
|
|
@ -7,10 +7,18 @@ IN: combinators.cleave
|
|||
|
||||
ARTICLE: "cleave-combinators" "Cleave Combinators"
|
||||
|
||||
"Basic cleavers:"
|
||||
|
||||
{ $subsection bi }
|
||||
{ $subsection tri }
|
||||
|
||||
"General cleave: "
|
||||
{ $subsection cleave }
|
||||
|
||||
"Cleave combinators for quotations with arity 2:"
|
||||
{ $subsection 2bi }
|
||||
{ $subsection 2tri }
|
||||
|
||||
{ $notes
|
||||
"From the Merriam-Webster Dictionary: "
|
||||
$nl
|
||||
|
|
@ -56,6 +64,10 @@ HELP: cleave
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
{ bi tri cleave 2bi 2tri } related-words
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
ARTICLE: "spread-combinators" "Spread Combinators"
|
||||
|
||||
{ $subsection bi* }
|
||||
|
|
|
|||
|
|
@ -199,7 +199,7 @@ ARTICLE: "cookbook-io" "Input and output cookbook"
|
|||
}
|
||||
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
|
||||
{ $code
|
||||
"\"mydata.dat\" dup file-length ["
|
||||
"\"mydata.dat\" dup file-info file-info-length ["
|
||||
" 4 <sliced-groups> [ reverse-here ] change-each"
|
||||
"] with-mapped-file"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -95,5 +95,4 @@ PRIVATE>
|
|||
swap >>post-data-type ;
|
||||
|
||||
: http-post ( content-type content url -- response string )
|
||||
#! The content is URL encoded for you.
|
||||
>r url-encode r> <post-request> http-request contents ;
|
||||
<post-request> http-request contents ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@ USING: fry hashtables io io.streams.string kernel math
|
|||
namespaces math.parser assocs sequences strings splitting ascii
|
||||
io.encodings.utf8 io.encodings.string namespaces unicode.case
|
||||
combinators vectors sorting new-slots accessors calendar
|
||||
calendar.format quotations arrays ;
|
||||
calendar.format quotations arrays combinators.cleave
|
||||
combinators.lib byte-arrays ;
|
||||
IN: http
|
||||
|
||||
: http-port 80 ; inline
|
||||
|
|
@ -12,18 +13,21 @@ IN: http
|
|||
: url-quotable? ( ch -- ? )
|
||||
#! In a URL, can this character be used without
|
||||
#! URL-encoding?
|
||||
dup letter?
|
||||
over LETTER? or
|
||||
over digit? or
|
||||
swap "/_-." member? or ; foldable
|
||||
{
|
||||
[ dup letter? ]
|
||||
[ dup LETTER? ]
|
||||
[ dup digit? ]
|
||||
[ dup "/_-.:" member? ]
|
||||
} || nip ; foldable
|
||||
|
||||
: push-utf8 ( ch -- )
|
||||
1string utf8 encode [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
|
||||
1string utf8 encode
|
||||
[ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
|
||||
|
||||
: url-encode ( str -- str )
|
||||
[ [
|
||||
dup url-quotable? [ , ] [ push-utf8 ] if
|
||||
] each ] "" make ;
|
||||
[
|
||||
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
|
||||
] "" make ;
|
||||
|
||||
: url-decode-hex ( index str -- )
|
||||
2dup length 2 - >= [
|
||||
|
|
@ -108,7 +112,12 @@ IN: http
|
|||
] when ;
|
||||
|
||||
: assoc>query ( hash -- str )
|
||||
[ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
|
||||
[
|
||||
[ url-encode ]
|
||||
[ dup number? [ number>string ] when url-encode ]
|
||||
bi*
|
||||
"=" swap 3append
|
||||
] { } assoc>map
|
||||
"&" join ;
|
||||
|
||||
TUPLE: cookie name value path domain expires http-only ;
|
||||
|
|
@ -169,10 +178,10 @@ cookies ;
|
|||
|
||||
: <request>
|
||||
request construct-empty
|
||||
"1.1" >>version
|
||||
http-port >>port
|
||||
H{ } clone >>query
|
||||
V{ } clone >>cookies ;
|
||||
"1.1" >>version
|
||||
http-port >>port
|
||||
H{ } clone >>query
|
||||
V{ } clone >>cookies ;
|
||||
|
||||
: query-param ( request key -- value )
|
||||
swap query>> at ;
|
||||
|
|
@ -245,6 +254,10 @@ SYMBOL: max-post-request
|
|||
: extract-post-data-type ( request -- request )
|
||||
dup "content-type" header >>post-data-type ;
|
||||
|
||||
: parse-post-data ( request -- request )
|
||||
dup post-data-type>> "application/x-www-form-urlencoded" =
|
||||
[ dup post-data>> query>assoc >>post-data ] when ;
|
||||
|
||||
: extract-cookies ( request -- request )
|
||||
dup "cookie" header [ parse-cookies >>cookies ] when* ;
|
||||
|
||||
|
|
@ -257,24 +270,31 @@ SYMBOL: max-post-request
|
|||
read-post-data
|
||||
extract-host
|
||||
extract-post-data-type
|
||||
parse-post-data
|
||||
extract-cookies ;
|
||||
|
||||
: write-method ( request -- request )
|
||||
dup method>> write bl ;
|
||||
|
||||
: write-url ( request -- request )
|
||||
dup path>> url-encode write
|
||||
dup query>> dup assoc-empty? [ drop ] [
|
||||
"?" write
|
||||
assoc>query write
|
||||
] if ;
|
||||
: (link>string) ( url query -- url' )
|
||||
[ url-encode ] [ assoc>query ] bi*
|
||||
dup empty? [ drop ] [ "?" swap 3append ] if ;
|
||||
|
||||
: write-url ( request -- )
|
||||
[ path>> ] [ query>> ] bi (link>string) write ;
|
||||
|
||||
: write-request-url ( request -- request )
|
||||
write-url bl ;
|
||||
dup write-url bl ;
|
||||
|
||||
: write-version ( request -- request )
|
||||
"HTTP/" write dup request-version write crlf ;
|
||||
|
||||
: unparse-post-data ( request -- request )
|
||||
dup post-data>> dup sequence? [ drop ] [
|
||||
assoc>query >>post-data
|
||||
"application/x-www-form-urlencoded" >>post-data-type
|
||||
] if ;
|
||||
|
||||
: write-request-header ( request -- request )
|
||||
dup header>> >hashtable
|
||||
over host>> [ "host" pick set-at ] when*
|
||||
|
|
@ -287,6 +307,7 @@ SYMBOL: max-post-request
|
|||
dup post-data>> [ write ] when* ;
|
||||
|
||||
: write-request ( request -- )
|
||||
unparse-post-data
|
||||
write-method
|
||||
write-request-url
|
||||
write-version
|
||||
|
|
@ -297,15 +318,16 @@ SYMBOL: max-post-request
|
|||
|
||||
: request-url ( request -- url )
|
||||
[
|
||||
dup host>> [
|
||||
"http://" write
|
||||
dup host>> url-encode write
|
||||
":" write
|
||||
dup port>> number>string write
|
||||
] when
|
||||
dup path>> "/" head? [ "/" write ] unless
|
||||
write-url
|
||||
drop
|
||||
[
|
||||
dup host>> [
|
||||
[ "http://" write host>> url-encode write ]
|
||||
[ ":" write port>> number>string write ]
|
||||
bi
|
||||
] [ drop ] if
|
||||
]
|
||||
[ path>> "/" head? [ "/" write ] unless ]
|
||||
[ write-url ]
|
||||
tri
|
||||
] with-string-writer ;
|
||||
|
||||
: set-header ( request/response value key -- request/response )
|
||||
|
|
|
|||
|
|
@ -29,6 +29,7 @@ blah
|
|||
STRING: action-request-test-2
|
||||
POST http://foo/bar/baz HTTP/1.1
|
||||
content-length: 5
|
||||
content-type: application/x-www-form-urlencoded
|
||||
|
||||
xxx=4
|
||||
;
|
||||
|
|
|
|||
|
|
@ -17,14 +17,6 @@ TUPLE: action init display submit get-params post-params ;
|
|||
[ <400> ] >>display
|
||||
[ <400> ] >>submit ;
|
||||
|
||||
: extract-params ( path -- assoc )
|
||||
+path+ associate
|
||||
request get dup method>> {
|
||||
{ "GET" [ query>> ] }
|
||||
{ "HEAD" [ query>> ] }
|
||||
{ "POST" [ post-data>> query>assoc ] }
|
||||
} case union ;
|
||||
|
||||
: with-validator ( string quot -- result error? )
|
||||
'[ , @ f ] [
|
||||
dup validation-error? [ t ] [ rethrow ] if
|
||||
|
|
@ -50,12 +42,10 @@ TUPLE: action init display submit get-params post-params ;
|
|||
action get display>> call exit-with ;
|
||||
|
||||
M: action call-responder ( path action -- response )
|
||||
[ extract-params params set ]
|
||||
[
|
||||
action set
|
||||
request get method>> {
|
||||
{ "GET" [ handle-get ] }
|
||||
{ "HEAD" [ handle-get ] }
|
||||
{ "POST" [ handle-post ] }
|
||||
} case
|
||||
] bi* ;
|
||||
[ +path+ associate request-params union params set ]
|
||||
[ action set ] bi*
|
||||
request get method>> {
|
||||
{ "GET" [ handle-get ] }
|
||||
{ "HEAD" [ handle-get ] }
|
||||
{ "POST" [ handle-post ] }
|
||||
} case ;
|
||||
|
|
|
|||
|
|
@ -30,7 +30,8 @@ SYMBOL: login-failed?
|
|||
|
||||
: successful-login ( user -- response )
|
||||
logged-in-user sset
|
||||
post-login-url sget f <permanent-redirect> ;
|
||||
post-login-url sget "" or f <permanent-redirect>
|
||||
f post-login-url sset ;
|
||||
|
||||
:: <login-action> ( -- action )
|
||||
[let | form [ <login-form> ] |
|
||||
|
|
|
|||
|
|
@ -1,10 +1,13 @@
|
|||
<% USING: http.server.auth.login http.server.components kernel
|
||||
namespaces ; %>
|
||||
<% USING: http.server.auth.login http.server.components http.server
|
||||
kernel namespaces ; %>
|
||||
<html>
|
||||
<body>
|
||||
<h1>Login required</h1>
|
||||
|
||||
<form method="POST" action="login">
|
||||
|
||||
<% hidden-form-field %>
|
||||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
|
|
@ -30,10 +33,12 @@ login-failed? get
|
|||
|
||||
<p>
|
||||
<% allow-registration? [ %>
|
||||
<a href="register">Register</a>
|
||||
<a href="<% "register" f write-link %>">Register</a>
|
||||
<% ] when %>
|
||||
<% allow-password-recovery? [ %>
|
||||
<a href="recover-password">Recover Password</a>
|
||||
<a href="<% "recover-password" f write-link %>">
|
||||
Recover Password
|
||||
</a>
|
||||
<% ] when %>
|
||||
</p>
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
<% USING: http.server.components ; %>
|
||||
<% USING: http.server.components http.server ; %>
|
||||
<html>
|
||||
<body>
|
||||
<h1>Recover lost password: step 1 of 4</h1>
|
||||
|
|
@ -6,6 +6,9 @@
|
|||
<p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
|
||||
|
||||
<form method="POST" action="recover-password">
|
||||
|
||||
<% hidden-form-field %>
|
||||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
<% USING: http.server.components http.server.auth.login
|
||||
<% USING: http.server.components http.server.auth.login http.server
|
||||
namespaces kernel combinators ; %>
|
||||
<html>
|
||||
<body>
|
||||
|
|
@ -7,6 +7,9 @@ namespaces kernel combinators ; %>
|
|||
<p>Choose a new password for your account.</p>
|
||||
|
||||
<form method="POST" action="new-password">
|
||||
|
||||
<% hidden-form-field %>
|
||||
|
||||
<table>
|
||||
|
||||
<% "username" component render-edit %>
|
||||
|
|
@ -32,7 +35,7 @@ namespaces kernel combinators ; %>
|
|||
<p><input type="submit" value="Set password" />
|
||||
|
||||
<% password-mismatch? get [
|
||||
"passwords do not match" render-error
|
||||
"passwords do not match" render-error
|
||||
] when %>
|
||||
|
||||
</p>
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
<% USING: http.server.components http.server.auth.login
|
||||
namespaces kernel combinators ; %>
|
||||
<% USING: http.server ; %>
|
||||
<html>
|
||||
<body>
|
||||
<h1>Recover lost password: step 4 of 4</h1>
|
||||
|
||||
<p>Your password has been reset. You may now <a href="login">log in</a>.</p>
|
||||
<p>Your password has been reset.
|
||||
You may now <a href="<% "login" f write-link %>">log in</a>.</p>
|
||||
|
||||
</body>
|
||||
</html>
|
||||
|
|
|
|||
|
|
@ -1,10 +1,12 @@
|
|||
<% USING: http.server.components http.server.auth.login
|
||||
namespaces kernel combinators ; %>
|
||||
http.server namespaces kernel combinators ; %>
|
||||
<html>
|
||||
<body>
|
||||
<h1>New user registration</h1>
|
||||
|
||||
<form method="POST" action="register">
|
||||
<% hidden-form-field %>
|
||||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
|
|
|
|||
|
|
@ -14,9 +14,7 @@ user "USERS"
|
|||
{ "profile" "PROFILE" FACTOR-BLOB }
|
||||
} define-persistent
|
||||
|
||||
: init-users-table ( -- )
|
||||
[ user drop-table ] ignore-errors
|
||||
user create-table ;
|
||||
: init-users-table user ensure-table ;
|
||||
|
||||
TUPLE: from-db ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,6 +9,13 @@ IN: http.server
|
|||
|
||||
GENERIC: call-responder ( path responder -- response )
|
||||
|
||||
: request-params ( -- assoc )
|
||||
request get dup method>> {
|
||||
{ "GET" [ query>> ] }
|
||||
{ "HEAD" [ query>> ] }
|
||||
{ "POST" [ post-data>> ] }
|
||||
} case ;
|
||||
|
||||
: <content> ( content-type -- response )
|
||||
<response>
|
||||
200 >>code
|
||||
|
|
@ -45,19 +52,27 @@ SYMBOL: 404-responder
|
|||
|
||||
[ <404> ] <trivial-responder> 404-responder set-global
|
||||
|
||||
: url-redirect ( to query -- url )
|
||||
#! Different host.
|
||||
dup assoc-empty? [
|
||||
drop
|
||||
] [
|
||||
assoc>query "?" swap 3append
|
||||
] if ;
|
||||
SYMBOL: link-hook
|
||||
|
||||
: modify-query ( query -- query )
|
||||
link-hook get [ ] or call ;
|
||||
|
||||
: link>string ( url query -- url' )
|
||||
modify-query (link>string) ;
|
||||
|
||||
: write-link ( url query -- )
|
||||
link>string write ;
|
||||
|
||||
SYMBOL: form-hook
|
||||
|
||||
: hidden-form-field ( -- )
|
||||
form-hook get [ ] or call ;
|
||||
|
||||
: absolute-redirect ( to query -- url )
|
||||
#! Same host.
|
||||
request get clone
|
||||
swap [ >>query ] when*
|
||||
swap >>path
|
||||
swap url-encode >>path
|
||||
request-url ;
|
||||
|
||||
: replace-last-component ( path with -- path' )
|
||||
|
|
@ -67,11 +82,12 @@ SYMBOL: 404-responder
|
|||
request get clone
|
||||
swap [ >>query ] when*
|
||||
swap [ '[ , replace-last-component ] change-path ] when*
|
||||
dup query>> modify-query >>query
|
||||
request-url ;
|
||||
|
||||
: derive-url ( to query -- url )
|
||||
{
|
||||
{ [ over "http://" head? ] [ url-redirect ] }
|
||||
{ [ over "http://" head? ] [ link>string ] }
|
||||
{ [ over "/" head? ] [ absolute-redirect ] }
|
||||
{ [ t ] [ relative-redirect ] }
|
||||
} cond ;
|
||||
|
|
|
|||
|
|
@ -2,6 +2,8 @@ IN: http.server.sessions.tests
|
|||
USING: tools.test http.server.sessions math namespaces
|
||||
kernel accessors ;
|
||||
|
||||
[ H{ } ] [ H{ } add-session-id ] unit-test
|
||||
|
||||
: with-session \ session swap with-variable ; inline
|
||||
|
||||
TUPLE: foo ;
|
||||
|
|
@ -10,7 +12,9 @@ C: <foo> foo
|
|||
|
||||
M: foo init-session* drop 0 "x" sset ;
|
||||
|
||||
f <session> [
|
||||
f <session> "123" >>id [
|
||||
[ H{ { "factorsessid" "123" } } ] [ H{ } add-session-id ] unit-test
|
||||
|
||||
[ ] [ 3 "x" sset ] unit-test
|
||||
|
||||
[ 9 ] [ "x" sget sq ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs calendar kernel math.parser namespaces random
|
||||
boxes alarms new-slots accessors http http.server
|
||||
quotations hashtables sequences fry combinators.cleave ;
|
||||
quotations hashtables sequences fry combinators.cleave
|
||||
html.elements ;
|
||||
IN: http.server.sessions
|
||||
|
||||
! ! ! ! ! !
|
||||
|
|
@ -67,12 +68,6 @@ TUPLE: session manager id namespace alarm ;
|
|||
: sessions ( -- manager/f )
|
||||
\ session get dup [ manager>> ] when ;
|
||||
|
||||
GENERIC: session-link* ( url query sessions -- string )
|
||||
|
||||
M: object session-link* 2drop url-encode ;
|
||||
|
||||
: session-link ( url query -- string ) sessions session-link* ;
|
||||
|
||||
TUPLE: null-sessions ;
|
||||
|
||||
: <null-sessions>
|
||||
|
|
@ -88,23 +83,30 @@ TUPLE: url-sessions ;
|
|||
|
||||
: sess-id "factorsessid" ;
|
||||
|
||||
: current-session ( responder request -- session )
|
||||
sess-id query-param swap get-session ;
|
||||
: current-session ( responder -- session )
|
||||
>r request-params sess-id swap at r> get-session ;
|
||||
|
||||
: add-session-id ( query -- query' )
|
||||
\ session get [ id>> sess-id associate union ] when* ;
|
||||
|
||||
: session-form-field ( -- )
|
||||
<input
|
||||
"hidden" =type
|
||||
sess-id =id
|
||||
sess-id =name
|
||||
\ session get id>> =value
|
||||
input/> ;
|
||||
|
||||
M: url-sessions call-responder ( path responder -- response )
|
||||
dup request get current-session [
|
||||
[ add-session-id ] link-hook set
|
||||
[ session-form-field ] form-hook set
|
||||
dup current-session [
|
||||
call-responder/session
|
||||
] [
|
||||
nip
|
||||
f swap new-session sess-id associate <temporary-redirect>
|
||||
] if* ;
|
||||
|
||||
M: url-sessions session-link*
|
||||
drop
|
||||
url-encode
|
||||
\ session get id>> sess-id associate union assoc>query
|
||||
dup assoc-empty? [ drop ] [ "?" swap 3append ] if ;
|
||||
|
||||
TUPLE: cookie-sessions ;
|
||||
|
||||
: <cookie-sessions> ( responder -- responder' )
|
||||
|
|
|
|||
|
|
@ -10,12 +10,8 @@ IN: http.server.static
|
|||
! special maps mime types to quots with effect ( path -- )
|
||||
TUPLE: file-responder root hook special ;
|
||||
|
||||
: unix-time>timestamp ( n -- timestamp )
|
||||
>r unix-1970 r> seconds time+ ;
|
||||
|
||||
: file-http-date ( filename -- string )
|
||||
file-info file-info-modified
|
||||
unix-time>timestamp timestamp>http-string ;
|
||||
file-info file-info-modified timestamp>http-string ;
|
||||
|
||||
: last-modified-matches? ( filename -- ? )
|
||||
file-http-date dup [
|
||||
|
|
|
|||
|
|
@ -0,0 +1,9 @@
|
|||
USING: io.encodings.string io.encodings.ascii tools.test strings arrays ;
|
||||
IN: io.encodings.ascii.tests
|
||||
|
||||
[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" ascii encode ] unit-test
|
||||
[ { 128 } >string ascii encode ] must-fail
|
||||
[ B{ 127 } ] [ { 127 } ascii encode ] unit-test
|
||||
|
||||
[ "bar" ] [ "bar" ascii decode ] unit-test
|
||||
[ { CHAR: b HEX: fffd CHAR: r } ] [ { CHAR: b 233 CHAR: r } ascii decode >array ] unit-test
|
||||
|
|
@ -3,13 +3,16 @@
|
|||
USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ;
|
||||
IN: io.encodings.ascii
|
||||
|
||||
: encode-check<= ( string stream max -- )
|
||||
: encode-check< ( string stream max -- )
|
||||
[ pick <= [ encode-error ] [ stream-write1 ] if ] 2curry each ;
|
||||
|
||||
: push-if< ( sbuf character max -- )
|
||||
over <= [ drop HEX: fffd ] when swap push ;
|
||||
|
||||
TUPLE: ascii ;
|
||||
|
||||
M: ascii stream-write-encoded ( string stream encoding -- )
|
||||
drop 128 encode-check<= ;
|
||||
drop 128 encode-check< ;
|
||||
|
||||
M: ascii decode-step
|
||||
drop dup 128 >= [ decode-error ] [ swap push ] if ;
|
||||
drop 128 push-if< ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,9 @@
|
|||
USING: io.encodings.string io.encodings.latin1 tools.test strings arrays ;
|
||||
IN: io.encodings.latin1.tests
|
||||
|
||||
[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test
|
||||
[ { 256 } >string latin1 encode ] must-fail
|
||||
[ B{ 255 } ] [ { 255 } latin1 encode ] unit-test
|
||||
|
||||
[ "bar" ] [ "bar" latin1 decode ] unit-test
|
||||
[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test
|
||||
|
|
@ -6,7 +6,7 @@ IN: io.encodings.latin1
|
|||
TUPLE: latin1 ;
|
||||
|
||||
M: latin1 stream-write-encoded
|
||||
drop 256 encode-check<= ;
|
||||
drop 256 encode-check< ;
|
||||
|
||||
M: latin1 decode-step
|
||||
drop swap push ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: io.mmap.tests
|
|||
|
||||
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
|
||||
[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test
|
||||
[ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
|
||||
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test
|
||||
[ ] [ "mmap-test-file.txt" resource-path dup file-info file-info-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
|
||||
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ length ] with-mapped-file ] unit-test
|
||||
[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test
|
||||
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
|
||||
|
|
|
|||
|
|
@ -1,15 +1,15 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.backend io.nonblocking io.unix.backend io.files io
|
||||
unix unix.stat unix.time kernel math continuations math.bitfields
|
||||
byte-arrays alien combinators combinators.cleave calendar
|
||||
io.encodings.binary ;
|
||||
unix unix.stat unix.time kernel math continuations
|
||||
math.bitfields byte-arrays alien combinators combinators.cleave
|
||||
calendar io.encodings.binary ;
|
||||
|
||||
IN: io.unix.files
|
||||
|
||||
M: unix-io cwd
|
||||
MAXPATHLEN dup <byte-array> swap
|
||||
getcwd [ (io-error) ] unless* ;
|
||||
MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
|
||||
[ (io-error) ] unless* ;
|
||||
|
||||
M: unix-io cd
|
||||
chdir io-error ;
|
||||
|
|
@ -68,7 +68,9 @@ M: unix-io delete-directory ( path -- )
|
|||
] with-disposal ;
|
||||
|
||||
M: unix-io copy-file ( from to -- )
|
||||
[ (copy-file) ] 2keep swap file-info file-info-permissions io-error ;
|
||||
[ (copy-file) ]
|
||||
[ swap file-info file-info-permissions chmod io-error ]
|
||||
2bi ;
|
||||
|
||||
: stat>type ( stat -- type )
|
||||
stat-st_mode {
|
||||
|
|
@ -82,8 +84,8 @@ M: unix-io copy-file ( from to -- )
|
|||
{ [ t ] [ +unknown+ ] }
|
||||
} cond nip ;
|
||||
|
||||
M: unix-io file-info ( path -- info )
|
||||
stat* {
|
||||
: stat>file-info ( stat -- info )
|
||||
{
|
||||
[ stat>type ]
|
||||
[ stat-st_size ]
|
||||
[ stat-st_mode ]
|
||||
|
|
@ -91,11 +93,8 @@ M: unix-io file-info ( path -- info )
|
|||
} cleave
|
||||
\ file-info construct-boa ;
|
||||
|
||||
M: unix-io file-info ( path -- info )
|
||||
stat* stat>file-info ;
|
||||
|
||||
M: unix-io link-info ( path -- info )
|
||||
lstat* {
|
||||
[ stat>type ]
|
||||
[ stat-st_size ]
|
||||
[ stat-st_mode ]
|
||||
[ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
|
||||
} cleave
|
||||
\ file-info construct-boa ;
|
||||
lstat* stat>file-info ;
|
||||
|
|
|
|||
|
|
@ -76,7 +76,7 @@ M: win32-file close-handle ( handle -- )
|
|||
] when drop ;
|
||||
|
||||
: open-append ( path -- handle length )
|
||||
dup file-length dup [
|
||||
dup file-info file-info-size dup [
|
||||
>r (open-append) r> 2dup set-file-pointer
|
||||
] [
|
||||
drop open-write
|
||||
|
|
|
|||
|
|
@ -12,25 +12,25 @@ tools.deploy.backend math sequences io.launcher ;
|
|||
[ ] [ "hello-world" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [
|
||||
"hello.image" temp-file file-length 500000 <=
|
||||
"hello.image" temp-file file-info file-info-size 500000 <=
|
||||
] unit-test
|
||||
|
||||
[ ] [ "sudoku" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [
|
||||
"hello.image" temp-file file-length 1500000 <=
|
||||
"hello.image" temp-file file-info file-info-size 1500000 <=
|
||||
] unit-test
|
||||
|
||||
[ ] [ "hello-ui" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [
|
||||
"hello.image" temp-file file-length 2000000 <=
|
||||
"hello.image" temp-file file-info file-info-size 2000000 <=
|
||||
] unit-test
|
||||
|
||||
[ ] [ "bunny" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [
|
||||
"hello.image" temp-file file-length 3000000 <=
|
||||
"hello.image" temp-file file-info file-info-size 3000000 <=
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
|
|
|||
Loading…
Reference in New Issue