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

diff --git a/burrow.scm b/burrow.scm
index 9e01845..bb21e3a 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-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)))
+    (set! result (thunk))
+    (change-directory old-wd)
+    result))
 
-(define (with-selector-dir selector thunk)
-  (with-current-working-directory (pathname-directory selector) thunk))
+(define (with-selector-dir selector config thunk)
+  (with-current-working-directory
+   (make-pathname (config-root-dir config)
+                  (pathname-directory selector)) thunk))
 
 ;;; main
 
@@ -230,7 +245,6 @@
               (begin
                 (config-display-footer-set! config #f)
                 (set! args (cdr args))))
-          (print args)
           (if (or (< (length args) 2)
                   (> (length args) 3))
               (print-usage progname)
@@ -241,9 +255,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)