basis/http/server/static/static.factor

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