X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scratchy.git;a=blobdiff_plain;f=burrow.scm;h=09b8df3fc1d602f2f2a6501d9c73da39d118e3fe;hp=26814d895f355cce086bf69e35e5cd44ed67d887;hb=bc05a238ffed02f915e8809914c1bbf0b6ed7670;hpb=7aabc06f178c6bb5f37ecb95f0f3c03375663491

diff --git a/burrow.scm b/burrow.scm
index 26814d8..09b8df3 100644
--- a/burrow.scm
+++ b/burrow.scm
@@ -8,24 +8,27 @@
         (chicken condition)
         (chicken process)
         (chicken process-context)
-        srfi-13)
+        srfi-1 srfi-13 matchable)
 
 (define gopher-index-file-name "index")
 
+(define burrow-version "1.0.0")
+
+(define burrow-footer
+  (conc "\n"
+        "--------------------------------------------------\n"
+        "Served by Burrow Gopher Server v" burrow-version "\n"
+        "Powered by Chicken Scheme!"))
+
 ;;; 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-record config root-dir host port display-footer)
 
 (define (run-server config)
-  (print "Gopher server listening on port " (server-port config) " ...")
-  (let ((listener (tcp-listen (server-port config))))
+  (print "Gopher server listening on port " (config-port config) " ...")
+  (let ((listener (tcp-listen (config-port config))))
     (let server-loop ()
       (let-values (((in-port out-port) (tcp-accept listener)))
         (let* ((line (read-line in-port))
@@ -51,44 +54,56 @@
       (server-loop))
     (tcp-close listener)))
 
+;;; Selector type inference
 
-;;; Selector retrieval
+(define (has-suffix? selector . suffixes)
+  (if (null? suffixes)
+      #f
+      (if (string-suffix? (car suffixes) selector)
+          #t
+          (apply has-suffix? selector (cdr suffixes)))))
 
-(define (directory-selector? selector)
-  (string-suffix? "/" selector))
+(define (infer-selector-type selector)
+  (let ((l (string-downcase selector)))
+    (cond
+     ((or (= (string-length l) 0) (string-suffix? "/" l)) 1)
+     ((has-suffix? l ".txt" ".org" ".md") 0)
+     ((has-suffix? l ".png" ".jpg" ".gif" ".bmp" ".tif" ".tga") 'I)
+     (else 9))))
+
+;;; Selector retrieval
 
-(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))
+  ((case (infer-selector-type selector)
+     ((1) serve-directory)
+     ((0) 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)
+  (let ((file-name (make-pathname (list (config-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)))))))
+        (begin
+          (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-records (read-line)))
+                      (loop (peek-char)))))))
+          (if (config-display-footer config)
+              (serve-info-records burrow-footer)))
         (error "Index file not found."))))
   
 (define (serve-text-file path config)
-  (let ((file-name (make-pathname (server-root-dir config) path)))
+  (let ((file-name (make-pathname (config-root-dir config) path)))
     (if (regular-file? file-name)
         (with-input-from-file file-name
           (lambda ()
@@ -99,7 +114,7 @@
         (error "File not found." file-name))))
 
 (define (serve-binary-file path config)
-  (let ((file-name (make-pathname (server-root-dir config) path)))
+  (let ((file-name (make-pathname (config-root-dir config) path)))
     (if (regular-file? file-name)
         (with-input-from-file file-name
           (lambda ()
@@ -114,30 +129,86 @@
 
 ;;; Index rendering
 
-(define (serve-info-record info-string)
-  (print "i" info-string "\tfake\tfake\t1\r"))
+(define (serve-info-records string)
+  (for-each
+   (lambda (line)
+     (print* "i")
+     (for-each (lambda (char)
+                 (print* (if (eq? char #\tab)
+                             "    "
+                             char)))
+               (string->list line))
+     (print "\tfake\tfake\t1\r"))
+   (string-split string "\n" #t)))
+
+(define (serve-record record path config)
+  (match record
+    (('shell command) (serve-shell-command command))
+    (('eval expression) (serve-expression expression))
+    (('url display-string url)
+     (print #\h display-string "\tURL:" url "\tfake\t80\r"))
+    ((type display-string selector host port)
+     (print type display-string "\t" selector "\t" host "\t" port "\r"))
+    ((type display-string selector host)
+     (serve-record (list type display-string selector host 70)
+                   path config))
+    ((type display-string selector)
+     (serve-record (list type display-string selector
+                         (config-host config) (config-port config))
+                   path config))
+    ((display-string selector)
+     (serve-record (list (infer-selector-type selector) display-string selector)
+                   path config))
+    ((selector)
+     (serve-record (list (infer-selecto-type selector) selector)
+                   path config))
+    (else (error "Unknown record type."))))
+
+(define (serve-shell-command command)
+  (let-values (((in-port out-port id) (process command)))
+    (serve-info-records (string-chomp (read-string #f in-port) "\n"))))
+
+(define (serve-expression expression)
+  (serve-info-records (conc (eval expression))))
 
 ;;; main
 
+(define (print-usage progname)
+  (print "Usage:\n"
+         progname " -h/--help\n"
+         progname " [-n/--no-footer] gopher-root-dir server-hostname [server-port]\n"
+         "\n"
+         "The -n option tells the server to not display a directory footer."))
+
 (define (main)
-  (let ((progname (car (argv)))
-        (args (cdr (argv))))
-    (if (or (< (length args) 2)
+  (let* ((progname (car (argv)))
+         (args (cdr (argv)))
+         (config (make-config '() '() 70 #t)))
+
+    (if (or (null? args)
             (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))))))
+        (print-usage progname)
+        (begin
+          (if (or (equal? (car args) "-n")
+                  (equal? (car args) "--no-footer"))
+              (begin
+                (config-display-footer-set! config #f)
+                (set! args (cdr args))))
+          (print args)
+          (if (or (< (length args) 2)
+                  (> (length args) 3))
+              (print-usage progname)
+              (begin
+                (config-root-dir-set! config (car args))
+                (config-host-set! config (cadr args))
+                (if (= (length args) 3)
+                    (config-port-set! config (string->number (caddr args))))
+                (run-server config)))))))
 
 (main)
 
 ;; (define (test)
-  ;; (run-server (make-server-config "gopher-root" "localhost" 70)))
+;;   (run-server (make-config "gopher-root" "localhost" 70 #t)))
 
 ;; (test)