1 ! Copyright (C) 2016 John Benediktsson
2 ! See https://factorcode.org/license.txt for BSD license
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 ;
12 TUPLE: gopher-server < threaded-server
13 { serving-hostname string }
14 { serving-directory string } ;
18 : send-file ( path -- )
19 binary [ [ write ] each-block ] with-file-reader ;
21 : gopher-type ( entry -- type )
23 { +directory+ [ drop "1" ] }
26 { [ dup "text/" head? ] [ drop "0" ] }
27 { [ dup "image/gif" = ] [ drop "g" ] }
28 { [ dup "image/" head? ] [ drop "I" ] }
34 : file-modified ( entry -- string )
35 modified>> "%Y-%b-%d %H:%M" strftime ;
37 : file-size ( entry -- string )
42 { [ dup 40 2^ >= ] [ 40 2^ /f "TB" ] }
43 { [ dup 30 2^ >= ] [ 30 2^ /f "GB" ] }
44 { [ dup 20 2^ >= ] [ 20 2^ /f "MB" ] }
46 } cond "%.1f %s" sprintf
49 :: list-directory ( server path -- )
50 path server serving-directory>> ?head drop [
52 "i[%s]\t\terror.host\t1\r\n\r\n" sprintf
56 ".." swap parent-directory
57 server serving-hostname>>
59 "1%-69s\t%s\t%s\t%d\r\n" sprintf
65 [ name>> "." head? ] reject
66 [ { [ directory? ] [ regular-file? ] } 1|| ] filter
69 [ gopher-type ] [ name>> ] [ directory? [ "/" append ] when ] tri
71 dup file-info [ file-modified ] [ file-size ] bi
72 "%-40s %s %10s" sprintf
75 server serving-directory>> ?head drop
78 server serving-hostname>>
80 "%s%s\t%s\t%s\t%d\r\n" sprintf
83 ] with-directory-entries ;
85 : send-directory ( server path -- )
86 dup ".gophermap" append-path dup file-exists? [
89 drop dup ".gopherhead" append-path
90 dup file-exists? [ send-file ] [ drop ] if
94 : read-gopher-path ( -- path )
95 readln dup [ "\t\r\n" member? ] find drop [ head ] when*
96 trim-tail-separators url-decode ;
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 ] }
108 : <gopher-server> ( directory port -- server )
109 utf8 gopher-server new-threaded-server
111 "localhost" >>serving-hostname
112 swap resolve-symlinks >>serving-directory
113 "gopher.server" >>name
115 5 minutes >>timeout ;
117 : start-gopher-server ( directory port -- server )
118 <gopher-server> start-server ;
120 : gopher-server-main ( -- )
121 command-line get ?first "." or
122 70 <gopher-server> start-server wait-for-server ;
124 MAIN: gopher-server-main