X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scratchy.git;a=blobdiff_plain;f=scratchy.scm;fp=scratchy.scm;h=df538b43a04cc8297389f2b2c78826ac56db6fa8;hp=0000000000000000000000000000000000000000;hb=6ee5bee184695648170e6255ceea7c76cc31c581;hpb=2ee1c7c6da9e093c1722a0009c82dba5c14a0db0

diff --git a/scratchy.scm b/scratchy.scm
new file mode 100644
index 0000000..df538b4
--- /dev/null
+++ b/scratchy.scm
@@ -0,0 +1,360 @@
+;;; Scratchy gopher server
+;;
+;; Requires Chicken 5.0.0.
+;;
+
+;;; Imports
+
+(import (chicken tcp)
+        (chicken port)
+        (chicken io)
+        (chicken string)
+        (chicken pathname)
+        (chicken file)
+        (chicken time posix)
+        (chicken condition)
+        (chicken process)
+        (chicken process-context)
+        (chicken process-context posix)
+        srfi-1 srfi-13 matchable)
+
+;;; Global constants
+
+(define scratchy-version "1.0.0")
+
+(define scratchy-footer
+  (conc "\n"
+        "--------------------------------------------------\n"
+        "This gopher hole was dug using Scratchy v" scratchy-version ".\n"
+        "Powered by Chicken Scheme!"))
+
+(define gopher-index-filename "index")
+
+;;; Server loop
+
+;; We don't yet use worker threads here to handle requests,
+;; the server just blocks until the first request is finished.
+;; While we should fix this, it's actually probably okay, as
+;; we genuinely don't expect a huge flood of gopher traffic. :-(
+
+(define-record config
+  root-dir host port display-footer user group)
+
+(define (run-server config)
+  (set-buffering-mode! (current-output-port) #:line)
+  (let ((listener (tcp-listen (config-port config))))
+    (print "Gopher server listening on port " (config-port config) " ...")
+    (drop-privs config)
+    (server-loop listener config))
+  (tcp-close listener))
+
+(define (drop-privs config)
+  (let ((uid (config-user config))
+        (gid (config-group config)))
+    (if (not (null? gid)) ; Group first, since only root can switch groups.
+        (set! (current-group-id) gid))
+    (if (not (null? uid))
+        (set! (current-user-id) uid))))
+
+(define (server-loop listener config)
+  (let-values (((in-port out-port) (tcp-accept listener)))
+    (let* ((line (read-line in-port))
+           (selector (string-trim-both line)))
+      (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
+        (print "Accepted connection from " remote-ip
+               " on " (seconds->string))
+        (condition-case
+            (begin
+              (with-output-to-port out-port
+                (lambda ()
+                  (serve-selector (if (= (string-length selector) 0)
+                                      "/"
+                                      selector)
+                                  config)))
+              (print "... served selector '" selector "'. Closing connection."))
+          (o (exn)
+             (print-error-message o out-port)
+             (print-error-message o)
+             (print "Error while attempting to serve selector " selector ".")))))
+    (close-input-port in-port)
+    (close-output-port out-port))
+  (server-loop listener config))
+
+;;; Selector type inference
+
+(define (true-for-one? predicate values)
+  (if (null? values)
+      #f
+      (if (predicate (car values))
+          #t
+          (true-for-one? predicate (cdr values)))))
+
+(define (has-suffix? selector . suffixes)
+  (true-for-one? (lambda (suffix)
+                   (string-suffix? suffix selector))
+                 suffixes))
+
+(define (has-prefix? selector . prefixes)
+  (true-for-one? (lambda (prefix)
+                   (string-prefix? prefix selector))
+                 prefixes))
+
+(define (infer-selector-type selector)
+  (let ((l (string-downcase selector)))
+    (cond
+     ((or (= (string-length l) 0)
+          (string-suffix? "/" l)) 1)
+     ((has-suffix? l ".txt" ".org" ".md") 0)
+     ((has-suffix? l ".png" ".jpg" ".gif" ".bmp" ".tif" ".tga") 'I)
+     ((has-suffix? l "?" "%3f") 7)
+     ((has-prefix? l "url:" "/url:") 'h)
+     (else 9))))
+
+
+;;; Selector retrieval
+
+(define (serve-selector raw-selector config)
+  (let* ((selector-list (string-split raw-selector "\t"))
+         (selector (car selector-list))
+         (arguments (cdr selector-list)))
+    (if (string-contains selector "|")
+        (let ((l (string-split selector "|")))
+          (serve-script (car l) (cdr l) config))
+        (case (infer-selector-type selector)
+          ((1) (serve-directory-file selector config))
+          ((7) (let ((l (string-split selector "?")))
+                 (serve-script (car l) arguments config)))
+          ((0) (serve-text-file selector config))
+          ((h) (serve-url selector config))
+          (else (serve-binary-file selector config))))))
+
+(define (legal-filename? filename config)
+  (and (string-prefix? (config-root-dir config)
+                       (normalize-pathname filename))
+       (file-exists? filename)
+       (not (directory-exists? filename))
+       (file-readable? filename)))
+
+(define (legal-script-filename? filename config)
+  (and (legal-filename? filename config)
+       (string-suffix? ".scm" filename)
+       (file-executable? filename)))
+
+(define (serve-directory-file selector config)
+  (let ((filename (make-pathname (list (config-root-dir config) selector)
+                                 gopher-index-filename)))
+    (if (legal-filename? filename config)
+        (begin
+          (with-input-from-file filename
+            (lambda ()
+              (let loop ((c (peek-char)))
+                (if (eof-object? c)
+                    'done
+                    (begin
+                      (if (eq? c #\,)
+                          (begin
+                            (read-char)
+                            (serve-record (read) selector config)
+                            (read-line))
+                          (serve-info-records (read-line)))
+                      (loop (peek-char)))))))
+          (if (config-display-footer config)
+              (serve-info-records scratchy-footer))
+          (print ".\r"))
+        (error "No legal index file not found."))))
+  
+(define (serve-text-file selector config)
+  (let ((filename (make-pathname (config-root-dir config) selector)))
+    (if (legal-filename? filename config)
+        (begin
+          (with-input-from-file filename
+            (lambda ()
+              (for-each
+               (lambda (line)
+                 (print line "\r"))
+               (read-lines))))
+          (print ".\r"))
+        (error "File not found." filename))))
+
+(define (serve-binary-file selector config)
+  (let ((filename (make-pathname (config-root-dir config) selector)))
+    (if (legal-filename? filename config)
+        (with-input-from-file filename
+          (lambda ()
+            (let loop ((b (read-byte)))
+              (if (eof-object? b)
+                  'done
+                  (begin
+                    (write-byte b)
+                    (loop (read-byte)))))))
+        (error "File not found." filename))))
+
+(define (serve-url selector config)
+  (let ((url (substring selector 4)))
+    (print
+     "<html><head><title>Redirection</title>"
+     "<meta http-equiv=\"refresh\" content=\"10; URL='" url "'\" />"
+     "</head><body>"
+     "<p>If you are seeing this page, your gopher browser does not "
+     "properly support URL directory entries or cannot follow such "
+     "links.</p>"
+     "<p>If you are viewing this page using a web browser, you should "
+     "be redirected shortly.  Otherwise, you can manually open the "
+     "the follwing url:\n"
+     "\n"
+     "<a href=\"" url "\">" url "</a>\n"
+     "</body></html>")))
+
+(define (serve-script selector arguments config)
+  (let ((filename (make-pathname (config-root-dir config) selector)))
+    (if (legal-script-filename? filename config)
+        (let* ((sexp (with-input-from-file filename read))
+               (script-result (with-selector-dir
+                               selector config
+                               (lambda ()
+                                 (apply (eval sexp) arguments)))))
+          (when (pair? script-result)
+            (serve-records script-result
+                           (pathname-directory selector) config)
+            (print ".\r")))
+        (error "No legal index script not found." filename))))
+
+
+;;; Index rendering
+
+(define (serve-records records dir-selector config)
+  (for-each
+   (lambda (record)
+     (serve-record record dir-selector config))
+   records))
+
+(define (serve-info-records string)
+  (for-each
+   (lambda (line)
+     (print* "i")
+     (for-each (lambda (char)
+                 (print* (if (eq? char #\tab)
+                             "    "
+                             char)))
+               (string->list line))
+     (print "\tfake\tfake\t1\r"))
+   (string-split string "\n" #t)))
+
+(define (serve-record record dir-selector config)
+  (match record
+    ((? string?) (serve-info-records record))
+    (('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
+            "\t" (config-host config)
+            "\t" (config-port config) "\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)
+                   dir-selector config))
+    ((type display-string selector)
+     (serve-record (list type display-string
+                         (make-pathname dir-selector selector)
+                         (config-host config) (config-port config))
+                   dir-selector config))
+    ((display-string selector)
+     (serve-record (list (infer-selector-type selector) display-string selector)
+                   dir-selector config))
+    ((selector)
+     (serve-record (list (infer-selector-type selector) selector)
+                   dir-selector config))
+    (else (error "Unknown record type."))))
+
+(define (serve-shell-command command dir-selector config)
+  (with-selector-dir
+   dir-selector config
+   (lambda ()
+     (let-values (((in-port out-port id) (process command)))
+       (let ((string (read-string #f in-port)))
+         (if (and (not (eof-object? string))
+                  (> (string-length string) 0))
+             (serve-info-records (string-chomp string "\n")))
+         (close-input-port in-port)
+         (close-output-port out-port))))))
+
+(define (serve-expression expression dir-selector config)
+  (with-selector-dir
+   dir-selector config
+   (lambda ()
+     (serve-records (eval expression) dir-selector config))))
+
+
+;;; Utility methods
+
+(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 (with-selector-dir selector config thunk)
+  (with-current-working-directory
+   (make-pathname (config-root-dir config)
+                  (pathname-directory selector)) thunk))
+
+
+;;; Main
+
+(define (print-usage progname)
+  (print "Usage:\n"
+         progname " -h/--help\n"
+         progname " [-n/--no-footer] [-u/--user UID] [-g/--group GID] root-dir hostname [port]\n"
+         "\n"
+         "The -n option tells the server to not display a directory footer."
+         "The -u and -g can be used to set the UID and GID of the process following"
+         "the creation of the TCP port listener (which often requires root)."))
+
+(define (main)
+  (let* ((progname (car (argv)))
+         (config (make-config '() '() 70 #t '() '())))
+    (if (null? (cdr (argv)))
+        (print-usage progname)
+        (let loop ((args (cdr (argv))))
+          (let ((this-arg (car args))
+                (rest-args (cdr args)))
+            (if (string-prefix? "-" this-arg)
+                (cond
+                 ((or (equal? this-arg "-h")
+                      (equal? this-arg "--help"))
+                  (print-usage progname))
+                 ((or (equal? this-arg "-n")
+                      (equal? this-arg "--no-footer"))
+                  (config-display-footer-set! config #f)
+                  (loop rest-args))
+                 ((or (equal? this-arg "-u")
+                      (equal? this-arg "--user"))
+                  (config-user-set! config (string->number (car rest-args)))
+                  (loop (cdr rest-args)))
+                 ((or (equal? this-arg "-g")
+                      (equal? this-arg "--group"))
+                  (config-group-set! config (string->number (car rest-args)))
+                  (loop (cdr rest-args)))
+                 (else
+                  (print-usage progname)))
+                (begin
+                  (config-root-dir-set! config (car args))
+                  (config-host-set! config (cadr args))
+                  (if (>= (length rest-args) 2)
+                      (config-port-set! config (string->number (caddr args))))
+                  (run-server config))))))))
+
+(main)
+
+;; (define (test)
+;;   (run-server (make-config "gopher-root" "localhost" 70 #t '() '())))
+
+;; (test)