X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scratchy.git;a=blobdiff_plain;f=burrow.scm;h=6be32516910c8e6da9507f9939e6e25a020bfb99;hp=9e01845dbdb701ea9a41f8f6bb59bc70d12c0cdc;hb=074b068f25de41249ab1c76293ce5765960b19bb;hpb=85202d014fa114989cb619e48bc815cac870d1d3

diff --git a/burrow.scm b/burrow.scm
index 9e01845..6be3251 100644
--- a/burrow.scm
+++ b/burrow.scm
@@ -87,12 +87,12 @@
          (selector (car selector-list))
          (arguments (cdr selector-list)))
     (case (infer-selector-type selector)
-      ((1) (serve-directory selector config))
+      ((1) (serve-directory selector remote-ip config))
       ((0) (serve-text-file selector config))
       ((7) (serve-query selector arguments remote-ip config))
       (else (serve-binary-file selector config)))))
 
-(define (serve-directory selector config)
+(define (serve-directory selector remote-ip config)
   (let ((file-name (make-pathname (list (config-root-dir config) selector)
                                   gopher-index-file-name)))
     (if (regular-file? file-name)
@@ -106,7 +106,7 @@
                       (if (eq? c #\,)
                           (begin
                             (read-char)
-                            (serve-record (read) selector config)
+                            (serve-record (read) selector remote-ip config)
                             (read-line))
                           (serve-info-records (read-line)))
                       (loop (peek-char)))))))
@@ -145,8 +145,12 @@
              (= (length arguments) 1))
         (with-input-from-file file-name
           (lambda ()
-            (serve-info-records (apply (eval (read))
-                                       (list (car arguments) remote-ip)))))
+            (serve-info-records
+             (with-selector-dir
+              selector config
+              (lambda ()
+                (apply (eval (read))
+                       (list (car arguments) remote-ip)))))))
         (error "Invalid query."))))
 
 
@@ -164,47 +168,58 @@
      (print "\tfake\tfake\t1\r"))
    (string-split string "\n" #t)))
 
-(define (serve-record record path config)
+(define (serve-record record dir-selector config)
   (match record
-    (('shell command) (serve-shell-command command))
-    (('eval expression) (serve-expression expression))
+    (('shell command) (serve-shell-command command dir-selector config))
+    (('eval expression) (serve-expression expression dir-selector config))
     (('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))
+                   dir-selector config))
     ((type display-string selector)
-     (serve-record (list type display-string selector
+     (serve-record (list type display-string
+                         (make-pathname dir-selector selector)
                          (config-host config) (config-port config))
-                   path config))
+                   dir-selector config))
     ((display-string selector)
      (serve-record (list (infer-selector-type selector) display-string selector)
-                   path config))
+                   dir-selector config))
     ((selector)
      (serve-record (list (infer-selecto-type selector) selector)
-                   path config))
+                   dir-selector 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-shell-command command dir-selector config)
+  (with-selector-dir
+   dir-selector config
+   (lambda ()
+     (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))))
+(define (serve-expression expression dir-selector config)
+  (with-selector-dir
+   dir-selector config
+   (lambda ()
+     (serve-info-records (conc (eval expression))))))
 
 
 ;;; Utility methods
 
 (define (with-current-working-directory directory thunk)
-  (let ((old-wd (current-directory)))
+  (let ((old-wd (current-directory))
+        (result 'none))
     (change-directory directory)
-    (thunk)
-    (change-directory old-wd)))
-
-(define (with-selector-dir selector thunk)
-  (with-current-working-directory (pathname-directory selector) thunk))
+    (set! result (thunk))
+    (change-directory old-wd)
+    result))
+
+(define (with-selector-dir selector config thunk)
+  (with-current-working-directory
+   (make-pathname (config-root-dir config)
+                  (pathname-directory selector)) thunk))
 
 ;;; main