Can now serve binary files.

[scratchy.git] / gs.scm

diff --git a/gs.scm b/gs.scm
index c655e41..163eb2c 100644 (file)
--- a/gs.scm
+++ b/gs.scm
@@ -3,64 +3,86 @@
         (chicken io)
         (chicken string)
         (chicken pathname)
+        (chicken file posix)
         (chicken time posix)
-        srfi-1
+        (chicken condition)
         srfi-13)
 
 (define gopher-root "./gopher-root")
-(define index-file-name "index")
-(define gopher-server-hostname "egan.icytree.org")
+(define gopher-index-file-name "index")
+(define gopher-server-hostname "localhost")
 (define gopher-server-port 70)
 
 (define (run-server)
+  (print "Gopher server listening on port " gopher-server-port " ...")
   (let ((listener (tcp-listen gopher-server-port)))
-    (print "Gopher server listening on port " gopher-server-port " ...")
-    (let-values (((in-port out-port) (tcp-accept listener)))
-      (let* ((line (read-line in-port))
-             (selector (string-trim-both line)))
-        (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
-          (print "Accepted connection from " remote-ip
-                 " on " (seconds->string)))
-        (with-output-to-port out-port
-          (lambda ()
-            (retrieve-selector 
-             (if (= (string-length selector) 0)
-                 "/"
-                 selector)
-             gopher-root
-             gopher-server-hostname
-             gopher-server-port)))
-        (print "... retrieved selector '" selector "'. Closing connection."))
-      (close-input-port in-port)
-      (close-output-port out-port))
-    (tcp-close listener))
-  (run-server))
+    (let loop ()
+      (let-values (((in-port out-port) (tcp-accept listener)))
+        (let* ((line (read-line in-port))
+               (selector (string-trim-both line)))
+          (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
+            (print "Accepted connection from " remote-ip
+                   " on " (seconds->string)))
+          (with-output-to-port out-port
+            (lambda ()
+              (serve-selector 
+               (if (= (string-length selector) 0)
+                   "1/"
+                   selector)
+               gopher-root
+               gopher-server-hostname
+               gopher-server-port)))
+          (print "... served selector '" selector "'. Closing connection."))
+        (close-input-port in-port)
+        (close-output-port out-port))
+      (loop))
+    (tcp-close listener)))
 
 ;;; Selector retrieval
 
-(define (retrieve-selector selector gopher-root server-host server-port)
-  (if (string-suffix? "/" selector)
-      (retrieve-index-file (make-pathname gopher-root (make-pathname selector index-file-name))
-                           server-host
-                           server-port)
-      (retrieve-text-file (make-pathname gopher-root selector)
+(define (serve-selector selector gopher-root server-host server-port)
+  (let ((type (with-input-from-string (substring selector 0 1) read))
+        (path (substring selector 1)))
+    (case type
+      ((0) (serve-text-file path server-host server-port))
+      ((1) (serve-index-file path server-host server-port))
+      ((9 g I) (serve-binary-file path server-host server-port))
+      (else (error "Unhandled file type:" type)))))
+
+(define (serve-index-file path server-host server-port)
+  (let ((file-name (make-pathname (list gopher-root path) gopher-index-file-name)))
+    (if (regular-file? file-name)
+        (with-input-from-file file-name
+          (lambda ()
+            (render-index (read)
+                          path
                           server-host
                           server-port)))
-
-(define (retrieve-index-file index-file-name server-host server-port)
-  (with-input-from-file index-file-name
-    (lambda ()
-      (render-index (read)
-                    server-host
-                    server-port))))
-
-(define (retrieve-text-file file-name server-host server-port)
-  (with-input-from-file file-name
-    (lambda ()
-      (for-each
-       (lambda (line)
-         (print line "\r"))
-       (read-lines)))))
+        (error "Index file not found."))))
+  
+(define (serve-text-file path server-host server-port)
+  (let ((file-name (make-pathname gopher-root path)))
+    (if (regular-file? file-name)
+        (with-input-from-file file-name
+          (lambda ()
+            (for-each
+             (lambda (line)
+               (print line "\r"))
+             (read-lines))))
+        (error "File not found."))))
+
+(define (serve-binary-file path server-host server-port)
+  (let ((file-name (make-pathname gopher-root path)))
+    (if (regular-file? file-name)
+        (with-input-from-file file-name
+          (lambda ()
+            (let loop ((b (read-byte)))
+              (if (eof-object? b)
+                  'done
+                  (begin
+                    (write-byte b)
+                    (loop (read-byte)))))))))
+  (print "File not found."))
 
 ;;; Index rendering
 
@@ -80,13 +102,16 @@
 
 (define (entry-port entry) (list-ref entry 4))
 
-(define (render-entry entry default-selector default-host default-port)
+(define (render-entry entry default-selector default-host default-port selector-prefix)
   (let ((name-string (entry-name entry)))
     (for-each
      (lambda (name-string-line)
        (print* (entry-type entry) name-string-line)
        (print* "\t" (if (has-selector? entry)
-                        (entry-selector entry)
+                        (if (has-host? entry)
+                            (entry-selector entry)
+                            (conc (entry-type entry)
+                                  (make-pathname selector-prefix (entry-selector entry))))
                         default-selector))
        (print* "\t" (if (has-host? entry)
                         (entry-host entry)
@@ -97,11 +122,11 @@
        (print* "\r\n"))
      (string-split name-string "\n" #t))))
 
-(define (render-index index this-host this-port)
+(define (render-index index selector-prefix this-host this-port)
   (for-each
    (lambda (entry)
      (if (eq? (entry-type entry) 'i)
-         (render-entry entry "fake.selector" "fake.host" 1)
-         (render-entry entry "" this-host this-port)))
+         (render-entry entry "fake.selector" "fake.host" 1 selector-prefix)
+         (render-entry entry "" this-host this-port selector-prefix)))
    index)
   (print "."))