From: Tim Vaughan <tgvaughan@gmail.com>
Date: Sat, 4 May 2019 09:24:37 +0000 (+0200)
Subject: Queries etc evaluated in correct WD.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=2a8ee3c005ad7d400e81e5652e0a033843166177;p=scratchy.git

Queries etc evaluated in correct WD.
---

diff --git a/burrow.scm b/burrow.scm
index 9e01845..700eb56 100644
--- a/burrow.scm
+++ b/burrow.scm
@@ -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-selectorconfig))
     ((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 path 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