Added dynamic elements, av-98 also connecting.

diff --git a/gratchy.scm b/gratchy.scm
index 9424a38..6237534 100644 (file)
--- a/gratchy.scm
+++ b/gratchy.scm
@@ -4,13 +4,11 @@
         (chicken string)
         (chicken pathname)
         (chicken condition)
         (chicken string)
         (chicken pathname)
         (chicken condition)

+        (chicken time posix)
+        (chicken process)

         (chicken process-context)
         matchable srfi-13
         (chicken process-context)
         matchable srfi-13

-        uri-common openssl)
-
-(define SERVER-ROOT "public_gemini")
-(define SERVER-HOST "localhost")
-(define SERVER-HOST 1965)
+        uri-common tcp6 openssl)

 
 (define-record config
   root-dir host port certfile keyfile) 
 
 (define-record config
   root-dir host port certfile keyfile) 


@@ -20,7 +18,6 @@
     ("txt" "text/plain" "charset=utf-8")))
 
 (define (process-request config request-line)
     ("txt" "text/plain" "charset=utf-8")))
 
 (define (process-request config request-line)

-  ;; (condition-case

   (let ((uri (uri-normalize-path-segments (absolute-uri request-line))))
     (cond
      ((not (eq? (uri-scheme uri) 'gemini))
   (let ((uri (uri-normalize-path-segments (absolute-uri request-line))))
     (cond
      ((not (eq? (uri-scheme uri) 'gemini))


@@ -35,9 +32,6 @@
       (fail-permanent "Document not found."))
      (else 
       (serve-document config uri)))))
       (fail-permanent "Document not found."))
      (else 
       (serve-document config uri)))))

-  ;; (o (exn)
-  ;;    (print ((condition-property-accessor 'exn 'message) o))
-  ;;    (fail-permanent "Failed to parse URL."))))

 
 (define (fail-permanent reason)
   (print "50 " reason "\r"))
 
 (define (fail-permanent reason)
   (print "50 " reason "\r"))


@@ -60,7 +54,7 @@
          (mime-type (cadr mime)))
     (print "20 " (string-intersperse (cdr mime) ";") "\r")
     (cond 
          (mime-type (cadr mime)))
     (print "20 " (string-intersperse (cdr mime) ";") "\r")
     (cond 

-      ((equal? mime-type "text/gemini") (serve-text-plain path))
+      ((equal? mime-type "text/gemini") (serve-dynamic-gemini path))

       ((equal? mime-type "text/plain") (serve-text-plain path))
       (else (serve-binary)))))
 
       ((equal? mime-type "text/plain") (serve-text-plain path))
       (else (serve-binary)))))
 


@@ -72,12 +66,59 @@
           (print* str)
           (loop (read-string)))))))
 
           (print* str)
           (loop (read-string)))))))
 

+(define (serve-dynamic-gemini path)
+  (with-input-from-file path
+    (lambda ()
+      (let loop ((c (peek-char)))
+        (if (eof-object? c)
+            'done
+            (begin
+              (if (eq? c #\,)
+                  (begin
+                    (read-char)
+                    (serve-dynamic-element (read) (pathname-directory path))
+                    (read-line))
+                  (print (read-line)))
+              (loop (peek-char))))))))
+                              
+(define (serve-dynamic-element element working-directory)
+  (match element
+    (('eval expression)
+     (with-current-working-directory
+      working-directory
+      (lambda ()
+        (eval expression))))
+    (('shell command)
+     (with-current-working-directory
+      working-directory
+      (lambda ()
+        (let-values (((in-port out-port id) (process command)))
+          (let ((string (read-string #f in-port)))
+            (unless (eof-object? string)
+              (print string))
+            (close-input-port in-port)
+            (close-output-port out-port))))))
+    (else (error "Unknown element type."))))
+
+(define (with-current-working-directory directory thunk)
+  (let ((old-wd (current-directory))
+        (result 'none))
+    (condition-case
+        (begin
+          (change-directory directory)
+          (set! result (thunk))
+          (change-directory old-wd)
+          result)
+      (o (exn)
+         (change-directory old-wd)
+         (signal o)))))

 
 

-(define (run-server config)
-  (define listener (ssl-listen (config-port config)))

 
 

-  (ssl-load-certificate-chain! listener (config-certfile config))
-  (ssl-load-private-key! listener (config-keyfile config))
+(define (run-server config)
+  (define listener (ssl-listen* hostname: (config-host config)
+                                port: (config-port config)
+                                certificate: (config-certfile config)
+                                private-key: (config-keyfile config)))

 
   (print "Host: '" (config-host config) "'\n"
          "Port: '" (config-port config) "'\n"
 
   (print "Host: '" (config-host config) "'\n"
          "Port: '" (config-port config) "'\n"


@@ -87,11 +128,26 @@
          "\n"
          "Gemini server listening ...")
 
          "\n"
          "Gemini server listening ...")
 

+  (server-loop listener config))
+
+(define (server-loop listener config)

   (let-values (((in-port out-port) (ssl-accept listener)))
   (let-values (((in-port out-port) (ssl-accept listener)))

-    (let ((request-line (read-line in-port)))
-      (with-output-to-port out-port
-        (lambda ()
-          (process-request config request-line))))))
+    (let-values (((local-ip remote-ip) (tcp-addresses (ssl-port->tcp-port in-port))))
+      (print "Accepted connection from " remote-ip
+             " on " (seconds->string))
+      (condition-case
+          (let ((request-line (read-line in-port)))
+            (print* "Serving request '" request-line "' ... ")
+            (with-output-to-port out-port
+              (lambda ()
+                (process-request config request-line)))
+            (print "done."))
+        (o (exn)
+           (print-error-message o))))
+    (close-input-port in-port)
+    (close-output-port out-port))
+  (server-loop listener config))
+

 
 (define (print-usage progname)
   (print "Usage: " progname " [-h] [-p port] server-root-dir hostname certfile keyfile"))
 
 (define (print-usage progname)
   (print "Usage: " progname " [-h] [-p port] server-root-dir hostname certfile keyfile"))