! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar io io.files kernel math math.order
math.parser namespaces parser sequences strings
assocs hashtables debugger mime.types sorting logging
calendar.format accessors splitting
io.encodings.binary fry xml.entities destructors urls
html.elements html.templates.fhtml
http
http.server
http.server.responses
http.server.redirection ;
IN: http.server.static

TUPLE: file-responder root hook special 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 ;

: (serve-static) ( path mime-type -- response )
    [
        [ binary <file-reader> &dispose ] dip
        <content> binary >>content-charset
    ]
    [ 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 ] [ 2drop <304> ] if ;

: serving-path ( filename -- filename )
    file-responder get root>> trim-right-separators
    "/"
    rot "" or trim-left-separators 3append ;

: serve-file ( filename -- response )
    dup mime-type
    dup file-responder get special>> at
    [ call ] [ serve-static ] ?if ;

\ serve-file NOTICE add-input-logging

: file. ( name -- )
    dup link-info directory? [ "/" append ] when
    dup <a =href a> escape-string write </a> ;

: directory. ( path -- )
    dup file-name [ ] [
        [ <h1> file-name escape-string write </h1> ]
        [
            <ul>
                directory-files [ <li> file. </li> ] each
            </ul>
        ] bi
    ] simple-page ;

: list-directory ( directory -- response )
    file-responder get allow-listings>> [
        '[ _ directory. ] "text/html" <content>
    ] [
        drop <403>
    ] if ;

: find-index ( filename -- path )
    "index.html" append-path dup exists? [ drop f ] unless ;

: 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 ;

! file responder integration
: enable-fhtml ( responder -- responder )
    [ <fhtml> "text/html" <content> ]
    "application/x-factor-server-page"
    pick special>> set-at ;