Hypertext server

Location: prog, 253 Lines

#! /usr/local/bin/s9

; s9hts -- hyper text server
; by Nils M Holm, 2010,2012
; Placed in the Public Domain
;
; Usage: s9hts [-m sec] [host [port]]

(load-from-library "inet-server.scm")
(load-from-library "url-decode.scm")
(load-from-library "split-url.scm")
(load-from-library "hash-table.scm")
(load-from-library "string-position.scm")
(load-from-library "string-parse.scm")
(load-from-library "string-unsplit.scm")
(load-from-library "string-find.scm")
(load-from-library "read-line.scm")
(load-from-library "displaystar.scm")
(load-from-library "parse-optionsb.scm")
(load-from-library "spawn-command.scm")
(load-from-library "format-time.scm")
(load-from-library "unix-time-to-time.scm")

(define show-help (option #\h #f))
(define max-req   (option #\m 'integer 5))
(define options   `(,max-req
                    ,show-help))

(define (usage)
  (display "Usage: s9hts [-m nreq] [host [port]]");
  (newline))

(define CR   (integer->char 13))
(define CRLF (string CR #\newline))

(define (status out n . type)
  (let ((msg (case n ((200) "ok")
                     ((400) "huh?")
                     ((404) "not here")
                     ((500) "oops - I blew it")
                     ((503) "bug me not"))))
    (display* out "HTTP/1.0 " n #\space msg CRLF)
    (if (not (null? type))
        (display* out "Content-type: " (car type) CRLF CRLF))))

(define (last x)
  (car (reverse x)))

(define (trim-empty a)
  (letrec
    ((trim
       (lambda (x)
         (if (and (not (null? x))
                  (equal? "" (car x)))
             (trim (cdr x))
             x))))
    (trim (reverse! (trim (reverse a))))))

(define (cant-parse out request)
  (status out 400 "text/html")
  (display* out "<H1>400 huh?</H1>" #\newline)
  (display* out "<P>Request: " request "</P>" #\newline))

(define (not-found out file)
  (status out 404 "text/html")
  (display* out "<H1>404 not here</H1>" #\newline)
  (display* out "<P>Path: " file "</P>" #\newline))

(define (bug-me-not out)
  (status out 503 "text/html")
  (display* out "<H1>503 bug me not!</H1>" #\newline))

(define (set-url-path! url path)
  (set-car! (cddr url) path))

(define (set-url-suffix! url suffix)
  (set-car! (cdddr url) suffix))

(define (local-path? s)
  (let loop ((in    (string->list s))
             (depth 0))
    (cond ((null? in))
          ((char=? #\/ (car in))
            (if (and (> (length in) 3)
                     (string=? "/.." (string (car in) (cadr in) (caddr in))))
                (if (zero? depth)
                    #f
                    (loop (cdr in) (- depth 1)))
                (loop (cdr in) (+ 1 depth))))
          (else
            (loop (cdr in) depth)))))

(define (mime-type suffix)
  (let ((table '(((#f)           "text/plain")
                 (("html" "htm") "text/html")
                 (("css")        "text/css")
                 (("jpg" "jpeg") "image/jpeg")
                 (("png")        "image/png")
                 (("gif")        "image/gif")
                 (("tar")        "application/x-tar")
                 (("gz" "tgz")   "application/x-gzip")
                 (("zip")        "application/zip"))))
    (let loop ((table table))
      (cond ((null? table)
              "application/octet-stream")
            ((member suffix (caar table))
              (cadar table))
            (else
              (loop (cdr table)))))))

(define (run-script out path args)
  (let* ((conn       (spawn-command path))
         (script-in  (car conn))
         (script-out (cadr conn))
         (args       (map (lambda (x)
                            (cons (car x)
                                  (url-decode (cdr x))))
                          args)))
    (if args
        (begin (display args script-out)
               (newline script-out)
               (close-output-port script-out)))
    (let loop ((c (read-char script-in)))
      (if (not (eof-object? c))
          (begin (write-char c out)
                 (loop (read-char script-in)))))))

(define (serve out url)
  (cond ((and (url-suffix url)
              (string=? "cgi" (url-suffix url)))
          (status out 200)
          (run-script out (url-path url) (url-args url)))
        (else
          (status out 200 (mime-type (url-suffix url)))
          (with-input-from-file
            (url-path url)
            (lambda ()
              (let loop ((c (read-char)))
                (if (not (eof-object? c))
                    (begin (write-char c out)
                           (loop (read-char))))))))))

(define (log-stuff code time peer header)
  (let ((tstp (format-time "~w ~4y-~m-~2d ~2h:~2m:~2s"
                           (unix-time->time time))))
    (display* #\" code #\"
              #\space
              #\" tstp #\"
              #\space
              #\" (if peer (car peer) "unknown") #\"
              #\space
              #\" (cadr (string-split #\space (car header))) #\"
              #\space
              #\" (get-user-agent header) #\"
              #\newline)))

(define (http-request out old time peer header)
  (let ((request (string-parse " " (car header))))
    (cond ((not (<= 2 (length request) 3))
            (log-stuff 400 time peer header)
            (cant-parse out (string-unsplit #\space request)))
          ((not (string=? "GET" (car request)))
            (log-stuff 400 time peer header)
            (cant-parse out (string-unsplit #\space request)))
          (else
            (let* ((url (split-url (cadr request)))
                   (_   (set-url-path! url
                                       (string-append "." (url-path url))))
                   (url (begin 
                          (if (and (sys:stat (url-path url))
                                   (sys:stat-directory? (url-path url)))
                              (begin (set-url-path!
                                       url
                                       (string-append (url-path url)
                                                      "/index.html"))
                                     (set-url-suffix! url "html")))
                          url)))
              (cond ((not (local-path? (url-path url)))
                      (log-stuff 503 time peer header)
                      (bug-me-not out))
                    ((file-exists? (url-path url))
                      (log-stuff 200 time peer header)
                      (serve out url))
                    (else
                      (log-stuff 404 time peer header)
                      (not-found out (cadr request)))))))))

(define (get-user-agent header)
  (let* ((uah "User-Agent: ")
         (k   (string-length uah)))
    (let loop ((h header))
      (cond ((null? h) "unidentified")
            ((and (>= (string-length (car h)) k)
                  (string-ci=? (substring (car h) 0 k) uah))
              (substring (car h) k (string-length (car h))))
            (else
              (loop (cdr h)))))))

(define (old-request? s)
  (let ((s (string-parse " " s)))
    (and (= (length s) 2)
         (>= (string-length (car s)) 3)
         (string=? "GET" (substring (car s) 0 3)))))

(define (handle-request in out peer time delta)
  (if (and delta (< delta 1))
      (bug-me-not out)
      (let loop ((line   (read-line in))
                 (header '()))
        (let* ((k    (if (eof-object? line)
                         -1
                         (- (string-length line) 1)))
               (line (if (and (not (negative? k))
                              (char=? CR (string-ref line k)))
                         (substring line 0 k)
                         line)))
          (cond ((or (eof-object? line)
                     (string=? "" line))
                  (http-request out
                                #f
                                time
                                peer
                                (reverse header)))
                ((old-request? line)
                  (handle-request out
                                  #t
                                  time
                                  peer
                                  (list line)))
                (else
                  (loop (read-line in)
                        (cons line header))))))))

(define (server)
  (let ((args (parse-options! (sys:command-line) options usage)))
    (if (opt-val show-help)
        (begin (display-usage
                 `(""
                   ,usage
                   ""
                   "Hypertext Server"
                   ""
                   "-m nreq   max. requests/second per client (default: 5)"
                   ""))
        (sys:exit 0)))
    (let ((host (if (null? args)
                    #t
                    (car args)))
          (port (if (or (null? args)
                        (null? (cdr args)))
                    "80"
                    (cadr args))))
      (inet-server host port handle-request (opt-val max-req)))))

(server)