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