native factor httpd
Slava Pestov
parent
cda61358bf
commit
ac1855bc15
|
|
@ -26,7 +26,6 @@
|
|||
|
||||
+ tests:
|
||||
|
||||
- finish split
|
||||
- java factor: equal numbers have non-equal hashcodes!
|
||||
- sbuf=
|
||||
- vector-hashcode
|
||||
|
|
@ -89,6 +88,9 @@ ERROR: I/O error: [ "primitive_read_line_fd_8" "Resource temporarily unavailable
|
|||
|
||||
+ httpd:
|
||||
|
||||
- multitasking
|
||||
- don't die if one client errors
|
||||
- inspect: always use inspect/ URL prefix, not responder name var
|
||||
- httpd: don't flush so much
|
||||
- log with date
|
||||
- log user agent
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@ USE: vectors
|
|||
namestack "error-namestack" set
|
||||
catchstack "error-catchstack" set
|
||||
] bind
|
||||
] when* ;
|
||||
] when ;
|
||||
|
||||
: catch ( try catch -- )
|
||||
#! Call the try quotation. If an error occurs restore the
|
||||
|
|
|
|||
|
|
@ -53,17 +53,17 @@ USE: wiki-responder
|
|||
"quit" "responder" set
|
||||
[ quit-responder ] "get" set
|
||||
] extend "quit" set
|
||||
|
||||
<responder> [
|
||||
"file" "responder" set
|
||||
[ file-responder ] "get" set
|
||||
] extend "file" set
|
||||
|
||||
<responder> [
|
||||
"wiki" "responder" set
|
||||
[ wiki-get-responder ] "get" set
|
||||
[ wiki-post-responder ] "post" set
|
||||
<namespace> "wiki" set
|
||||
"WikiHome" "default-argument" set
|
||||
] extend "wiki" set
|
||||
!
|
||||
! <responder> [
|
||||
! "file" "responder" set
|
||||
! [ file-responder ] "get" set
|
||||
! ] extend "file" set
|
||||
!
|
||||
! <responder> [
|
||||
! "wiki" "responder" set
|
||||
! [ wiki-get-responder ] "get" set
|
||||
! [ wiki-post-responder ] "post" set
|
||||
! <namespace> "wiki" set
|
||||
! "WikiHome" "default-argument" set
|
||||
! ] extend "wiki" set
|
||||
] extend "httpd-responders" set ;
|
||||
|
|
|
|||
|
|
@ -122,7 +122,9 @@ USE: url-encoding
|
|||
] extend ;
|
||||
|
||||
: with-html-stream ( quot -- )
|
||||
"stdio" get <html-stream> swap with-stream ;
|
||||
[
|
||||
"stdio" get <html-stream> "stdio" set call
|
||||
] with-scope ;
|
||||
|
||||
: html-head ( title -- )
|
||||
"<html><head><title>" write
|
||||
|
|
|
|||
|
|
@ -26,7 +26,6 @@
|
|||
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
IN: quit-responder
|
||||
USE: combinators
|
||||
USE: namespaces
|
||||
USE: stdio
|
||||
USE: stack
|
||||
|
|
|
|||
|
|
@ -26,13 +26,13 @@
|
|||
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
IN: test-responder
|
||||
USE: stdio
|
||||
USE: prettyprint
|
||||
|
||||
USE: html
|
||||
USE: httpd
|
||||
USE: httpd-responder
|
||||
USE: stack
|
||||
USE: test
|
||||
|
||||
: test-responder ( argument -- )
|
||||
serving-text
|
||||
"This is the test responder." print
|
||||
"Argument is " write . ;
|
||||
drop
|
||||
serving-html
|
||||
"Factor Test Suite" [ all-tests ] simple-html-document ;
|
||||
|
|
|
|||
|
|
@ -133,7 +133,11 @@ USE: vocabularies
|
|||
[ "top-level-continuation" set ] callcc0 ;
|
||||
|
||||
: (word-of-the-day) ( -- word )
|
||||
vocabs random-element words random-element ;
|
||||
vocabs random-element words dup [
|
||||
random-element
|
||||
] [
|
||||
drop (word-of-the-day) ( empty vocab )
|
||||
] ifte ;
|
||||
|
||||
: word-of-the-day ( -- )
|
||||
#! Something to entertain the poor hacker.
|
||||
|
|
|
|||
|
|
@ -100,5 +100,5 @@ USE: vocabularies
|
|||
: describe-object-path ( string -- )
|
||||
[
|
||||
dup "object-path" set
|
||||
global-object-path describe
|
||||
"'" split global [ object-path ] bind describe
|
||||
] with-scope ;
|
||||
|
|
|
|||
|
|
@ -121,10 +121,6 @@ USE: vectors
|
|||
#! Returns f if any of the objects are not set.
|
||||
this swap object-path-iter ;
|
||||
|
||||
: global-object-path ( string -- object )
|
||||
#! An object path based from the global namespace.
|
||||
"'" split global [ object-path ] bind ;
|
||||
|
||||
: on ( var -- ) t put ;
|
||||
: off ( var -- ) f put ;
|
||||
: toggle ( var -- ) dup get not put ;
|
||||
|
|
|
|||
|
|
@ -52,8 +52,8 @@ USE: parser
|
|||
"/library/platform/jvm/errors.factor" run-resource ! errors
|
||||
"/library/platform/jvm/namespaces.factor" run-resource ! namespaces
|
||||
"/library/namespaces.factor" run-resource ! namespaces
|
||||
"/library/sbuf.factor" run-resource ! strings
|
||||
"/library/list-namespaces.factor" run-resource ! namespaces
|
||||
"/library/sbuf.factor" run-resource ! strings
|
||||
"/library/math/namespace-math.factor" run-resource ! arithmetic
|
||||
"/library/continuations.factor" run-resource ! continuations
|
||||
"/library/errors.factor" run-resource ! errors
|
||||
|
|
|
|||
|
|
@ -69,3 +69,7 @@ USE: vectors
|
|||
#! this from a word definition will clobber any values left
|
||||
#! on the data stack by the caller.
|
||||
datastack* vector-clear ;
|
||||
|
||||
: depth ( -- n )
|
||||
#! Push the number of elements on the datastack.
|
||||
datastack vector-length ;
|
||||
|
|
|
|||
|
|
@ -139,19 +139,6 @@ USE: strings
|
|||
[ <char-stream>/fclose ] "fclose" set
|
||||
] extend ;
|
||||
|
||||
: <string-output-stream> ( size -- stream )
|
||||
#! Creates a new stream for writing to a string buffer.
|
||||
<stream> [
|
||||
<sbuf> "buf" set
|
||||
( string -- )
|
||||
[ "buf" get sbuf-append ] "fwrite" set
|
||||
] extend ;
|
||||
|
||||
: stream>str ( stream -- string )
|
||||
#! Returns the string written to the given string output
|
||||
#! stream.
|
||||
[ "buf" get ] bind >str ;
|
||||
|
||||
: <bwriter> ( writer -- bwriter )
|
||||
[ "java.io.Writer" ] "java.io.BufferedWriter" jnew ;
|
||||
|
||||
|
|
@ -233,6 +220,15 @@ USE: strings
|
|||
] "fclose" set
|
||||
] extend ;
|
||||
|
||||
: socket-closed? ( socket -- ? )
|
||||
[ ] "java.net.Socket" "isClosed" jinvoke ;
|
||||
|
||||
: close-socket ( socket -- )
|
||||
[ ] "java.net.Socket" "close" jinvoke ;
|
||||
|
||||
: ?close-socket ( socket -- )
|
||||
dup socket-closed? [ drop ] [ close-socket ] ifte ;
|
||||
|
||||
: <socket-stream> ( socket -- stream )
|
||||
#! Wraps a socket inside a byte-stream.
|
||||
dup
|
||||
|
|
@ -245,7 +241,7 @@ USE: strings
|
|||
! We "extend" byte-stream's fclose.
|
||||
( -- )
|
||||
"fclose" get [
|
||||
"socket" get [ ] "java.net.Socket" "close" jinvoke
|
||||
"socket" get ?close-socket
|
||||
] append "fclose" set
|
||||
] extend ;
|
||||
|
||||
|
|
|
|||
|
|
@ -83,6 +83,10 @@ primitives,
|
|||
"/library/httpd/http-common.factor"
|
||||
"/library/httpd/responder.factor"
|
||||
"/library/httpd/httpd.factor"
|
||||
"/library/httpd/inspect-responder.factor"
|
||||
"/library/httpd/test-responder.factor"
|
||||
"/library/httpd/quit-responder.factor"
|
||||
"/library/httpd/default-responders.factor"
|
||||
"/library/math/arc-trig-hyp.factor"
|
||||
"/library/math/arithmetic.factor"
|
||||
"/library/math/list-math.factor"
|
||||
|
|
|
|||
|
|
@ -75,7 +75,7 @@ USE: unparser
|
|||
init-scratchpad
|
||||
init-styles
|
||||
init-vocab-styles
|
||||
! default-responders
|
||||
default-responders
|
||||
|
||||
run-user-init
|
||||
|
||||
|
|
|
|||
|
|
@ -44,7 +44,8 @@ DEFER: >n
|
|||
: set-global ( g -- ) 4 setenv ;
|
||||
|
||||
: init-namespaces ( -- )
|
||||
64 <vector> set-namestack* global >n ;
|
||||
64 <vector> set-namestack* global >n
|
||||
global "global" set ;
|
||||
|
||||
: namespace-buckets 23 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -42,4 +42,8 @@ USE: vectors
|
|||
#! Clear the datastack. For interactive use only; invoking
|
||||
#! this from a word definition will clobber any values left
|
||||
#! on the data stack by the caller.
|
||||
0 <vector> set-datastack ;
|
||||
{ } set-datastack ;
|
||||
|
||||
: depth ( -- n )
|
||||
#! Push the number of elements on the datastack.
|
||||
datastack vector-length ;
|
||||
|
|
|
|||
|
|
@ -29,6 +29,7 @@ IN: strings
|
|||
USE: arithmetic
|
||||
USE: combinators
|
||||
USE: kernel
|
||||
USE: lists
|
||||
USE: namespaces
|
||||
USE: strings
|
||||
USE: stack
|
||||
|
|
@ -59,3 +60,22 @@ USE: stack
|
|||
#! push a new string constructed from return values.
|
||||
#! The quotation must have stack effect ( X -- X ).
|
||||
<% swap [ swap dup >r call % r> ] str-each drop %> ;
|
||||
|
||||
: split-next ( index string split -- next )
|
||||
3dup index-of* dup -1 = [
|
||||
>r drop swap str-tail , r> ( end of string )
|
||||
] [
|
||||
swap str-length dupd + >r swap substring , r>
|
||||
] ifte ;
|
||||
|
||||
: (split) ( index string split -- )
|
||||
2dup >r >r split-next dup -1 = [
|
||||
drop r> drop r> drop
|
||||
] [
|
||||
r> r> (split)
|
||||
] ifte ;
|
||||
|
||||
: split ( string split -- list )
|
||||
#! Split the string at each occurrence of split, and push a
|
||||
#! list of the pieces.
|
||||
[, 0 -rot (split) ,] ;
|
||||
|
|
|
|||
|
|
@ -29,6 +29,7 @@ IN: streams
|
|||
USE: errors
|
||||
USE: kernel
|
||||
USE: namespaces
|
||||
USE: strings
|
||||
|
||||
! Generic functions, of sorts...
|
||||
|
||||
|
|
@ -102,3 +103,16 @@ USE: namespaces
|
|||
( string -- )
|
||||
[ "stream" get fprint ] "fprint" set
|
||||
] extend ;
|
||||
|
||||
: <string-output-stream> ( size -- stream )
|
||||
#! Creates a new stream for writing to a string buffer.
|
||||
<stream> [
|
||||
<sbuf> "buf" set
|
||||
( string -- )
|
||||
[ "buf" get sbuf-append ] "fwrite" set
|
||||
] extend ;
|
||||
|
||||
: stream>str ( stream -- string )
|
||||
#! Returns the string written to the given string output
|
||||
#! stream.
|
||||
[ "buf" get ] bind sbuf>str ;
|
||||
|
|
|
|||
|
|
@ -114,19 +114,6 @@ USE: stack
|
|||
[ = ] dip f ?
|
||||
] ifte ;
|
||||
|
||||
: split ( string split -- list )
|
||||
#! Split the string at each occurrence of split, and push a
|
||||
#! list of the pieces.
|
||||
2dup index-of dup -1 = [
|
||||
2drop dup str-length 0 = [
|
||||
drop f
|
||||
] [
|
||||
unit
|
||||
] ifte
|
||||
] [
|
||||
swap [ str// ] dip split cons
|
||||
] ifte ;
|
||||
|
||||
: split1 ( string split -- before after )
|
||||
#! The car of the pair is the string up to the first
|
||||
#! occurrence of split; the cdr is the remainder of
|
||||
|
|
|
|||
|
|
@ -65,8 +65,6 @@ USE: url-encoding
|
|||
|
||||
[ ] [ "/" "get" ] [ serve-responder ] test-word
|
||||
[ ] [ "" "get" ] [ serve-responder ] test-word
|
||||
[ ] [ "test" "get" ] [ serve-responder ] test-word
|
||||
[ ] [ "test/" "get" ] [ serve-responder ] test-word
|
||||
[ ] [ "does-not-exist!" "get" ] [ serve-responder ] test-word
|
||||
[ ] [ "does-not-exist!/" "get" ] [ serve-responder ] test-word
|
||||
|
||||
|
|
|
|||
|
|
@ -25,9 +25,15 @@ USE: vocabularies
|
|||
: print-test ( input output -- )
|
||||
"TESTING: " write 2list . ;
|
||||
|
||||
: keep-datastack ( quot -- )
|
||||
datastack >r call r> set-datastack drop ;
|
||||
|
||||
: unit-test ( output input -- )
|
||||
2dup print-test
|
||||
swap >r >r clear r> call datastack vector>list r> = assert ;
|
||||
[
|
||||
2dup print-test
|
||||
swap >r >r clear r> call datastack vector>list r>
|
||||
= assert
|
||||
] keep-datastack 2drop ;
|
||||
|
||||
: test-word ( output input word -- )
|
||||
#! Old-style test.
|
||||
|
|
@ -44,8 +50,12 @@ USE: vocabularies
|
|||
|
||||
: test ( name -- )
|
||||
! Run the given test.
|
||||
depth pred >r
|
||||
"Testing " write dup write "..." print
|
||||
"/library/test/" swap ".factor" cat3 run-resource ;
|
||||
"/library/test/" swap ".factor" cat3 run-resource
|
||||
"Checking before/after depth..." print
|
||||
depth r> = assert
|
||||
;
|
||||
|
||||
: all-tests ( -- )
|
||||
"Running Factor test suite..." print
|
||||
|
|
@ -59,6 +69,7 @@ USE: vocabularies
|
|||
"lists/namespaces"
|
||||
"combinators"
|
||||
"continuations"
|
||||
"errors"
|
||||
"hashtables"
|
||||
"strings"
|
||||
"namespaces/namespaces"
|
||||
|
|
|
|||
Loading…
Reference in New Issue