factor/library/httpd/http-common.factor

! Copyright (C) 2003, 2005 Slava Pestov, Chris Double
IN: httpd
USING: kernel lists namespaces parser sequences stdio streams
strings url-encoding ;

: print-header ( alist -- )
    [ unswons write ": " write url-encode print ] each ;

: response ( header msg -- )
    "HTTP/1.0 " write print print-header ;

: error-body ( error -- body )
    "<html><body><h1>" swap "</h1></body></html>" cat3 print ;

: error-head ( error -- )
    dup log-error
    [ [[ "Content-Type" "text/html" ]] ] over response ;

: httpd-error ( error -- )
    #! This must be run from handle-request
    error-head
    "head" "method" get = [ terpri error-body ] unless ;

: bad-request ( -- )
    [
        ! Make httpd-error print a body
        "get" "method" set
        "400 Bad request" httpd-error
    ] with-scope ;

: serving-html ( -- )
    [ [[ "Content-Type" "text/html" ]] ]
    "200 Document follows" response terpri ;

: serving-text ( -- )
    [ [[ "Content-Type" "text/plain" ]] ]
    "200 Document follows" response terpri ;

: redirect ( to -- )
    "Location" swons unit
    "301 Moved Permanently" response terpri ;

: directory-no/ ( -- )
    [
        "request" get , CHAR: / ,
        "raw-query" get [ CHAR: ? , , ] when*
    ] make-string redirect ;

: header-line ( alist line -- alist )
    ": " split1 dup [ cons swons ] [ 2drop ] ifte ;

: (read-header) ( alist -- alist )
    read-line dup
    empty? [ drop ] [ header-line (read-header) ] ifte ;

: read-header ( -- alist )
    [ ] (read-header) ;

: content-length ( alist -- length )
    "Content-Length" swap assoc parse-number ;

: query>alist ( query -- alist )
    dup [
        "&" split [
            "=" split1
            dup [ url-decode ] when swap
            dup [ url-decode ] when swap cons
        ] map
    ] when ;

: read-post-request ( header -- alist )
    content-length dup [ read query>alist ] when ;

: log-user-agent ( alist -- )
    "User-Agent" swap assoc* [
        unswons [ , ": " , , ] make-string log
    ] when* ;

: prepare-url ( url -- url )
    #! This is executed in the with-request namespace.
    "?" split1
    dup "raw-query" set query>alist "query" set
    dup "request" set ;

: prepare-header ( -- )
    read-header dup "header" set
    dup log-user-agent
    read-post-request "response" set ;
minor cleanups here and there 2005-04-19 20:28:01 -04:00			`! Copyright (C) 2003, 2005 Slava Pestov, Chris Double`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00			`IN: httpd`
removing cfactor I/O code; unix ffi I/O socket code fixes 2005-04-22 20:09:46 -04:00			`USING: kernel lists namespaces parser sequences stdio streams`
minor cleanups here and there 2005-04-19 20:28:01 -04:00			`strings url-encoding ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
file-responder improvements, plugin improvements 2004-09-02 16:40:34 -04:00			`: print-header ( alist -- )`
			`[ unswons write ": " write url-encode print ] each ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
file-responder improvements, plugin improvements 2004-09-02 16:40:34 -04:00			`: response ( header msg -- )`
			`"HTTP/1.0 " write print print-header ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
			`: error-body ( error -- body )`
file-responder improvements, plugin improvements 2004-09-02 16:40:34 -04:00			`"<html><body><h1>" swap "</h1></body></html>" cat3 print ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
file-responder improvements, plugin improvements 2004-09-02 16:40:34 -04:00			`: error-head ( error -- )`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00			`dup log-error`
[[ car cdr ]] syntax replaces [ car \| cdr ] 2005-01-13 19:49:47 -05:00			`[ [[ "Content-Type" "text/html" ]] ] over response ;`
file-responder improvements, plugin improvements 2004-09-02 16:40:34 -04:00
			`: httpd-error ( error -- )`
			`#! This must be run from handle-request`
			`error-head`
			`"head" "method" get = [ terpri error-body ] unless ;`

			`: bad-request ( -- )`
			`[`
			`! Make httpd-error print a body`
			`"get" "method" set`
			`"400 Bad request" httpd-error`
			`] with-scope ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
file responder: redirect if directory url does not end with /, and other changes to httpd 2004-08-29 23:30:54 -04:00			`: serving-html ( -- )`
[[ car cdr ]] syntax replaces [ car \| cdr ] 2005-01-13 19:49:47 -05:00			`[ [[ "Content-Type" "text/html" ]] ]`
file-responder improvements, plugin improvements 2004-09-02 16:40:34 -04:00			`"200 Document follows" response terpri ;`
file responder: redirect if directory url does not end with /, and other changes to httpd 2004-08-29 23:30:54 -04:00
			`: serving-text ( -- )`
[[ car cdr ]] syntax replaces [ car \| cdr ] 2005-01-13 19:49:47 -05:00			`[ [[ "Content-Type" "text/plain" ]] ]`
file-responder improvements, plugin improvements 2004-09-02 16:40:34 -04:00			`"200 Document follows" response terpri ;`
file responder: redirect if directory url does not end with /, and other changes to httpd 2004-08-29 23:30:54 -04:00
			`: redirect ( to -- )`
file-responder improvements, plugin improvements 2004-09-02 16:40:34 -04:00			`"Location" swons unit`
			`"301 Moved Permanently" response terpri ;`
file responder: redirect if directory url does not end with /, and other changes to httpd 2004-08-29 23:30:54 -04:00
html-tags imported, file responder shows icons 2004-09-02 19:38:05 -04:00			`: directory-no/ ( -- )`
make-string and make-list replace <> and [, ,] 2004-11-11 15:15:43 -05:00			`[`
			`"request" get , CHAR: / ,`
			`"raw-query" get [ CHAR: ? , , ] when*`
			`] make-string redirect ;`
html-tags imported, file responder shows icons 2004-09-02 19:38:05 -04:00
working on http server, word of the day 2004-08-10 21:32:10 -04:00			`: header-line ( alist line -- alist )`
random cleanups, starting new developer's guide 2004-11-15 12:33:21 -05:00			`": " split1 dup [ cons swons ] [ 2drop ] ifte ;`
working on http server, word of the day 2004-08-10 21:32:10 -04:00
			`: (read-header) ( alist -- alist )`
stream word renaming 2005-02-14 22:15:02 -05:00			`read-line dup`
minor cleanups here and there 2005-04-19 20:28:01 -04:00			`empty? [ drop ] [ header-line (read-header) ] ifte ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
			`: read-header ( -- alist )`
working on http server, word of the day 2004-08-10 21:32:10 -04:00			`[ ] (read-header) ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
			`: content-length ( alist -- length )`
moved quadratic and simpson to contrib, fix some parse-number oddness 2004-10-10 14:28:56 -04:00			`"Content-Length" swap assoc parse-number ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
file responder: redirect if directory url does not end with /, and other changes to httpd 2004-08-29 23:30:54 -04:00			`: query>alist ( query -- alist )`
			`dup [`
			`"&" split [`
			`"=" split1`
			`dup [ url-decode ] when swap`
			`dup [ url-decode ] when swap cons`
			`] map`
			`] when ;`
fix read-post-request 2004-08-19 19:21:40 -04:00
			`: read-post-request ( header -- alist )`
stream word renaming 2005-02-14 22:15:02 -05:00			`content-length dup [ read query>alist ] when ;`
header and post request in variables, other tweaks 2004-08-17 20:44:57 -04:00
			`: log-user-agent ( alist -- )`
			`"User-Agent" swap assoc* [`
make-string and make-list replace <> and [, ,] 2004-11-11 15:15:43 -05:00			`unswons [ , ": " , , ] make-string log`
header and post request in variables, other tweaks 2004-08-17 20:44:57 -04:00			`] when* ;`

file responder: redirect if directory url does not end with /, and other changes to httpd 2004-08-29 23:30:54 -04:00			`: prepare-url ( url -- url )`
			`#! This is executed in the with-request namespace.`
			`"?" split1`
			`dup "raw-query" set query>alist "query" set`
			`dup "request" set ;`

			`: prepare-header ( -- )`
			`read-header dup "header" set`
			`dup log-user-agent`
			`read-post-request "response" set ;`