1 ! Copyright (C) 2004, 2010 Slava Pestov.
\r
2 ! See http://factorcode.org/license.txt for BSD license.
\r
3 USING: calendar kernel math math.order math.parser namespaces
\r
4 parser sequences strings assocs hashtables debugger mime.types
\r
5 sorting logging calendar.format accessors splitting io io.files
\r
6 io.files.info io.directories io.pathnames io.encodings.binary
\r
7 fry xml.entities destructors urls html xml.syntax
\r
8 html.templates.fhtml http http.server http.server.responses
\r
9 http.server.redirection xml.writer ;
\r
10 FROM: sets => adjoin ;
\r
11 IN: http.server.static
\r
13 TUPLE: file-responder root hook special index-names allow-listings ;
\r
15 : modified-since ( request -- date )
\r
16 "if-modified-since" header ";" split1 drop
\r
17 dup [ rfc822>timestamp ] when ;
\r
19 : modified-since? ( filename -- ? )
\r
20 request get modified-since dup
\r
21 [ [ file-info modified>> ] dip after? ] [ 2drop t ] if ;
\r
23 : <file-responder> ( root hook -- responder )
\r
27 H{ } clone >>special
\r
28 V{ "index.html" } >>index-names ;
\r
30 : (serve-static) ( path mime-type -- response )
\r
32 [ binary <file-reader> &dispose ] dip <content>
\r
33 binary >>content-encoding
\r
35 [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi
\r
36 [ "content-length" set-header ]
\r
37 [ "last-modified" set-header ] bi* ;
\r
39 : <static> ( root -- responder )
\r
40 [ (serve-static) ] <file-responder> ;
\r
42 : serve-static ( filename mime-type -- response )
\r
43 over modified-since?
\r
44 [ file-responder get hook>> call( filename mime-type -- response ) ]
\r
48 : serving-path ( filename -- filename )
\r
49 [ file-responder get root>> trim-tail-separators ] dip
\r
50 [ "/" swap trim-head-separators 3append ] unless-empty ;
\r
52 : serve-file ( filename -- response )
\r
54 dup file-responder get special>> at
\r
55 [ call( filename -- response ) ] [ serve-static ] ?if ;
\r
57 \ serve-file NOTICE add-input-logging
\r
59 : file>html ( name -- xml )
\r
60 dup link-info directory? [ "/" append ] when
\r
61 dup [XML <li><a href=<->><-></a></li> XML] ;
\r
63 : directory>html ( path -- xml )
\r
67 [ file-name ] [ [ [ file>html ] map ] with-directory-files ] bi
\r
68 [XML <h1><-></h1> <ul><-></ul> XML]
\r
72 : list-directory ( directory -- response )
\r
73 file-responder get allow-listings>> [
\r
74 directory>html <html-content>
\r
79 : find-index ( filename -- path )
\r
80 file-responder get index-names>>
\r
81 [ append-path dup exists? [ drop f ] unless ] with map-find
\r
84 : serve-directory ( filename -- response )
\r
85 url get path>> "/" tail? [
\r
87 find-index [ serve-file ] [ list-directory ] ?if
\r
90 url get clone [ "/" append ] change-path <permanent-redirect>
\r
93 : serve-object ( filename -- response )
\r
94 serving-path dup exists?
\r
95 [ dup file-info directory? [ serve-directory ] [ serve-file ] if ]
\r
99 M: file-responder call-responder* ( path responder -- response )
\r
102 [ drop <400> ] [ "/" join serve-object ] if ;
\r
104 : add-index ( name responder -- )
\r
105 index-names>> adjoin ;
\r
107 : serve-fhtml ( path -- response )
\r
108 <fhtml> <html-content> ;
\r
110 : enable-fhtml ( responder -- responder )
\r
111 [ serve-fhtml ] "application/x-factor-server-page" pick special>> set-at
\r
112 "index.fhtml" over add-index ;
\r