Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
118 lines (101 sloc) 3.36 KB
! 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 urls.encoding ;
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 [
[ "/" ] when-empty
"i[%s]\t\terror.host\t1\r\n\r\n" sprintf
utf8 encode write
] [
[
".." swap parent-directory
server serving-hostname>>
server insecure>>
"1%-69s\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
server serving-directory>> ?head drop
url-encode
] bi
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 url-decode ;
M: gopher-server handle-client*
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 ;
: start-gopher-server ( directory port -- server )
<gopher-server> start-server ;