make multi-assocs work for http headers
parent
ea8ad2b04c
commit
9e9c71b6d0
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs http kernel math math.parser namespaces sequences
|
||||
io io.sockets io.streams.string io.files strings splitting
|
||||
continuations ;
|
||||
continuations assocs.lib ;
|
||||
IN: http.client
|
||||
|
||||
: parse-host ( url -- host port )
|
||||
|
@ -44,7 +44,7 @@ DEFER: http-get-stream
|
|||
#! Should this support Location: headers that are
|
||||
#! relative URLs?
|
||||
pick 100 /i 3 = [
|
||||
dispose "location" swap header-single nip http-get-stream
|
||||
dispose "location" swap peek-at nip http-get-stream
|
||||
] when ;
|
||||
|
||||
: http-get-stream ( url -- code headers stream )
|
||||
|
|
|
@ -1,18 +1,19 @@
|
|||
! Copyright (C) 2003, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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
|
||||
|
||||
: header-line ( line -- )
|
||||
": " split1 dup [ swap >lower set ] [ 2drop ] if ;
|
||||
": " split1 dup [ swap >lower insert ] [ 2drop ] if ;
|
||||
|
||||
: (read-header) ( -- )
|
||||
readln dup
|
||||
empty? [ drop ] [ header-line (read-header) ] if ;
|
||||
|
||||
: read-header ( -- hash )
|
||||
[ (read-header) ] VH{ } make-assoc ;
|
||||
[ (read-header) ] H{ } make-assoc ;
|
||||
|
||||
: url-quotable? ( ch -- ? )
|
||||
#! In a URL, can this character be used without
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs hashtables html html.elements splitting
|
||||
http io kernel math math.parser namespaces parser sequences
|
||||
strings io.server ;
|
||||
strings io.server vectors vector-hash strings.lib ;
|
||||
|
||||
IN: http.server.responders
|
||||
|
||||
|
@ -10,8 +10,11 @@ IN: http.server.responders
|
|||
SYMBOL: vhosts
|
||||
SYMBOL: responders
|
||||
|
||||
: >header ( value key -- vector-hash )
|
||||
VH{ } clone [ set-at ] keep ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
|
@ -20,7 +23,7 @@ SYMBOL: responders
|
|||
|
||||
: error-head ( error -- )
|
||||
dup log-error response
|
||||
H{ { "Content-Type" "text/html" } } print-header nl ;
|
||||
VH{ { "Content-Type" "text/html" } } print-header nl ;
|
||||
|
||||
: httpd-error ( error -- )
|
||||
#! This must be run from handle-request
|
||||
|
@ -36,7 +39,7 @@ SYMBOL: responders
|
|||
|
||||
: serving-content ( mime -- )
|
||||
"200 Document follows" response
|
||||
"Content-Type" associate print-header ;
|
||||
"Content-Type" >header print-header ;
|
||||
|
||||
: serving-html "text/html" serving-content ;
|
||||
|
||||
|
@ -46,7 +49,7 @@ SYMBOL: responders
|
|||
: serving-text "text/plain" serving-content ;
|
||||
|
||||
: redirect ( to response -- )
|
||||
response "Location" associate print-header ;
|
||||
response "Location" >header print-header ;
|
||||
|
||||
: permanent-redirect ( to -- )
|
||||
"301 Moved Permanently" redirect ;
|
||||
|
@ -84,14 +87,14 @@ SYMBOL: max-post-request
|
|||
: log-headers ( hash -- )
|
||||
[
|
||||
drop {
|
||||
"User-Agent"
|
||||
"Referer"
|
||||
"X-Forwarded-For"
|
||||
"Host"
|
||||
"user-agent"
|
||||
"referer"
|
||||
"x-forwarded-for"
|
||||
"host"
|
||||
} member?
|
||||
] assoc-subset [
|
||||
": " swap 3append log-message
|
||||
] assoc-each ;
|
||||
] vector-hash-each ;
|
||||
|
||||
: prepare-url ( url -- url )
|
||||
#! This is executed in the with-request namespace.
|
||||
|
@ -122,7 +125,8 @@ SYMBOL: max-post-request
|
|||
|
||||
: query-param ( key -- value ) "query" get at ;
|
||||
|
||||
: header-param ( key -- value ) "header" get at ;
|
||||
: header-param ( key -- value )
|
||||
"header" get peek-at ;
|
||||
|
||||
: host ( -- string )
|
||||
#! The host the current responder was called from.
|
||||
|
@ -130,7 +134,7 @@ SYMBOL: max-post-request
|
|||
|
||||
: add-responder ( responder -- )
|
||||
#! Add a responder object to the list.
|
||||
"responder" over at responders get set-at ;
|
||||
"responder" over at responders get set-at ;
|
||||
|
||||
: make-responder ( quot -- )
|
||||
#! quot has stack effect ( url -- )
|
||||
|
|
Loading…
Reference in New Issue