--- /dev/null
+! Copyright (C) 2016 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors calendar combinators combinators.short-circuit
+formatting fry io io.directories io.encodings.binary
+io.encodings.string io.encodings.utf8 io.files io.files.info
+io.files.types io.pathnames io.servers kernel locals math
+mime.types sequences splitting strings ;
+
+IN: gopher.server
+
+TUPLE: gopher-server < threaded-server
+ { serving-hostname string }
+ { serving-directory string } ;
+
+<PRIVATE
+
+: send-file ( path -- )
+ binary [ [ write ] each-block ] with-file-reader ;
+
+: gopher-type ( entry -- type )
+ dup type>> {
+ { +directory+ [ drop "1" ] }
+ { +regular-file+ [
+ name>> mime-type {
+ { [ dup "text/" head? ] [ drop "0" ] }
+ { [ dup "image/gif" = ] [ drop "g" ] }
+ { [ dup "image/" head? ] [ drop "I" ] }
+ [ drop "9" ]
+ } cond ] }
+ [ 2drop f ]
+ } case ;
+
+: file-modified ( entry -- string )
+ modified>> "%Y-%b-%d %H:%M" strftime ;
+
+: file-size ( entry -- string )
+ dup directory? [
+ drop "- "
+ ] [
+ size>> {
+ { [ dup 40 2^ >= ] [ 40 2^ /f "TB" ] }
+ { [ dup 30 2^ >= ] [ 30 2^ /f "GB" ] }
+ { [ dup 20 2^ >= ] [ 20 2^ /f "MB" ] }
+ [ 10 2^ /f "KB" ]
+ } cond "%.1f %s" sprintf
+ ] if ;
+
+:: list-directory ( server path -- )
+ path server serving-directory>> ?head drop [
+ "i[%s]\t\terror.host\t1\r\n\r\n" sprintf
+ utf8 encode write
+ ] [
+ [
+ ".." swap parent-directory
+ server serving-hostname>>
+ server insecure>>
+ "1%-67s\t%s\t%s\t%d\r\n" sprintf
+ utf8 encode write
+ ] unless-empty
+ ] bi
+
+ path [
+ [ name>> "." head? ] reject
+ [ { [ directory? ] [ regular-file? ] } 1|| ] filter
+ [
+ [ gopher-type ] [ name>> ] bi
+ [
+ dup file-info [ file-modified ] [ file-size ] bi
+ "%-40s %s %10s" sprintf
+ ] [
+ path prepend-path
+ ] bi
+ server serving-directory>> ?head drop
+ server serving-hostname>>
+ server insecure>>
+ "%s%s\t%s\t%s\t%d\r\n" sprintf
+ utf8 encode write
+ ] each
+ ] with-directory-entries ;
+
+: send-directory ( server path -- )
+ dup ".gophermap" append-path dup exists? [
+ send-file 2drop
+ ] [
+ drop dup ".gopherhead" append-path
+ dup exists? [ send-file ] [ drop ] if
+ list-directory
+ ] if ;
+
+: read-gopher-path ( -- path )
+ readln dup [ "\t\r\n" member? ] find drop [ head ] when*
+ trim-tail-separators ;
+
+: handle-gopher-client ( server -- )
+ dup serving-directory>> read-gopher-path append-path
+ dup file-info type>> {
+ { +directory+ [ send-directory ] }
+ { +regular-file+ [ nip send-file ] }
+ [ 3drop ]
+ } case flush ;
+
+PRIVATE>
+
+: <gopher-server> ( directory port -- server )
+ utf8 gopher-server new-threaded-server
+ swap >>insecure
+ "localhost" >>serving-hostname
+ swap resolve-symlinks >>serving-directory
+ "gopher.server" >>name
+ binary >>encoding
+ 5 minutes >>timeout
+ dup '[ _ handle-gopher-client ] >>handler ;
+
+: start-gopher-server ( directory port -- server )
+ <gopher-server> start-server ;