1 ! Copyright (C) 2004, 2008 Slava Pestov.
\r
2 ! See http://factorcode.org/license.txt for BSD license.
\r
3 USING: calendar io io.files kernel math math.order
\r
4 math.parser namespaces parser sequences strings
\r
5 assocs hashtables debugger mime.types sorting logging
\r
6 calendar.format accessors splitting
\r
7 io.encodings.binary fry xml.entities destructors urls
\r
8 html.elements html.templates.fhtml
\r
11 http.server.responses
\r
12 http.server.redirection ;
\r
13 IN: http.server.static
\r
15 TUPLE: file-responder root hook special allow-listings ;
\r
17 : modified-since ( request -- date )
\r
18 "if-modified-since" header ";" split1 drop
\r
19 dup [ rfc822>timestamp ] when ;
\r
21 : modified-since? ( filename -- ? )
\r
22 request get modified-since dup [
\r
23 [ file-info modified>> ] dip after?
\r
28 : <file-responder> ( root hook -- responder )
\r
32 H{ } clone >>special ;
\r
34 : (serve-static) ( path mime-type -- response )
\r
36 [ binary <file-reader> &dispose ] dip
\r
37 <content> binary >>content-charset
\r
39 [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi
\r
40 [ "content-length" set-header ]
\r
41 [ "last-modified" set-header ] bi* ;
\r
43 : <static> ( root -- responder )
\r
44 [ (serve-static) ] <file-responder> ;
\r
46 : serve-static ( filename mime-type -- response )
\r
47 over modified-since?
\r
48 [ file-responder get hook>> call ] [ 2drop <304> ] if ;
\r
50 : serving-path ( filename -- filename )
\r
51 file-responder get root>> trim-right-separators
\r
53 rot "" or trim-left-separators 3append ;
\r
55 : serve-file ( filename -- response )
\r
57 dup file-responder get special>> at
\r
58 [ call ] [ serve-static ] ?if ;
\r
60 \ serve-file NOTICE add-input-logging
\r
63 dup link-info directory? [ "/" append ] when
\r
64 dup <a =href a> escape-string write </a> ;
\r
66 : directory. ( path -- )
\r
68 [ <h1> file-name escape-string write </h1> ]
\r
71 directory-files [ <li> file. </li> ] each
\r
76 : list-directory ( directory -- response )
\r
77 file-responder get allow-listings>> [
\r
78 '[ _ directory. ] "text/html" <content>
\r
83 : find-index ( filename -- path )
\r
84 "index.html" append-path dup exists? [ drop f ] unless ;
\r
86 : serve-directory ( filename -- response )
\r
87 url get path>> "/" tail? [
\r
89 find-index [ serve-file ] [ list-directory ] ?if
\r
92 url get clone [ "/" append ] change-path <permanent-redirect>
\r
95 : serve-object ( filename -- response )
\r
96 serving-path dup exists?
\r
97 [ dup file-info directory? [ serve-directory ] [ serve-file ] if ]
\r
101 M: file-responder call-responder* ( path responder -- response )
\r
104 [ drop <400> ] [ "/" join serve-object ] if ;
\r
106 ! file responder integration
\r
107 : enable-fhtml ( responder -- responder )
\r
108 [ <fhtml> "text/html" <content> ]
\r
109 "application/x-factor-server-page"
\r
110 pick special>> set-at ;
\r