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.parser 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 combinators ;
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 infos -- 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 CO-N CO-M CO-S -- xml )
87 [XML <h1><-title-></h1>
90 <th><a href=<-CO-N->>Name</a></th>
91 <th><a href=<-CO-M->>Last modified</a></th>
92 <th><a href=<-CO-S->>Size</a></th>
94 <tr><th colspan="5"><hr/></th></tr>
97 <tr><th colspan="5"><hr/></th></tr>
101 : sort-column ( -- column ) params get "C" of "N" or ;
103 : sort-order ( -- order ) params get "O" of "A" or ;
105 : sort-asc? ( -- ? ) sort-order "A" = ;
107 : toggle-order ( order -- order' ) "A" = "D" "A" ? ;
109 : ?toggle-sort-order ( col current-col -- order )
110 = [ sort-order toggle-order ] [ "A" ] if ;
112 : sort-orders ( -- CO-N CO-M CO-S )
113 "N" "M" "S" sort-column [
114 [ drop "?C=" ";O=" surround ]
115 [ ?toggle-sort-order ] 2bi append
118 : listing-sort-with ( seq quot: ( elt -- key ) -- sortedseq )
119 sort-with sort-asc? [ reverse ] unless ; inline
121 : sort-with-name ( {file,info} -- sorted )
122 [ first ] listing-sort-with ;
124 : sort-with-modified ( {file,info} -- sorted )
125 [ second modified>> ] listing-sort-with ;
127 : size-without-directories ( info -- size )
128 dup directory? [ drop -1 ] [ size>> ] if ;
130 : sort-with-size ( {file,info} -- sorted )
131 [ second size-without-directories ] listing-sort-with ;
133 : sort-listing ( zipped-files-infos -- sorted )
135 { "M" [ sort-with-modified ] }
136 { "S" [ sort-with-size ] }
137 [ drop sort-with-name ]
140 : zip-files-infos ( files -- zipped )
141 dup [ link-info ] map zip ;
143 : listing ( path -- seq-xml )
145 zip-files-infos sort-listing [ first2 file>html ] map
146 ] with-directory-files ;
148 : listing-body ( title path -- xml )
149 listing ?parent-dir-link sort-orders listing-html-template ;
151 : directory>html ( path -- xml )
152 [ listing-title f over ] dip listing-body simple-page ;
154 : list-directory ( directory -- response )
155 file-responder get allow-listings>> [
156 directory>html <html-content>
161 : find-index ( filename -- path )
162 file-responder get index-names>>
163 [ append-path dup file-exists? [ drop f ] unless ] with map-find
166 : serve-directory ( filename -- response )
167 url get path>> "/" tail? [
169 find-index [ serve-file ] [ list-directory ] ?if
172 url get clone [ "/" append ] change-path <permanent-redirect>
175 : serve-object ( filename -- response )
176 serving-path dup file-exists?
177 [ dup file-info directory? [ serve-directory ] [ serve-file ] if ]
181 M: file-responder call-responder*
184 [ drop <400> ] [ "/" join serve-object ] if ;
186 : add-index ( name responder -- )
187 index-names>> sets:adjoin ;
189 : serve-fhtml ( path -- response )
190 <fhtml> <html-content> ;
192 : enable-fhtml ( responder -- responder )
193 [ serve-fhtml ] "application/x-factor-server-page" pick special>> set-at
194 "index.fhtml" over add-index ;