basis/http/server/static/static.factor

   1 ! Copyright (C) 2004, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: http.server.static
   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 ;
  12 QUALIFIED: sets
  13
  14 TUPLE: file-responder root hook special index-names allow-listings ;
  15
  16 : modified-since ( request -- date )
  17     "if-modified-since" header ";" split1 drop
  18     dup [ rfc822>timestamp ] when ;
  19
  20 : modified-since? ( filename -- ? )
  21     request get modified-since dup
  22     [ [ file-info modified>> ] dip after? ] [ 2drop t ] if ;
  23
  24 : <file-responder> ( root hook -- responder )
  25     file-responder new
  26         swap >>hook
  27         swap >>root
  28         H{ } clone >>special
  29         V{ "index.html" } >>index-names ;
  30
  31 : (serve-static) ( path mime-type -- response )
  32     [
  33         [ binary <file-reader> &dispose ] dip <content>
  34         binary >>content-encoding
  35     ]
  36     [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi
  37     [ "content-length" set-header ]
  38     [ "last-modified" set-header ] bi* ;
  39
  40 : <static> ( root -- responder )
  41     [ (serve-static) ] <file-responder> ;
  42
  43 : serve-static ( filename mime-type -- response )
  44     over modified-since?
  45     [ file-responder get hook>> call( filename mime-type -- response ) ]
  46     [ 2drop <304> ]
  47     if ;
  48
  49 : serving-path ( filename -- filename )
  50     [ file-responder get root>> trim-tail-separators ] dip
  51     [ "/" swap trim-head-separators 3append ] unless-empty ;
  52
  53 : serve-file ( filename -- response )
  54     dup mime-type
  55     dup file-responder get special>> at
  56     [ call( filename -- response ) ] [ serve-static ] ?if ;
  57
  58 \ serve-file NOTICE add-input-logging
  59
  60 :: file-html-template ( href size modified -- xml )
  61     [XML
  62         <tr>
  63             <td><a href=<-href->><-href-></a></td>
  64             <td align="right"><-modified-></td>
  65             <td align="right"><-size-></td>
  66         </tr>
  67     XML] ;
  68
  69 : file>html ( name infos -- xml )
  70     [
  71         dup directory?
  72         [ drop "/" append "-" ]
  73         [ size>> number>string ] if
  74     ] [ modified>> ] bi file-html-template ;
  75
  76 : parent-dir-link ( -- xml )
  77     "../" "" "" file-html-template ;
  78
  79 : ?parent-dir-link ( -- xml/f )
  80     url get [ path>> "/" = [ "" ] [ parent-dir-link ] if ] [ "" ] if* ;
  81
  82 : listing-title ( -- title )
  83     url get [ path>> "Index of " prepend ] [ "" ] if* ;
  84
  85 :: listing-html-template ( title listing ?parent CO-N CO-M CO-S -- xml )
  86     [XML <h1><-title-></h1>
  87         <table>
  88             <tr>
  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>
  92             </tr>
  93             <tr><th colspan="5"><hr/></th></tr>
  94             <-?parent->
  95             <-listing->
  96             <tr><th colspan="5"><hr/></th></tr>
  97         </table>
  98     XML] ;
  99
 100 : sort-column ( -- column ) params get "C" of "N" or ;
 101
 102 : sort-order ( -- order ) params get "O" of "A" or ;
 103
 104 : sort-asc? ( -- ? ) sort-order "A" = ;
 105
 106 : toggle-order ( order -- order' ) "A" = "D" "A" ? ;
 107
 108 : ?toggle-sort-order ( col current-col -- order )
 109     = [ sort-order toggle-order ] [ "A" ] if ;
 110
 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
 115     ] curry tri@ ;
 116
 117 : listing-sort-with ( seq quot: ( elt -- key ) -- sortedseq )
 118     sort-with sort-asc? [ reverse ] unless ; inline
 119
 120 : sort-with-name ( {file,info} -- sorted )
 121     [ first ] listing-sort-with ;
 122
 123 : sort-with-modified ( {file,info} -- sorted )
 124     [ second modified>> ] listing-sort-with ;
 125
 126 : size-without-directories ( info -- size )
 127     dup directory? [ drop -1 ] [ size>> ] if ;
 128
 129 : sort-with-size ( {file,info} -- sorted )
 130     [ second size-without-directories ] listing-sort-with ;
 131
 132 : sort-listing ( zipped-files-infos -- sorted )
 133     sort-column {
 134         { "M" [ sort-with-modified ] }
 135         { "S" [ sort-with-size ] }
 136         [ drop sort-with-name ]
 137     } case ; inline
 138
 139 : zip-files-infos ( files -- zipped )
 140     dup [ link-info ] map zip ;
 141
 142 : listing ( path -- seq-xml )
 143     [
 144         zip-files-infos sort-listing [ first2 file>html ] map
 145     ] with-directory-files ;
 146
 147 : listing-body ( title path -- xml )
 148     listing ?parent-dir-link sort-orders listing-html-template ;
 149
 150 : directory>html ( path -- xml )
 151     [ listing-title f over ] dip listing-body simple-page ;
 152
 153 : list-directory ( directory -- response )
 154     file-responder get allow-listings>> [
 155         directory>html <html-content>
 156     ] [
 157         drop <403>
 158     ] if ;
 159
 160 : find-index ( filename -- path )
 161     file-responder get index-names>>
 162     [ append-path dup file-exists? [ drop f ] unless ] with map-find
 163     drop ;
 164
 165 : serve-directory ( filename -- response )
 166     url get path>> "/" tail? [
 167         dup
 168         find-index [ serve-file ] [ list-directory ] ?if
 169     ] [
 170         drop
 171         url get clone [ "/" append ] change-path <permanent-redirect>
 172     ] if ;
 173
 174 : serve-object ( filename -- response )
 175     serving-path dup file-exists?
 176     [ dup file-info directory? [ serve-directory ] [ serve-file ] if ]
 177     [ drop <404> ]
 178     if ;
 179
 180 M: file-responder call-responder*
 181     file-responder set
 182     ".." over member?
 183     [ drop <400> ] [ "/" join serve-object ] if ;
 184
 185 : add-index ( name responder -- )
 186     index-names>> sets:adjoin ;
 187
 188 : serve-fhtml ( path -- response )
 189     <fhtml> <html-content> ;
 190
 191 : enable-fhtml ( responder -- responder )
 192     [ serve-fhtml ] "application/x-factor-server-page" pick special>> set-at
 193     "index.fhtml" over add-index ;