X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=rags.scm;h=6eacfc42970f2e1a691ecbb64a71efd590139a0d;hb=316325e01f929f70c7a31b7b65cd5082ff638957;hp=177c7b5701d622c99f0c279b4da48af7be7aee1a;hpb=fdce37f4be71360bea1ebd0ed864ebffed84265d;p=rags.git

diff --git a/rags.scm b/rags.scm
index 177c7b5..6eacfc4 100644
--- a/rags.scm
+++ b/rags.scm
@@ -36,6 +36,9 @@
     ("png" "image/png")
     ("mp3" "audio/mpeg")))
 
+(define eval-env-file "eval-env.scm")
+(define eval-env (interaction-environment))
+
 (define (process-request config request-line)
   (let ((uri (uri-normalize-path-segments (absolute-uri request-line))))
     (cond
@@ -63,6 +66,9 @@
 (define (redirect-permanent new-uri)
   (print "30 " (uri->string new-uri) "\r"))
 
+(define (serve-query prompt)
+  (print "10 " prompt "\r"))
+
 (define (uri-lacks-trailing-slash? uri)
   (not (string-null? (last (uri-path uri)))))
 
@@ -90,18 +96,25 @@
     (if (directory-exists? path)
         (make-pathname path "index.gmi")
         path)))
+
+(define (ext->mime ext)
+  (let* ((mime-detected (assoc ext file-types)))
+    (cdr (if mime-detected
+             mime-detected
+             (assoc "txt" file-types)))))
+
+(define (serve-document-header mime)
+  (print "20 " (string-intersperse mime ";") "\r"))
     
 (define (serve-document config uri)
   (let* ((path (document-path config uri))
          (ext (pathname-extension path))
-         (mime-detected (assoc ext file-types))
-         (mime (if mime-detected mime-detected (assoc "txt" file-types)))
-         (mime-type (cadr mime)))
-    (print "20 " (string-intersperse (cdr mime) ";") "\r")
+         (mime (ext->mime ext)))
+    (serve-document-header mime)
     (cond 
      ((file-executable? path)
       (serve-text-dynamic path)) ; Binary-files can also be generated here, but the source is dynamic text
-     ((string-prefix? "text/" mime-type)
+     ((string-prefix? "text/" (car mime))
       (serve-text-plain path))
      (else (serve-binary path)))))
 
@@ -134,7 +147,7 @@
      (with-current-working-directory
       working-directory
       (lambda ()
-        (eval expression))))
+        (eval expression eval-env))))
     (('shell command)
      (with-current-working-directory
       working-directory
@@ -149,9 +162,12 @@
 
 (define (serve-script config uri)
   ;; Scripts are responsible for the entire response, including header
-  (let ((path (document-path config uri)))
-    (apply (eval (with-input-from-file path read))
-           (list uri))))
+  (let* ((path (document-path config uri))
+         (proc (eval (with-input-from-file path read) eval-env)))
+    (with-current-working-directory
+     (pathname-directory (document-path config uri))
+     (lambda ()
+       (apply proc (list uri))))))
 
 (define (with-current-working-directory directory thunk)
   (let ((old-wd (current-directory))
@@ -177,13 +193,31 @@
          "Port: '" (config-port config) "'\n"
          "Root directory: '" (config-root-dir config) "'\n"
          "Cert file: '" (config-certfile config) "'\n"
-         "Key file: '" (config-keyfile config) "'\n"
-         "\n"
-         "Gemini server listening ...")
+         "Key file: '" (config-keyfile config) "'\n")
 
+  (print* "Dropping privilages ... ")
   (drop-privs config)
+  (print "done")
+
+  (print* "Setting up environment ... ")
+  (setup-env config)
+  (print "done")
+
+  (print "\nGemini server listening ...")
   (server-loop listener config))
 
+(define (setup-env config)
+  (with-current-working-directory
+   (config-root-dir config)
+   (lambda ()
+     (if (and (file-exists? eval-env-file) (file-readable? eval-env-file))
+         (with-input-from-file eval-env-file
+           (lambda ()
+             (let loop ((next-expr (read)))
+               (unless (eof-object? next-expr)
+                 (eval next-expr eval-env)
+                 (loop (read))))))))))
+
 (define (drop-privs config)
   (let ((uid (config-uid config))
         (gid (config-gid config)))
@@ -222,9 +256,9 @@
 (define (main)
   (let* ((progname (pathname-file (car (argv))))
          (config (make-config #f #f 1965 #f #f #f #f)))
-    (if (null? (cdr (argv)))
+    (if (null? (command-line-arguments))
         (print-usage progname)
-        (let loop ((args (cdr (argv))))
+        (let loop ((args (command-line-arguments)))
           (let ((this-arg (car args))
                 (rest-args (cdr args)))
             (if (string-prefix? "-" this-arg)