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

diff --git a/burrow.scm b/burrow.scm
index 26814d8..c258311 100644
--- a/burrow.scm
+++ b/burrow.scm
@@ -8,7 +8,7 @@
         (chicken condition)
         (chicken process)
         (chicken process-context)
-        srfi-13)
+        srfi-1 srfi-13 matchable)
 
 (define gopher-index-file-name "index")
 
@@ -51,21 +51,30 @@
       (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)
@@ -115,7 +124,37 @@
 ;;; Index rendering
 
 (define (serve-info-record info-string)
-  (print "i" info-string "\tfake\tfake\t1\r"))
+  (print* "i")
+  (for-each (lambda (char)
+              (print* (if (eq? char #\tab)
+                          "    "
+                          char)))
+            (string->list info-string))
+  (print "\tfake\tfake\t1\r"))
+
+(define (serve-record record path config)
+  (match record
+    (('shell command) (serve-shell-command command))
+    ((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
+                         (server-host config) (server-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)))
+    (for-each serve-info-record (read-lines in-port))))
 
 ;;; main
 
@@ -138,6 +177,6 @@
 (main)
 
 ;; (define (test)
-  ;; (run-server (make-server-config "gopher-root" "localhost" 70)))
+;;   (run-server (make-server-config "gopher-root" "localhost" 70)))
 
 ;; (test)