From: Tim Vaughan <tgvaughan@gmail.com>
Date: Sat, 25 May 2019 22:24:17 +0000 (+0200)
Subject: Added directory scripts.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=fbe6d56aeb717aac844150f78d0891d913fa2346;p=scratchy.git

Added directory scripts.

Query selectors are now handled as a special case of this.
---

diff --git a/burrower.scm b/burrower.scm
index 2886a07..36820ea 100644
--- a/burrower.scm
+++ b/burrower.scm
@@ -6,7 +6,7 @@
         (chicken io)
         (chicken string)
         (chicken pathname)
-        (chicken file posix)
+        (chicken file)
         (chicken time posix)
         (chicken condition)
         (chicken process)
@@ -89,10 +89,12 @@
 (define (infer-selector-type selector)
   (let ((l (string-downcase selector)))
     (cond
-     ((or (= (string-length l) 0) (string-suffix? "/" l)) 1)
+     ((or (= (string-length l) 0)
+          (string-suffix? "/" l)
+          (string-contains l ":")) 1)
      ((has-suffix? l ".txt" ".org" ".md") 0)
      ((has-suffix? l ".png" ".jpg" ".gif" ".bmp" ".tif" ".tga") 'I)
-     ((has-suffix? l "?.scm" "%3f.scm") 7)
+     ((has-suffix? l "?" "%3f") 7)
      ((has-prefix? l "url:" "/url:") 'h)
      (else 9))))
 
@@ -104,18 +106,41 @@
          (selector (car selector-list))
          (arguments (cdr selector-list)))
     (case (infer-selector-type selector)
-      ((1) (serve-directory selector config))
+      ((1) (if (string-contains selector ":")
+               (let ((l (string-split selector ":")))
+                 (serve-directory-script (car l) (cdr l)
+                                         config))
+               (serve-directory-file selector config)))
+      ((7) (let ((l (string-split selector "?")))
+             (serve-directory-script (car l) arguments config)))
       ((0) (serve-text-file selector config))
-      ((7) (serve-query selector arguments config))
       ((h) (serve-url selector config))
       (else (serve-binary-file selector config)))))
 
 (define (legal-filename? filename config)
   (and (string-prefix? (config-root-dir config)
                        (normalize-pathname filename))
-       (regular-file? filename)))
+       (file-exists? filename)
+       (not (directory-exists? filename))
+       (file-readable? filename)))
 
-(define (serve-directory selector config)
+(define (legal-script-filename? filename config)
+  (and (legal-filename? filename config)
+       (string-suffix? ".scm" filename)
+       (file-executable? filename)))
+
+(define (serve-directory-script selector arguments config)
+  (let ((filename (make-pathname (config-root-dir config) selector)))
+    (if (legal-script-filename? filename config)
+        (let ((sexp (with-input-from-file filename read)))
+          (serve-records (with-selector-dir selector config
+                                            (lambda ()
+                                              (apply (eval sexp) arguments)))
+                         selector config)
+         (print ".\r"))
+        (error "No legal index script not found." filename))))
+
+(define (serve-directory-file selector config)
   (let ((filename (make-pathname (list (config-root-dir config) selector)
                                  gopher-index-filename)))
     (if (legal-filename? filename config)
@@ -136,7 +161,7 @@
           (if (config-display-footer config)
               (serve-info-records burrower-footer))
           (print ".\r"))
-        (error "Index file not found."))))
+        (error "No legal index file not found."))))
   
 (define (serve-text-file selector config)
   (let ((filename (make-pathname (config-root-dir config) selector)))
@@ -164,21 +189,6 @@
                     (loop (read-byte)))))))
         (error "File not found." filename))))
 
-(define (serve-query selector arguments config)
-  (let ((filename (make-pathname (config-root-dir config)
-                                 (string-translate* selector '(("%3f" . "?"))))))
-    (if (and (legal-filename? filename config)
-             (= (length arguments) 1))
-        (with-input-from-file filename
-          (lambda ()
-            (serve-info-records
-             (with-selector-dir
-              selector config
-              (lambda ()
-                (apply (eval (read)) arguments))))))
-        (error "Invalid query." selector arguments))))
-
-
 (define (serve-url selector config)
   (let ((url (substring selector 4)))
     (print
@@ -198,6 +208,12 @@
 
 ;;; Index rendering
 
+(define (serve-records records dir-selector config)
+  (for-each
+   (lambda (record)
+     (serve-record record dir-selector config))
+   records))
+
 (define (serve-info-records string)
   (for-each
    (lambda (line)
@@ -212,6 +228,7 @@
 
 (define (serve-record record dir-selector config)
   (match record
+    ((? string?) (serve-info-records record))
     (('shell command) (serve-shell-command command dir-selector config))
     (('eval expression) (serve-expression expression dir-selector config))
     (('url display-string url)
@@ -232,7 +249,7 @@
      (serve-record (list (infer-selector-type selector) display-string selector)
                    dir-selector config))
     ((selector)
-     (serve-record (list (infer-selecto-type selector) selector)
+     (serve-record (list (infer-selector-type selector) selector)
                    dir-selector config))
     (else (error "Unknown record type."))))
 
@@ -250,7 +267,7 @@
   (with-selector-dir
    dir-selector config
    (lambda ()
-     (serve-info-records (conc (eval expression))))))
+     (serve-records (eval expression) dir-selector config))))
 
 
 ;;; Utility methods
@@ -273,7 +290,8 @@
    (make-pathname (config-root-dir config)
                   (pathname-directory selector)) thunk))
 
-;;; main
+
+;;; Main
 
 (define (print-usage progname)
   (print "Usage:\n"
@@ -307,9 +325,9 @@
                     (config-port-set! config (string->number (caddr args))))
                 (run-server config)))))))
 
-;; (main)
+(main)
 
-(define (test)
-  (run-server (make-config "gopher-root" "localhost" 70 #t)))
+;; (define (test)
+;;   (run-server (make-config "gopher-root" "localhost" 70 #t)))
 
 ;; (test)