extra/gemini/server/server.factor

   1 ! Copyright (C) 2021 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 io.sockets.secure kernel
   8 math mime.types namespaces sequences sorting splitting strings
   9 urls urls.encoding ;
  10
  11 IN: gemini.server
  12
  13 TUPLE: gemini-server < threaded-server
  14     { serving-directory string } ;
  15
  16 <PRIVATE
  17
  18 : send-file ( path -- )
  19     binary [ [ write ] each-block ] with-file-reader ;
  20
  21 : write-utf8 ( string -- )
  22     utf8 encode write ;
  23
  24 : send-status ( path file-info -- )
  25     type>> {
  26         { +directory+ [ drop "text/gemini" ] }
  27         { +regular-file+ [ mime-type ] }
  28         [ 2drop f ]
  29     } case "application/octet-stream" or
  30     "20 %s\r\n" sprintf write-utf8 ;
  31
  32 : file-modified ( entry -- string )
  33     modified>> "%Y-%b-%d %H:%M" strftime ;
  34
  35 : file-size ( entry -- string )
  36     dup directory? [
  37         drop "-  "
  38     ] [
  39         size>> {
  40             { [ dup 40 2^ >= ] [ 40 2^ /f "TB" ] }
  41             { [ dup 30 2^ >= ] [ 30 2^ /f "GB" ] }
  42             { [ dup 20 2^ >= ] [ 20 2^ /f "MB" ] }
  43             [ 10 2^ /f "KB" ]
  44         } cond "%.1f %s" sprintf
  45     ] if ;
  46
  47 :: list-directory ( server path -- )
  48     path server serving-directory>> ?head drop [
  49         "# [%s]\r\n\r\n" sprintf write-utf8
  50     ] [
  51         dup "/" = [ drop ] [
  52             parent-directory ".."
  53             "=> %s %-69s\r\n" sprintf
  54             write-utf8
  55         ] if
  56     ] bi
  57
  58     path [
  59         [ name>> "." head? ] reject
  60         [ { [ directory? ] [ regular-file? ] } 1|| ] filter
  61         [ name>> ] sort-with
  62         [
  63             [ name>> ] [ directory? [ "/" append ] when ] bi
  64             [
  65                 url-encode
  66             ] [
  67                 dup file-info [ file-modified ] [ file-size ] bi
  68                 "%-40s %s %10s" sprintf
  69             ] bi
  70             "=> %s %s\r\n" sprintf
  71             write-utf8
  72         ] each
  73     ] with-directory-entries ;
  74
  75 : send-directory ( server path -- )
  76     dup ".geminimap" append-path dup file-exists? [
  77         send-file 2drop
  78     ] [
  79         drop dup ".geminihead" append-path
  80         dup file-exists? [ send-file ] [ drop ] if
  81         list-directory
  82     ] if ;
  83
  84 : read-gemini-path ( -- path )
  85     readln utf8 decode "\r" ?tail drop >url path>> ;
  86
  87 M: gemini-server handle-client*
  88     dup serving-directory>> read-gemini-path append
  89     dup file-info [ send-status ] 2keep type>> {
  90         { +directory+ [ send-directory ] }
  91         { +regular-file+ [ nip send-file ] }
  92         [ 3drop ]
  93     } case flush ;
  94
  95 PRIVATE>
  96
  97 : <gemini-secure-config> ( -- secure-config )
  98     <secure-config>
  99         "key-file" get absolute-path >>key-file
 100         "dh-file" get absolute-path >>dh-file
 101         "key-password" get >>password ;
 102
 103 : <gemini-server> ( directory port -- server )
 104     utf8 gemini-server new-threaded-server
 105         <gemini-secure-config> >>secure-config
 106         f >>insecure
 107         swap >>secure
 108         swap resolve-symlinks >>serving-directory
 109         "gemini.server" >>name
 110         binary >>encoding
 111         5 minutes >>timeout ;
 112
 113 : gemini-server-main ( -- )
 114     command-line get ?first "." or
 115     1965 <gemini-server> start-server wait-for-server ;
 116
 117 MAIN: gemini-server-main
 118
 119 ! ./factor -key-file=cert.pem -dh-file=dh2048.pem -key-password=password -run=gemini.server