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