102 lines
2.8 KiB
Factor
Executable File
102 lines
2.8 KiB
Factor
Executable File
! Copyright (C) 2004, 2008 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: calendar html io io.files kernel math math.parser http
|
|
http.server namespaces parser sequences strings assocs
|
|
hashtables debugger http.mime sorting html.elements logging
|
|
calendar.format new-slots accessors ;
|
|
IN: http.server.static
|
|
|
|
SYMBOL: responder
|
|
|
|
! 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-modified unix-time>timestamp timestamp>http-string ;
|
|
|
|
: last-modified-matches? ( filename -- ? )
|
|
file-http-date dup [
|
|
request get "if-modified-since" header =
|
|
] when ;
|
|
|
|
: <304> ( -- response )
|
|
304 "Not modified" <trivial-response> ;
|
|
|
|
: <file-responder> ( root hook -- responder )
|
|
H{ } clone file-responder construct-boa ;
|
|
|
|
: <static> ( root -- responder )
|
|
[
|
|
<content>
|
|
over file-length "content-length" set-header
|
|
over file-http-date "last-modified" set-header
|
|
swap [ <file-reader> stdio get stream-copy ] curry >>body
|
|
] <file-responder> ;
|
|
|
|
: serve-static ( filename mime-type -- response )
|
|
over last-modified-matches?
|
|
[ 2drop <304> ] [ responder get hook>> call ] if ;
|
|
|
|
: serving-path ( filename -- filename )
|
|
"" or responder get root>> swap path+ ;
|
|
|
|
: serve-file ( filename -- response )
|
|
dup mime-type
|
|
dup responder get special>> at
|
|
[ call ] [ serve-static ] ?if ;
|
|
|
|
\ serve-file NOTICE add-input-logging
|
|
|
|
: file. ( name dirp -- )
|
|
[ "/" append ] when
|
|
dup <a =href a> write </a> ;
|
|
|
|
: directory. ( path -- )
|
|
dup file-name [
|
|
<h1> dup file-name write </h1>
|
|
<ul>
|
|
directory sort-keys
|
|
[ <li> file. </li> ] assoc-each
|
|
</ul>
|
|
] simple-html-document ;
|
|
|
|
: list-directory ( directory -- response )
|
|
"text/html" <content>
|
|
swap [ directory. ] curry >>body ;
|
|
|
|
: find-index ( filename -- path )
|
|
{ "index.html" "index.fhtml" }
|
|
[ dupd path+ exists? ] find nip
|
|
dup [ path+ ] [ nip ] if ;
|
|
|
|
: serve-directory ( filename -- response )
|
|
dup "/" tail? [
|
|
dup find-index
|
|
[ serve-file ] [ list-directory ] ?if
|
|
] [
|
|
drop request get redirect-with-/
|
|
] if ;
|
|
|
|
: serve-object ( filename -- response )
|
|
serving-path dup exists? [
|
|
dup directory? [ serve-directory ] [ serve-file ] if
|
|
] [
|
|
drop <404>
|
|
] if ;
|
|
|
|
M: file-responder call-responder ( request path responder -- response )
|
|
over [
|
|
".." pick subseq? [
|
|
3drop <400>
|
|
] [
|
|
responder set
|
|
swap request set
|
|
serve-object
|
|
] if
|
|
] [
|
|
2drop redirect-with-/
|
|
] if ;
|