basis/http/server/static/static.factor

   1 ! Copyright (C) 2004, 2008 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.elements\r
   8 html.templates.fhtml http http.server http.server.responses\r
   9 http.server.redirection ;\r
  10 IN: http.server.static\r
  11 \r
  12 TUPLE: file-responder root hook special allow-listings ;\r
  13 \r
  14 : modified-since ( request -- date )\r
  15     "if-modified-since" header ";" split1 drop\r
  16     dup [ rfc822>timestamp ] when ;\r
  17 \r
  18 : modified-since? ( filename -- ? )\r
  19     request get modified-since dup [\r
  20         [ file-info modified>> ] dip after?\r
  21     ] [\r
  22         2drop t\r
  23     ] if ;\r
  24 \r
  25 : <file-responder> ( root hook -- responder )\r
  26     file-responder new\r
  27         swap >>hook\r
  28         swap >>root\r
  29         H{ } clone >>special ;\r
  30 \r
  31 : (serve-static) ( path mime-type -- response )\r
  32     [\r
  33         [ binary <file-reader> &dispose ] dip\r
  34         <content> binary >>content-charset\r
  35     ]\r
  36     [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi\r
  37     [ "content-length" set-header ]\r
  38     [ "last-modified" set-header ] bi* ;\r
  39 \r
  40 : <static> ( root -- responder )\r
  41     [ (serve-static) ] <file-responder> ;\r
  42 \r
  43 : serve-static ( filename mime-type -- response )\r
  44     over modified-since?\r
  45     [ file-responder get hook>> call ] [ 2drop <304> ] if ;\r
  46 \r
  47 : serving-path ( filename -- filename )\r
  48     file-responder get root>> trim-tail-separators\r
  49     "/"\r
  50     rot "" or trim-head-separators 3append ;\r
  51 \r
  52 : serve-file ( filename -- response )\r
  53     dup mime-type\r
  54     dup file-responder get special>> at\r
  55     [ call ] [ serve-static ] ?if ;\r
  56 \r
  57 \ serve-file NOTICE add-input-logging\r
  58 \r
  59 : file. ( name -- )\r
  60     dup link-info directory? [ "/" append ] when\r
  61     dup <a =href a> escape-string write </a> ;\r
  62 \r
  63 : directory. ( path -- )\r
  64     dup file-name [ ] [\r
  65         [ <h1> file-name escape-string write </h1> ]\r
  66         [\r
  67             <ul>\r
  68                 directory-files [ <li> file. </li> ] each\r
  69             </ul>\r
  70         ] bi\r
  71     ] simple-page ;\r
  72 \r
  73 : list-directory ( directory -- response )\r
  74     file-responder get allow-listings>> [\r
  75         '[ _ directory. ] "text/html" <content>\r
  76     ] [\r
  77         drop <403>\r
  78     ] if ;\r
  79 \r
  80 : find-index ( filename -- path )\r
  81     "index.html" append-path dup exists? [ drop f ] unless ;\r
  82 \r
  83 : serve-directory ( filename -- response )\r
  84     url get path>> "/" tail? [\r
  85         dup\r
  86         find-index [ serve-file ] [ list-directory ] ?if\r
  87     ] [\r
  88         drop\r
  89         url get clone [ "/" append ] change-path <permanent-redirect>\r
  90     ] if ;\r
  91 \r
  92 : serve-object ( filename -- response )\r
  93     serving-path dup exists?\r
  94     [ dup file-info directory? [ serve-directory ] [ serve-file ] if ]\r
  95     [ drop <404> ]\r
  96     if ;\r
  97 \r
  98 M: file-responder call-responder* ( path responder -- response )\r
  99     file-responder set\r
 100     ".." over member?\r
 101     [ drop <400> ] [ "/" join serve-object ] if ;\r
 102 \r
 103 ! file responder integration\r
 104 : enable-fhtml ( responder -- responder )\r
 105     [ <fhtml> "text/html" <content> ]\r
 106     "application/x-factor-server-page"\r
 107     pick special>> set-at ;\r