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

make multi-assocs work for http headers

db4
Doug Coleman 2008-02-01 23:46:44 -06:00
parent ea8ad2b04c
commit 9e9c71b6d0
3 changed files with 22 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
extra/http/client/client.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs http kernel math math.parser namespaces sequences USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files strings splitting io io.sockets io.streams.string io.files strings splitting
continuations ; continuations assocs.lib ;
IN: http.client IN: http.client
: parse-host ( url -- host port ) : parse-host ( url -- host port )
@ -44,7 +44,7 @@ DEFER: http-get-stream
#! Should this support Location: headers that are #! Should this support Location: headers that are
#! relative URLs? #! relative URLs?
pick 100 /i 3 = [ pick 100 /i 3 = [
dispose "location" swap header-single nip http-get-stream dispose "location" swap peek-at nip http-get-stream
] when ; ] when ;
: http-get-stream ( url -- code headers stream ) : http-get-stream ( url -- code headers stream )

7
extra/http/http.factor
View File

@ -1,18 +1,19 @@
! Copyright (C) 2003, 2007 Slava Pestov. ! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: hashtables io kernel math namespaces math.parser assocs USING: hashtables io kernel math namespaces math.parser assocs
sequences strings splitting ascii io.utf8 assocs.lib ; sequences strings splitting ascii io.utf8 assocs.lib
namespaces unicode.case ;
IN: http IN: http
: header-line ( line -- ) : header-line ( line -- )
": " split1 dup [ swap >lower set ] [ 2drop ] if ; ": " split1 dup [ swap >lower insert ] [ 2drop ] if ;
: (read-header) ( -- ) : (read-header) ( -- )
readln dup readln dup
empty? [ drop ] [ header-line (read-header) ] if ; empty? [ drop ] [ header-line (read-header) ] if ;
: read-header ( -- hash ) : read-header ( -- hash )
[ (read-header) ] VH{ } make-assoc ; [ (read-header) ] H{ } make-assoc ;
: url-quotable? ( ch -- ? ) : url-quotable? ( ch -- ? )
#! In a URL, can this character be used without #! In a URL, can this character be used without

28
extra/http/server/responders/responders.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs hashtables html html.elements splitting USING: arrays assocs hashtables html html.elements splitting
http io kernel math math.parser namespaces parser sequences http io kernel math math.parser namespaces parser sequences
strings io.server ; strings io.server vectors vector-hash strings.lib ;
IN: http.server.responders IN: http.server.responders
@ -10,8 +10,11 @@ IN: http.server.responders
SYMBOL: vhosts SYMBOL: vhosts
SYMBOL: responders SYMBOL: responders
: >header ( value key -- vector-hash )
VH{ } clone [ set-at ] keep ;
: print-header ( alist -- ) : print-header ( alist -- )
[ swap write ": " write print ] assoc-each nl ; [ swap >Upper-dashes write ": " write print ] vector-hash-each nl ;
: response ( msg -- ) "HTTP/1.0 " write print ; : response ( msg -- ) "HTTP/1.0 " write print ;
@ -20,7 +23,7 @@ SYMBOL: responders
: error-head ( error -- ) : error-head ( error -- )
dup log-error response dup log-error response
H{ { "Content-Type" "text/html" } } print-header nl ; VH{ { "Content-Type" "text/html" } } print-header nl ;
: httpd-error ( error -- ) : httpd-error ( error -- )
#! This must be run from handle-request #! This must be run from handle-request
@ -36,7 +39,7 @@ SYMBOL: responders
: serving-content ( mime -- ) : serving-content ( mime -- )
"200 Document follows" response "200 Document follows" response
"Content-Type" associate print-header ; "Content-Type" >header print-header ;
: serving-html "text/html" serving-content ; : serving-html "text/html" serving-content ;
@ -46,7 +49,7 @@ SYMBOL: responders
: serving-text "text/plain" serving-content ; : serving-text "text/plain" serving-content ;
: redirect ( to response -- ) : redirect ( to response -- )
response "Location" associate print-header ; response "Location" >header print-header ;
: permanent-redirect ( to -- ) : permanent-redirect ( to -- )
"301 Moved Permanently" redirect ; "301 Moved Permanently" redirect ;
@ -84,14 +87,14 @@ SYMBOL: max-post-request
: log-headers ( hash -- ) : log-headers ( hash -- )
[ [
drop { drop {
"User-Agent" "user-agent"
"Referer" "referer"
"X-Forwarded-For" "x-forwarded-for"
"Host" "host"
} member? } member?
] assoc-subset [ ] assoc-subset [
": " swap 3append log-message ": " swap 3append log-message
] assoc-each ; ] vector-hash-each ;
: prepare-url ( url -- url ) : prepare-url ( url -- url )
#! This is executed in the with-request namespace. #! This is executed in the with-request namespace.
@ -122,7 +125,8 @@ SYMBOL: max-post-request
: query-param ( key -- value ) "query" get at ; : query-param ( key -- value ) "query" get at ;
: header-param ( key -- value ) "header" get at ; : header-param ( key -- value )
"header" get peek-at ;
: host ( -- string ) : host ( -- string )
#! The host the current responder was called from. #! The host the current responder was called from.
@ -130,7 +134,7 @@ SYMBOL: max-post-request
: add-responder ( responder -- ) : add-responder ( responder -- )
#! Add a responder object to the list. #! Add a responder object to the list.
"responder" over at responders get set-at ; "responder" over at responders get set-at ;
: make-responder ( quot -- ) : make-responder ( quot -- )
#! quot has stack effect ( url -- ) #! quot has stack effect ( url -- )