1 ! Copyright (C) 2004, 2010 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
4 DEFER: file-responder ! necessary for cgi-docs
5 DEFER: <static> ! necessary for cgi-docs
6 USING: accessors assocs calendar.parser combinators destructors
7 html html.templates.fhtml http http.server
8 http.server.redirection http.server.responses io.directories
9 io.encodings.binary io.files io.files.info io.pathnames kernel
10 logging math.order math.parser mime.types namespaces sequences
11 sorting splitting urls xml.syntax ;
14 TUPLE: file-responder root hook special index-names allow-listings ;
16 : modified-since ( request -- date )
17 "if-modified-since" header ";" split1 drop
18 dup [ rfc822>timestamp ] when ;
20 : modified-since? ( filename -- ? )
21 request get modified-since dup
22 [ [ file-info modified>> ] dip after? ] [ 2drop t ] if ;
24 : <file-responder> ( root hook -- responder )
29 V{ "index.html" } >>index-names ;
31 : (serve-static) ( path mime-type -- response )
33 [ binary <file-reader> &dispose ] dip <content>
34 binary >>content-encoding
36 [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi
37 [ "content-length" set-header ]
38 [ "last-modified" set-header ] bi* ;
40 : <static> ( root -- responder )
41 [ (serve-static) ] <file-responder> ;
43 : serve-static ( filename mime-type -- response )
45 [ file-responder get hook>> call( filename mime-type -- response ) ]
49 : serving-path ( filename -- filename )
50 [ file-responder get root>> trim-tail-separators ] dip
51 [ "/" swap trim-head-separators 3append ] unless-empty ;
53 : serve-file ( filename -- response )
55 [ file-responder get special>> at ]
56 [ call( filename -- response ) ] [ serve-static ] ?if ;
58 \ serve-file NOTICE add-input-logging
60 :: file-html-template ( href size modified -- xml )
63 <td><a href=<-href->><-href-></a></td>
64 <td align="right"><-modified-></td>
65 <td align="right"><-size-></td>
69 : file>html ( name infos -- xml )
72 [ drop "/" append "-" ]
73 [ size>> number>string ] if
74 ] [ modified>> ] bi file-html-template ;
76 : parent-dir-link ( -- xml )
77 "../" "" "" file-html-template ;
79 : ?parent-dir-link ( -- xml/f )
80 url get [ path>> "/" = [ "" ] [ parent-dir-link ] if ] [ "" ] if* ;
82 : listing-title ( -- title )
83 url get [ path>> "Index of " prepend ] [ "" ] if* ;
85 :: listing-html-template ( title listing ?parent CO-N CO-M CO-S -- xml )
86 [XML <h1><-title-></h1>
89 <th><a href=<-CO-N->>Name</a></th>
90 <th><a href=<-CO-M->>Last modified</a></th>
91 <th><a href=<-CO-S->>Size</a></th>
93 <tr><th colspan="5"><hr/></th></tr>
96 <tr><th colspan="5"><hr/></th></tr>
100 : sort-column ( -- column ) params get "C" of "N" or ;
102 : sort-order ( -- order ) params get "O" of "A" or ;
104 : sort-asc? ( -- ? ) sort-order "A" = ;
106 : toggle-order ( order -- order' ) "A" = "D" "A" ? ;
108 : ?toggle-sort-order ( col current-col -- order )
109 = [ sort-order toggle-order ] [ "A" ] if ;
111 : sort-orders ( -- CO-N CO-M CO-S )
112 "N" "M" "S" sort-column [
113 [ drop "?C=" "&O=" surround ]
114 [ ?toggle-sort-order ] 2bi append
117 : listing-sort-by ( seq quot: ( elt -- key ) -- sortedseq )
118 sort-by sort-asc? [ reverse ] unless ; inline
120 : sort-by-name ( {file,info} -- sorted )
121 [ first ] listing-sort-by ;
123 : sort-by-modified ( {file,info} -- sorted )
124 [ second modified>> ] listing-sort-by ;
126 : size-without-directories ( info -- size )
127 dup directory? [ drop -1 ] [ size>> ] if ;
129 : sort-by-size ( {file,info} -- sorted )
130 [ second size-without-directories ] listing-sort-by ;
132 : sort-listing ( zipped-files-infos -- sorted )
134 { "M" [ sort-by-modified ] }
135 { "S" [ sort-by-size ] }
136 [ drop sort-by-name ]
139 : zip-files-infos ( files -- zipped )
140 dup [ link-info ] map zip ;
142 : listing ( path -- seq-xml )
144 zip-files-infos sort-listing [ first2 file>html ] map
145 ] with-directory-files ;
147 : listing-body ( title path -- xml )
148 listing ?parent-dir-link sort-orders listing-html-template ;
150 : directory>html ( path -- xml )
151 [ listing-title f over ] dip listing-body simple-page ;
153 : list-directory ( directory -- response )
154 file-responder get allow-listings>> [
155 directory>html <html-content>
160 : find-index ( filename -- path )
161 file-responder get index-names>>
162 [ append-path dup file-exists? [ drop f ] unless ] with map-find
165 : serve-directory ( filename -- response )
166 url get path>> "/" tail? [
167 [ find-index ] [ serve-file ] [ list-directory ] ?if
170 url get clone [ "/" append ] change-path <permanent-redirect>
173 : serve-object ( filename -- response )
174 serving-path dup file-exists?
175 [ dup file-info directory? [ serve-directory ] [ serve-file ] if ]
179 M: file-responder call-responder*
182 [ drop <400> ] [ "/" join serve-object ] if ;
184 : add-index ( name responder -- )
185 index-names>> sets:adjoin ;
187 : serve-fhtml ( path -- response )
188 <fhtml> <html-content> ;
190 : enable-fhtml ( responder -- responder )
191 [ serve-fhtml ] "application/x-factor-server-page" pick special>> set-at
192 "index.fhtml" over add-index ;