1 ! Copyright (C) 2004, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
4 DEFER: file-responder ! necessary for cgi-docs
5 DEFER: <static> ! necessary for cgi-docs
6 USING: calendar kernel math math.order math.parser namespaces
7 parser sequences strings assocs hashtables debugger mime.types
8 sorting logging calendar.format accessors splitting io io.files
9 io.files.info io.directories io.pathnames io.encodings.binary
10 fry xml.entities destructors urls html xml.syntax
11 html.templates.fhtml http http.server http.server.responses
12 http.server.redirection xml.writer locals ;
15 TUPLE: file-responder root hook special index-names allow-listings ;
17 : modified-since ( request -- date )
18 "if-modified-since" header ";" split1 drop
19 dup [ rfc822>timestamp ] when ;
21 : modified-since? ( filename -- ? )
22 request get modified-since dup
23 [ [ file-info modified>> ] dip after? ] [ 2drop t ] if ;
25 : <file-responder> ( root hook -- responder )
30 V{ "index.html" } >>index-names ;
32 : (serve-static) ( path mime-type -- response )
34 [ binary <file-reader> &dispose ] dip <content>
35 binary >>content-encoding
37 [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi
38 [ "content-length" set-header ]
39 [ "last-modified" set-header ] bi* ;
41 : <static> ( root -- responder )
42 [ (serve-static) ] <file-responder> ;
44 : serve-static ( filename mime-type -- response )
46 [ file-responder get hook>> call( filename mime-type -- response ) ]
50 : serving-path ( filename -- filename )
51 [ file-responder get root>> trim-tail-separators ] dip
52 [ "/" swap trim-head-separators 3append ] unless-empty ;
54 : serve-file ( filename -- response )
56 dup file-responder get special>> at
57 [ call( filename -- response ) ] [ serve-static ] ?if ;
59 \ serve-file NOTICE add-input-logging
61 :: file-html-template ( href size modified -- xml )
64 <td><a href=<-href->><-href-></a></td>
65 <td align="right"><-modified-></td>
66 <td align="right"><-size-></td>
70 : file>html ( name -- xml )
73 [ drop "/" append "-" ]
74 [ size>> number>string ] if
75 ] [ modified>> ] bi file-html-template ;
77 : parent-dir-link ( -- xml )
78 "../" "" "" file-html-template ;
80 : ?parent-dir-link ( -- xml/f )
81 url get [ path>> "/" = [ "" ] [ parent-dir-link ] if ] [ "" ] if* ;
83 : listing-title ( -- title )
84 url get [ path>> "Index of " prepend ] [ "" ] if* ;
86 :: listing-html-template ( title listing ?parent -- xml )
87 [XML <h1><-title-></h1>
91 <th>Last modified</th>
94 <tr><th colspan="5"><hr/></th></tr>
97 <tr><th colspan="5"><hr/></th></tr>
101 : listing ( path -- seq-xml )
102 [ natural-sort [ file>html ] map ] with-directory-files ;
104 : listing-body ( title path -- xml )
105 listing ?parent-dir-link listing-html-template ;
107 : directory>html ( path -- xml )
108 [ listing-title f over ] dip listing-body simple-page ;
110 : list-directory ( directory -- response )
111 file-responder get allow-listings>> [
112 directory>html <html-content>
117 : find-index ( filename -- path )
118 file-responder get index-names>>
119 [ append-path dup exists? [ drop f ] unless ] with map-find
122 : serve-directory ( filename -- response )
123 url get path>> "/" tail? [
125 find-index [ serve-file ] [ list-directory ] ?if
128 url get clone [ "/" append ] change-path <permanent-redirect>
131 : serve-object ( filename -- response )
132 serving-path dup exists?
133 [ dup file-info directory? [ serve-directory ] [ serve-file ] if ]
137 M: file-responder call-responder* ( path responder -- response )
140 [ drop <400> ] [ "/" join serve-object ] if ;
142 : add-index ( name responder -- )
143 index-names>> sets:adjoin ;
145 : serve-fhtml ( path -- response )
146 <fhtml> <html-content> ;
148 : enable-fhtml ( responder -- responder )
149 [ serve-fhtml ] "application/x-factor-server-page" pick special>> set-at
150 "index.fhtml" over add-index ;