extra/gopher/server/server.factor

   1 ! Copyright (C) 2016 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors calendar combinators combinators.short-circuit
   5 command-line formatting io io.directories io.encodings.binary
   6 io.encodings.string io.encodings.utf8 io.files io.files.info
   7 io.files.types io.pathnames io.servers kernel math mime.types
   8 namespaces sequences sorting splitting strings urls.encoding ;
   9
  10 IN: gopher.server
  11
  12 TUPLE: gopher-server < threaded-server
  13     { serving-hostname string }
  14     { serving-directory string } ;
  15
  16 <PRIVATE
  17
  18 : send-file ( path -- )
  19     binary [ [ write ] each-block ] with-file-reader ;
  20
  21 : gopher-type ( entry -- type )
  22     dup type>> {
  23         { +directory+ [ drop "1" ] }
  24         { +regular-file+ [
  25             name>> mime-type {
  26                 { [ dup "text/" head? ] [ drop "0" ] }
  27                 { [ dup "image/gif" = ] [ drop "g" ] }
  28                 { [ dup "image/" head? ] [ drop "I" ] }
  29                 [ drop "9" ]
  30             } cond ] }
  31         [ 2drop f ]
  32     } case ;
  33
  34 : file-modified ( entry -- string )
  35     modified>> "%Y-%b-%d %H:%M" strftime ;
  36
  37 : file-size ( entry -- string )
  38     dup directory? [
  39         drop "-  "
  40     ] [
  41         size>> {
  42             { [ dup 40 2^ >= ] [ 40 2^ /f "TB" ] }
  43             { [ dup 30 2^ >= ] [ 30 2^ /f "GB" ] }
  44             { [ dup 20 2^ >= ] [ 20 2^ /f "MB" ] }
  45             [ 10 2^ /f "KB" ]
  46         } cond "%.1f %s" sprintf
  47     ] if ;
  48
  49 :: list-directory ( server path -- )
  50     path server serving-directory>> ?head drop [
  51         [ "/" ] when-empty
  52         "i[%s]\t\terror.host\t1\r\n\r\n" sprintf
  53         utf8 encode write
  54     ] [
  55         [
  56             ".." swap parent-directory
  57             server serving-hostname>>
  58             server insecure>>
  59             "1%-69s\t%s\t%s\t%d\r\n" sprintf
  60             utf8 encode write
  61         ] unless-empty
  62     ] bi
  63
  64     path [
  65         [ name>> "." head? ] reject
  66         [ { [ directory? ] [ regular-file? ] } 1|| ] filter
  67         [ name>> ] sort-with
  68         [
  69             [ gopher-type ] [ name>> ] [ directory? [ "/" append ] when ] tri
  70             [
  71                 dup file-info [ file-modified ] [ file-size ] bi
  72                 "%-40s %s %10s" sprintf
  73             ] [
  74                 path prepend-path
  75                 server serving-directory>> ?head drop
  76                 url-encode
  77             ] bi
  78             server serving-hostname>>
  79             server insecure>>
  80             "%s%s\t%s\t%s\t%d\r\n" sprintf
  81             utf8 encode write
  82         ] each
  83     ] with-directory-entries ;
  84
  85 : send-directory ( server path -- )
  86     dup ".gophermap" append-path dup file-exists? [
  87         send-file 2drop
  88     ] [
  89         drop dup ".gopherhead" append-path
  90         dup file-exists? [ send-file ] [ drop ] if
  91         list-directory
  92     ] if ;
  93
  94 : read-gopher-path ( -- path )
  95     readln dup [ "\t\r\n" member? ] find drop [ head ] when*
  96     trim-tail-separators url-decode ;
  97
  98 M: gopher-server handle-client*
  99     dup serving-directory>> read-gopher-path append-path
 100     dup file-info type>> {
 101         { +directory+ [ send-directory ] }
 102         { +regular-file+ [ nip send-file ] }
 103         [ 3drop ]
 104     } case flush ;
 105
 106 PRIVATE>
 107
 108 : <gopher-server> ( directory port -- server )
 109     utf8 gopher-server new-threaded-server
 110         swap >>insecure
 111         "localhost" >>serving-hostname
 112         swap resolve-symlinks >>serving-directory
 113         "gopher.server" >>name
 114         binary >>encoding
 115         5 minutes >>timeout ;
 116
 117 : start-gopher-server ( directory port -- server )
 118     <gopher-server> start-server ;
 119
 120 : gopher-server-main ( -- )
 121     command-line get ?first "." or
 122     70 <gopher-server> start-server wait-for-server ;
 123
 124 MAIN: gopher-server-main