118 lines
3.4 KiB
Factor
118 lines
3.4 KiB
Factor
! 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 ;
|