scratchy.scm

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