scratchy.scm

   1 ;;; Scratchy gopher server
   2 ;;
   3 ;; Requires Chicken 5.0.0.
   4 ;;
   5
   6 ;;; Imports
   7
   8 (import (chicken tcp)
   9         (chicken port)
  10         (chicken io)
  11         (chicken string)
  12         (chicken pathname)
  13         (chicken file)
  14         (chicken time posix)
  15         (chicken condition)
  16         (chicken process)
  17         (chicken process-context)
  18         (chicken process-context posix)
  19         srfi-1 srfi-13 matchable)
  20
  21 ;;; Global constants
  22
  23 (define scratchy-version "1.0.0")
  24
  25 (define scratchy-footer
  26   (conc "\n"
  27         "--------------------------------------------------\n"
  28         "This gopher hole was dug using Scratchy v" scratchy-version ".\n"
  29         "Powered by Chicken Scheme!"))
  30
  31 (define gopher-index-filename "index")
  32
  33 ;;; Server loop
  34
  35 ;; We don't yet use worker threads here to handle requests,
  36 ;; the server just blocks until the first request is finished.
  37 ;; While we should fix this, it's actually probably okay, as
  38 ;; we genuinely don't expect a huge flood of gopher traffic. :-(
  39
  40 (define-record config
  41   root-dir host port display-footer user group)
  42
  43 (define (run-server config)
  44   (set-buffering-mode! (current-output-port) #:line)
  45   (let ((listener (tcp-listen (config-port config))))
  46     (print "Gopher server listening on port " (config-port config) " ...")
  47     (drop-privs config)
  48     (server-loop listener config))
  49   (tcp-close listener))
  50
  51 (define (drop-privs config)
  52   (let ((uid (config-user config))
  53         (gid (config-group config)))
  54     (if (not (null? gid)) ; Group first, since only root can switch groups.
  55         (set! (current-group-id) gid))
  56     (if (not (null? uid))
  57         (set! (current-user-id) uid))))
  58
  59 (define (server-loop listener config)
  60   (let-values (((in-port out-port) (tcp-accept listener)))
  61     (let* ((line (read-line in-port))
  62            (selector (string-trim-both line)))
  63       (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
  64         (print "Accepted connection from " remote-ip
  65                " on " (seconds->string))
  66         (condition-case
  67             (begin
  68               (with-output-to-port out-port
  69                 (lambda ()
  70                   (serve-selector (if (= (string-length selector) 0)
  71                                       "/"
  72                                       selector)
  73                                   config)))
  74               (print "... served selector '" selector "'. Closing connection."))
  75           (o (exn)
  76              (print-error-message o out-port)
  77              (print-error-message o)
  78              (print "Error while attempting to serve selector " selector ".")))))
  79     (close-input-port in-port)
  80     (close-output-port out-port))
  81   (server-loop listener config))
  82
  83 ;;; Selector type inference
  84
  85 (define (true-for-one? predicate values)
  86   (if (null? values)
  87       #f
  88       (if (predicate (car values))
  89           #t
  90           (true-for-one? predicate (cdr values)))))
  91
  92 (define (has-suffix? selector . suffixes)
  93   (true-for-one? (lambda (suffix)
  94                    (string-suffix? suffix selector))
  95                  suffixes))
  96
  97 (define (has-prefix? selector . prefixes)
  98   (true-for-one? (lambda (prefix)
  99                    (string-prefix? prefix selector))
 100                  prefixes))
 101
 102 (define (infer-selector-type selector)
 103   (let ((l (string-downcase selector)))
 104     (cond
 105      ((or (= (string-length l) 0)
 106           (string-suffix? "/" l)) 1)
 107      ((has-suffix? l ".txt" ".org" ".md") 0)
 108      ((has-suffix? l ".png" ".jpg" ".gif" ".bmp" ".tif" ".tga") 'I)
 109      ((has-suffix? l "?" "%3f") 7)
 110      ((has-prefix? l "url:" "/url:") 'h)
 111      (else 9))))
 112
 113
 114 ;;; Selector retrieval
 115
 116 (define (serve-selector raw-selector config)
 117   (let* ((selector-list (string-split raw-selector "\t"))
 118          (selector (car selector-list))
 119          (arguments (cdr selector-list)))
 120     (if (string-contains selector "|")
 121         (let ((l (string-split selector "|")))
 122           (serve-script (car l) (cdr l) config))
 123         (case (infer-selector-type selector)
 124           ((1) (serve-directory-file selector config))
 125           ((7) (let ((l (string-split selector "?")))
 126                  (serve-script (car l) arguments config)))
 127           ((0) (serve-text-file selector config))
 128           ((h) (serve-url selector config))
 129           (else (serve-binary-file selector config))))))
 130
 131 (define (legal-filename? filename config)
 132   (and (string-prefix? (config-root-dir config)
 133                        (normalize-pathname filename))
 134        (file-exists? filename)
 135        (not (directory-exists? filename))
 136        (file-readable? filename)))
 137
 138 (define (legal-script-filename? filename config)
 139   (and (legal-filename? filename config)
 140        (string-suffix? ".scm" filename)
 141        (file-executable? filename)))
 142
 143 (define (serve-directory-file selector config)
 144   (let ((filename (make-pathname (list (config-root-dir config) selector)
 145                                  gopher-index-filename)))
 146     (if (legal-filename? filename config)
 147         (begin
 148           (with-input-from-file filename
 149             (lambda ()
 150               (let loop ((c (peek-char)))
 151                 (if (eof-object? c)
 152                     'done
 153                     (begin
 154                       (if (eq? c #\,)
 155                           (begin
 156                             (read-char)
 157                             (serve-record (read) selector config)
 158                             (read-line))
 159                           (serve-info-records (read-line)))
 160                       (loop (peek-char)))))))
 161           (if (config-display-footer config)
 162               (serve-info-records scratchy-footer))
 163           (print ".\r"))
 164         (error "No legal index file not found."))))
 165
 166 (define (serve-text-file selector config)
 167   (let ((filename (make-pathname (config-root-dir config) selector)))
 168     (if (legal-filename? filename config)
 169         (begin
 170           (with-input-from-file filename
 171             (lambda ()
 172               (for-each
 173                (lambda (line)
 174                  (print line "\r"))
 175                (read-lines))))
 176           (print ".\r"))
 177         (error "File not found." filename))))
 178
 179 (define (serve-binary-file selector config)
 180   (let ((filename (make-pathname (config-root-dir config) selector)))
 181     (if (legal-filename? filename config)
 182         (with-input-from-file filename
 183           (lambda ()
 184             (let loop ((b (read-byte)))
 185               (if (eof-object? b)
 186                   'done
 187                   (begin
 188                     (write-byte b)
 189                     (loop (read-byte)))))))
 190         (error "File not found." filename))))
 191
 192 (define (serve-url selector config)
 193   (let ((url (substring selector 4)))
 194     (print
 195      "<html><head><title>Redirection</title>"
 196      "<meta http-equiv=\"refresh\" content=\"10; URL='" url "'\" />"
 197      "</head><body>"
 198      "<p>If you are seeing this page, your gopher browser does not "
 199      "properly support URL directory entries or cannot follow such "
 200      "links.</p>"
 201      "<p>If you are viewing this page using a web browser, you should "
 202      "be redirected shortly.  Otherwise, you can manually open the "
 203      "the follwing url:\n"
 204      "\n"
 205      "<a href=\"" url "\">" url "</a>\n"
 206      "</body></html>")))
 207
 208 (define (serve-script selector arguments config)
 209   (let ((filename (make-pathname (config-root-dir config) selector)))
 210     (if (legal-script-filename? filename config)
 211         (let* ((sexp (with-input-from-file filename read))
 212                (script-result (with-selector-dir
 213                                selector config
 214                                (lambda ()
 215                                  (apply (eval sexp) arguments)))))
 216           (when (pair? script-result)
 217             (serve-records script-result
 218                            (pathname-directory selector) config)
 219             (print ".\r")))
 220         (error "No legal index script not found." filename))))
 221
 222
 223 ;;; Index rendering
 224
 225 (define (serve-records records dir-selector config)
 226   (for-each
 227    (lambda (record)
 228      (serve-record record dir-selector config))
 229    records))
 230
 231 (define (serve-info-records string)
 232   (for-each
 233    (lambda (line)
 234      (print* "i")
 235      (for-each (lambda (char)
 236                  (print* (if (eq? char #\tab)
 237                              "    "
 238                              char)))
 239                (string->list line))
 240      (print "\tfake\tfake\t1\r"))
 241    (string-split string "\n" #t)))
 242
 243 (define (serve-record record dir-selector config)
 244   (match record
 245     ((? string?) (serve-info-records record))
 246     (('shell command) (serve-shell-command command dir-selector config))
 247     (('eval expression) (serve-expression expression dir-selector config))
 248     (('url display-string url)
 249      (print #\h display-string "\tURL:" url
 250             "\t" (config-host config)
 251             "\t" (config-port config) "\r"))
 252     ((type display-string selector host port)
 253      (print type display-string "\t" selector "\t" host "\t" port "\r"))
 254     ((type display-string selector host)
 255      (serve-record (list type display-string selector host 70)
 256                    dir-selector config))
 257     ((type display-string selector)
 258      (serve-record (list type display-string
 259                          (make-pathname dir-selector selector)
 260                          (config-host config) (config-port config))
 261                    dir-selector config))
 262     ((display-string selector)
 263      (serve-record (list (infer-selector-type selector) display-string selector)
 264                    dir-selector config))
 265     ((selector)
 266      (serve-record (list (infer-selector-type selector) selector)
 267                    dir-selector config))
 268     (else (error "Unknown record type."))))
 269
 270 (define (serve-shell-command command dir-selector config)
 271   (with-selector-dir
 272    dir-selector config
 273    (lambda ()
 274      (let-values (((in-port out-port id) (process command)))
 275        (let ((string (read-string #f in-port)))
 276          (if (and (not (eof-object? string))
 277                   (> (string-length string) 0))
 278              (serve-info-records (string-chomp string "\n")))
 279          (close-input-port in-port)
 280          (close-output-port out-port))))))
 281
 282 (define (serve-expression expression dir-selector config)
 283   (with-selector-dir
 284    dir-selector config
 285    (lambda ()
 286      (serve-records (eval expression) dir-selector config))))
 287
 288
 289 ;;; Utility methods
 290
 291 (define (with-current-working-directory directory thunk)
 292   (let ((old-wd (current-directory))
 293         (result 'none))
 294     (condition-case
 295         (begin
 296           (change-directory directory)
 297           (set! result (thunk))
 298           (change-directory old-wd)
 299           result)
 300       (o (exn)
 301          (change-directory old-wd)
 302          (signal o)))))
 303
 304 (define (with-selector-dir selector config thunk)
 305   (with-current-working-directory
 306    (make-pathname (config-root-dir config)
 307                   (pathname-directory selector)) thunk))
 308
 309
 310 ;;; Main
 311
 312 (define (print-usage progname)
 313   (print "Usage:\n"
 314          progname " -h/--help\n"
 315          progname " [-n/--no-footer] [-u/--user UID] [-g/--group GID] root-dir hostname [port]\n"
 316          "\n"
 317          "The -n option tells the server to not display a directory footer."
 318          "The -u and -g can be used to set the UID and GID of the process following"
 319          "the creation of the TCP port listener (which often requires root)."))
 320
 321 (define (main)
 322   (let* ((progname (car (argv)))
 323          (config (make-config '() '() 70 #t '() '())))
 324     (if (null? (cdr (argv)))
 325         (print-usage progname)
 326         (let loop ((args (cdr (argv))))
 327           (let ((this-arg (car args))
 328                 (rest-args (cdr args)))
 329             (if (string-prefix? "-" this-arg)
 330                 (cond
 331                  ((or (equal? this-arg "-h")
 332                       (equal? this-arg "--help"))
 333                   (print-usage progname))
 334                  ((or (equal? this-arg "-n")
 335                       (equal? this-arg "--no-footer"))
 336                   (config-display-footer-set! config #f)
 337                   (loop rest-args))
 338                  ((or (equal? this-arg "-u")
 339                       (equal? this-arg "--user"))
 340                   (config-user-set! config (string->number (car rest-args)))
 341                   (loop (cdr rest-args)))
 342                  ((or (equal? this-arg "-g")
 343                       (equal? this-arg "--group"))
 344                   (config-group-set! config (string->number (car rest-args)))
 345                   (loop (cdr rest-args)))
 346                  (else
 347                   (print-usage progname)))
 348                 (begin
 349                   (config-root-dir-set! config (car args))
 350                   (config-host-set! config (cadr args))
 351                   (if (>= (length rest-args) 2)
 352                       (config-port-set! config (string->number (caddr args))))
 353                   (run-server config))))))))
 354
 355 (main)
 356
 357 ;; (define (test)
 358 ;;   (run-server (make-config "gopher-root" "localhost" 70 #t '() '())))
 359
 360 ;; (test)