-! Copyright (C) 2004, 2010 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: calendar kernel math math.order math.parser namespaces\r
-parser sequences strings assocs hashtables debugger mime.types\r
-sorting logging calendar.format accessors splitting io io.files\r
-io.files.info io.directories io.pathnames io.encodings.binary\r
-fry xml.entities destructors urls html xml.syntax\r
-html.templates.fhtml http http.server http.server.responses\r
-http.server.redirection xml.writer ;\r
-FROM: sets => adjoin ;\r
-IN: http.server.static\r
-\r
-TUPLE: file-responder root hook special index-names allow-listings ;\r
-\r
-: modified-since ( request -- date )\r
- "if-modified-since" header ";" split1 drop\r
- dup [ rfc822>timestamp ] when ;\r
-\r
-: modified-since? ( filename -- ? )\r
- request get modified-since dup\r
- [ [ file-info modified>> ] dip after? ] [ 2drop t ] if ;\r
-\r
-: <file-responder> ( root hook -- responder )\r
- file-responder new\r
- swap >>hook\r
- swap >>root\r
- H{ } clone >>special\r
- V{ "index.html" } >>index-names ;\r
-\r
-: (serve-static) ( path mime-type -- response )\r
- [\r
- [ binary <file-reader> &dispose ] dip <content>\r
- binary >>content-encoding\r
- ]\r
- [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi\r
- [ "content-length" set-header ]\r
- [ "last-modified" set-header ] bi* ;\r
-\r
-: <static> ( root -- responder )\r
- [ (serve-static) ] <file-responder> ;\r
-\r
-: serve-static ( filename mime-type -- response )\r
- over modified-since?\r
- [ file-responder get hook>> call( filename mime-type -- response ) ]\r
- [ 2drop <304> ]\r
- if ;\r
-\r
-: serving-path ( filename -- filename )\r
- [ file-responder get root>> trim-tail-separators ] dip\r
- [ "/" swap trim-head-separators 3append ] unless-empty ;\r
-\r
-: serve-file ( filename -- response )\r
- dup mime-type\r
- dup file-responder get special>> at\r
- [ call( filename -- response ) ] [ serve-static ] ?if ;\r
-\r
-\ serve-file NOTICE add-input-logging\r
-\r
-: file>html ( name -- xml )\r
- dup link-info directory? [ "/" append ] when\r
- dup [XML <li><a href=<->><-></a></li> XML] ;\r
-\r
-: directory>html ( path -- xml )\r
- [ file-name ]\r
- [ drop f ]\r
- [\r
- [ file-name ] [ [ [ file>html ] map ] with-directory-files ] bi\r
- [XML <h1><-></h1> <ul><-></ul> XML]\r
- ] tri\r
- simple-page ;\r
-\r
-: list-directory ( directory -- response )\r
- file-responder get allow-listings>> [\r
- directory>html <html-content>\r
- ] [\r
- drop <403>\r
- ] if ;\r
-\r
-: find-index ( filename -- path )\r
- file-responder get index-names>>\r
- [ append-path dup exists? [ drop f ] unless ] with map-find\r
- drop ;\r
-\r
-: serve-directory ( filename -- response )\r
- url get path>> "/" tail? [\r
- dup\r
- find-index [ serve-file ] [ list-directory ] ?if\r
- ] [\r
- drop\r
- url get clone [ "/" append ] change-path <permanent-redirect>\r
- ] if ;\r
-\r
-: serve-object ( filename -- response )\r
- serving-path dup exists?\r
- [ dup file-info directory? [ serve-directory ] [ serve-file ] if ]\r
- [ drop <404> ]\r
- if ;\r
-\r
-M: file-responder call-responder* ( path responder -- response )\r
- file-responder set\r
- ".." over member?\r
- [ drop <400> ] [ "/" join serve-object ] if ;\r
-\r
-: add-index ( name responder -- )\r
- index-names>> adjoin ;\r
-\r
-: serve-fhtml ( path -- response )\r
- <fhtml> <html-content> ;\r
-\r
-: enable-fhtml ( responder -- responder )\r
- [ serve-fhtml ] "application/x-factor-server-page" pick special>> set-at\r
- "index.fhtml" over add-index ;\r
+! Copyright (C) 2004, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar kernel math math.order math.parser namespaces
+parser sequences strings assocs hashtables debugger mime.types
+sorting logging calendar.format accessors splitting io io.files
+io.files.info io.directories io.pathnames io.encodings.binary
+fry xml.entities destructors urls html xml.syntax
+html.templates.fhtml http http.server http.server.responses
+http.server.redirection xml.writer ;
+FROM: sets => adjoin ;
+IN: http.server.static
+
+TUPLE: file-responder root hook special index-names allow-listings ;
+
+: modified-since ( request -- date )
+ "if-modified-since" header ";" split1 drop
+ dup [ rfc822>timestamp ] when ;
+
+: modified-since? ( filename -- ? )
+ request get modified-since dup
+ [ [ file-info modified>> ] dip after? ] [ 2drop t ] if ;
+
+: <file-responder> ( root hook -- responder )
+ file-responder new
+ swap >>hook
+ swap >>root
+ H{ } clone >>special
+ V{ "index.html" } >>index-names ;
+
+: (serve-static) ( path mime-type -- response )
+ [
+ [ binary <file-reader> &dispose ] dip <content>
+ binary >>content-encoding
+ ]
+ [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi
+ [ "content-length" set-header ]
+ [ "last-modified" set-header ] bi* ;
+
+: <static> ( root -- responder )
+ [ (serve-static) ] <file-responder> ;
+
+: serve-static ( filename mime-type -- response )
+ over modified-since?
+ [ file-responder get hook>> call( filename mime-type -- response ) ]
+ [ 2drop <304> ]
+ if ;
+
+: serving-path ( filename -- filename )
+ [ file-responder get root>> trim-tail-separators ] dip
+ [ "/" swap trim-head-separators 3append ] unless-empty ;
+
+: serve-file ( filename -- response )
+ dup mime-type
+ dup file-responder get special>> at
+ [ call( filename -- response ) ] [ serve-static ] ?if ;
+
+\ serve-file NOTICE add-input-logging
+
+: file>html ( name -- xml )
+ dup link-info directory? [ "/" append ] when
+ dup [XML <li><a href=<->><-></a></li> XML] ;
+
+: directory>html ( path -- xml )
+ [ file-name ]
+ [ drop f ]
+ [
+ [ file-name ] [ [ [ file>html ] map ] with-directory-files ] bi
+ [XML <h1><-></h1> <ul><-></ul> XML]
+ ] tri
+ simple-page ;
+
+: list-directory ( directory -- response )
+ file-responder get allow-listings>> [
+ directory>html <html-content>
+ ] [
+ drop <403>
+ ] if ;
+
+: find-index ( filename -- path )
+ file-responder get index-names>>
+ [ append-path dup exists? [ drop f ] unless ] with map-find
+ drop ;
+
+: serve-directory ( filename -- response )
+ url get path>> "/" tail? [
+ dup
+ find-index [ serve-file ] [ list-directory ] ?if
+ ] [
+ drop
+ url get clone [ "/" append ] change-path <permanent-redirect>
+ ] if ;
+
+: serve-object ( filename -- response )
+ serving-path dup exists?
+ [ dup file-info directory? [ serve-directory ] [ serve-file ] if ]
+ [ drop <404> ]
+ if ;
+
+M: file-responder call-responder* ( path responder -- response )
+ file-responder set
+ ".." over member?
+ [ drop <400> ] [ "/" join serve-object ] if ;
+
+: add-index ( name responder -- )
+ index-names>> adjoin ;
+
+: serve-fhtml ( path -- response )
+ <fhtml> <html-content> ;
+
+: enable-fhtml ( responder -- responder )
+ [ serve-fhtml ] "application/x-factor-server-page" pick special>> set-at
+ "index.fhtml" over add-index ;
projects / factor.git / blobdiff