-! Copyright (C) 2004, 2009 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
-IN: http.server.static\r
-\r
-TUPLE: file-responder root hook special 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?\r
- ] [\r
- 2drop t\r
- ] if ;\r
-\r
-: <file-responder> ( root hook -- responder )\r
- file-responder new\r
- swap >>hook\r
- swap >>root\r
- H{ } clone >>special ;\r
-\r
-: (serve-static) ( path mime-type -- response )\r
- [\r
- [ binary <file-reader> &dispose ] dip\r
- <content> binary >>content-charset\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 "text/html" <content>\r
- ] [\r
- drop <403>\r
- ] if ;\r
-\r
-: find-index ( filename -- path )\r
- "index.html" append-path dup exists? [ drop f ] unless ;\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
-! file responder integration\r
-: enable-fhtml ( responder -- responder )\r
- [ <fhtml> "text/html" <content> ]\r
- "application/x-factor-server-page"\r
- pick special>> set-at ;\r
+! Copyright (C) 2004, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: http.server.static
+DEFER: file-responder ! necessary for cgi-docs
+DEFER: <static> ! necessary for cgi-docs
+USING: accessors assocs calendar.parser combinators destructors
+html html.templates.fhtml http http.server
+http.server.redirection http.server.responses io.directories
+io.encodings.binary io.files io.files.info io.pathnames kernel
+logging math.order math.parser mime.types namespaces sequences
+sorting splitting urls xml.syntax ;
+QUALIFIED: sets
+
+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-template ( href size modified -- xml )
+ [XML
+ <tr>
+ <td><a href=<-href->><-href-></a></td>
+ <td align="right"><-modified-></td>
+ <td align="right"><-size-></td>
+ </tr>
+ XML] ;
+
+: file>html ( name infos -- xml )
+ [
+ dup directory?
+ [ drop "/" append "-" ]
+ [ size>> number>string ] if
+ ] [ modified>> ] bi file-html-template ;
+
+: parent-dir-link ( -- xml )
+ "../" "" "" file-html-template ;
+
+: ?parent-dir-link ( -- xml/f )
+ url get [ path>> "/" = [ "" ] [ parent-dir-link ] if ] [ "" ] if* ;
+
+: listing-title ( -- title )
+ url get [ path>> "Index of " prepend ] [ "" ] if* ;
+
+:: listing-html-template ( title listing ?parent CO-N CO-M CO-S -- xml )
+ [XML <h1><-title-></h1>
+ <table>
+ <tr>
+ <th><a href=<-CO-N->>Name</a></th>
+ <th><a href=<-CO-M->>Last modified</a></th>
+ <th><a href=<-CO-S->>Size</a></th>
+ </tr>
+ <tr><th colspan="5"><hr/></th></tr>
+ <-?parent->
+ <-listing->
+ <tr><th colspan="5"><hr/></th></tr>
+ </table>
+ XML] ;
+
+: sort-column ( -- column ) params get "C" of "N" or ;
+
+: sort-order ( -- order ) params get "O" of "A" or ;
+
+: sort-asc? ( -- ? ) sort-order "A" = ;
+
+: toggle-order ( order -- order' ) "A" = "D" "A" ? ;
+
+: ?toggle-sort-order ( col current-col -- order )
+ = [ sort-order toggle-order ] [ "A" ] if ;
+
+: sort-orders ( -- CO-N CO-M CO-S )
+ "N" "M" "S" sort-column [
+ [ drop "?C=" ";O=" surround ]
+ [ ?toggle-sort-order ] 2bi append
+ ] curry tri@ ;
+
+: listing-sort-with ( seq quot: ( elt -- key ) -- sortedseq )
+ sort-with sort-asc? [ reverse ] unless ; inline
+
+: sort-with-name ( {file,info} -- sorted )
+ [ first ] listing-sort-with ;
+
+: sort-with-modified ( {file,info} -- sorted )
+ [ second modified>> ] listing-sort-with ;
+
+: size-without-directories ( info -- size )
+ dup directory? [ drop -1 ] [ size>> ] if ;
+
+: sort-with-size ( {file,info} -- sorted )
+ [ second size-without-directories ] listing-sort-with ;
+
+: sort-listing ( zipped-files-infos -- sorted )
+ sort-column {
+ { "M" [ sort-with-modified ] }
+ { "S" [ sort-with-size ] }
+ [ drop sort-with-name ]
+ } case ; inline
+
+: zip-files-infos ( files -- zipped )
+ dup [ link-info ] map zip ;
+
+: listing ( path -- seq-xml )
+ [
+ zip-files-infos sort-listing [ first2 file>html ] map
+ ] with-directory-files ;
+
+: listing-body ( title path -- xml )
+ listing ?parent-dir-link sort-orders listing-html-template ;
+
+: directory>html ( path -- xml )
+ [ listing-title f over ] dip listing-body 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 file-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 file-exists?
+ [ dup file-info directory? [ serve-directory ] [ serve-file ] if ]
+ [ drop <404> ]
+ if ;
+
+M: file-responder call-responder*
+ file-responder set
+ ".." over member?
+ [ drop <400> ] [ "/" join serve-object ] if ;
+
+: add-index ( name responder -- )
+ index-names>> sets: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