From 3ce514623516c0f47d15b84fa33028e4235e1d04 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Wed, 26 Oct 2016 16:47:00 -0700
Subject: [PATCH] gopher.server: adding a Gopher server.

---
 extra/gopher/server/authors.txt   |   1 +
 extra/gopher/server/server.factor | 116 ++++++++++++++++++++++++++++++
 extra/gopher/server/summary.txt   |   1 +
 extra/gopher/server/tags.txt      |   1 +
 4 files changed, 119 insertions(+)
 create mode 100644 extra/gopher/server/authors.txt
 create mode 100644 extra/gopher/server/server.factor
 create mode 100644 extra/gopher/server/summary.txt
 create mode 100644 extra/gopher/server/tags.txt

diff --git a/extra/gopher/server/authors.txt b/extra/gopher/server/authors.txt
new file mode 100644
index 0000000000..e091bb8164
--- /dev/null
+++ b/extra/gopher/server/authors.txt
@@ -0,0 +1 @@
+John Benediktsson
diff --git a/extra/gopher/server/server.factor b/extra/gopher/server/server.factor
new file mode 100644
index 0000000000..850ad3bce6
--- /dev/null
+++ b/extra/gopher/server/server.factor
@@ -0,0 +1,116 @@
+! 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 ;
diff --git a/extra/gopher/server/summary.txt b/extra/gopher/server/summary.txt
new file mode 100644
index 0000000000..3caf8cfece
--- /dev/null
+++ b/extra/gopher/server/summary.txt
@@ -0,0 +1 @@
+Gopher server
diff --git a/extra/gopher/server/tags.txt b/extra/gopher/server/tags.txt
new file mode 100644
index 0000000000..992ae12982
--- /dev/null
+++ b/extra/gopher/server/tags.txt
@@ -0,0 +1 @@
+network