Renamed source file.

[scratchy.git] / burrow.scm

diff --git a/burrow.scm b/burrow.scm
new file mode 100644 (file)
index 0000000..26814d8
--- /dev/null
+++ b/burrow.scm
@@ -0,0 +1,143 @@
+(import (chicken tcp)
+        (chicken port)
+        (chicken io)
+        (chicken string)
+        (chicken pathname)
+        (chicken file posix)
+        (chicken time posix)
+        (chicken condition)
+        (chicken process)
+        (chicken process-context)
+        srfi-13)
+
+(define gopher-index-file-name "index")
+
+;;; Server loop
+;; We don't actually use worker threads here to handle requests,
+;; the server just blocks until the first request is finished.
+
+(define (make-server-config root-dir host port)
+  (list root-dir host port))
+
+(define (server-root-dir config) (list-ref config 0))
+(define (server-host config) (list-ref config 1))
+(define (server-port config) (list-ref config 2))
+
+(define (run-server config)
+  (print "Gopher server listening on port " (server-port config) " ...")
+  (let ((listener (tcp-listen (server-port config))))
+    (let server-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)))
+          (condition-case
+              (begin
+                (with-output-to-port out-port
+                  (lambda ()
+                    (serve-selector (if (= (string-length selector) 0)
+                                        "/"
+                                        selector)
+                                    config)))
+                (print "... served selector '" selector "'. Closing connection."))
+            (o (exn)
+               (print-error-message o out-port)
+               (print-error-message o)
+               (print "Error while attempting to serve selector " selector "."))))
+        (close-input-port in-port)
+        (close-output-port out-port))
+      (server-loop))
+    (tcp-close listener)))
+
+
+;;; Selector retrieval
+
+(define (directory-selector? selector)
+  (string-suffix? "/" selector))
+
+(define (text-selector? selector)
+  (apply or (map (lambda (ext) (string-suffix? ext selector))
+                 '(".txt" ".org" ".md"))))
+  
+(define (serve-selector selector config)
+  ((cond
+    ((directory-selector? selector) serve-directory)
+    ((text-selector? seletor) serve-text-file)
+    (else serve-binary-file))
+   selector config))
+
+(define (serve-directory path config)
+  (let ((file-name (make-pathname (list (server-root-dir config) path)
+                                  gopher-index-file-name)))
+    (if (regular-file? file-name)
+        (with-input-from-file file-name
+          (lambda ()
+            (let loop ((c (peek-char)))
+              (if (eof-object? c)
+                  'done
+                  (begin
+                    (if (eq? c #\,)
+                        (begin
+                          (read-char)
+                          (serve-record (read) path config)
+                          (read-line))
+                        (serve-info-record (read-line)))
+                    (loop (peek-char)))))))
+        (error "Index file not found."))))
+  
+(define (serve-text-file path config)
+  (let ((file-name (make-pathname (server-root-dir config) 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." file-name))))
+
+(define (serve-binary-file path config)
+  (let ((file-name (make-pathname (server-root-dir config) 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)))))))
+        (error "File not found." file-name))))
+
+
+;;; Index rendering
+
+(define (serve-info-record info-string)
+  (print "i" info-string "\tfake\tfake\t1\r"))
+
+;;; main
+
+(define (main)
+  (let ((progname (car (argv)))
+        (args (cdr (argv))))
+    (if (or (< (length args) 2)
+            (equal? (car args) "-h")
+            (equal? (car args) "--help"))
+        (print "Usage:\n"
+               progname " -h/--help\n"
+               progname " gopher-root-dir server-hostname server-port")
+        (let ((root (car args))
+              (hostname (cadr args))
+              (port (if (= (length args) 3) (string->number (caddr args)) 70)))
+          (if port
+              (run-server (make-server-config root hostname port))
+              (error "Invalid port argument." port))))))
+
+(main)
+
+;; (define (test)
+  ;; (run-server (make-server-config "gopher-root" "localhost" 70)))
+
+;; (test)