hobby-http.lsp

   1 #!/usr/bin/newlisp
   2 #
   3 # Simple HTTP service for a directory tree. Start with:
   4 #
   5 # newlisp hobby-http.lsp -c -http -d $PORT -w $TREE
   6 #
   7 # Note that it does not make automatic file indexes of directories,
   8 # and it only shows the files that are there. Some files are handled
   9 # by their file extension, such as: .avi, .cgi, .css, .gif, .htm,
  10 # .html, .jpg, .js, .mov, .mp3,.mpg, .pdf, .png, .wav, .zip. Those
  11 # files are served with appropriate mime types, except .cgi which if
  12 # executable will be executed as a near CGI 1.1 script. Other files
  13 # are served with type "text/plain".
  14
  15 ; Exit on ^C -- not cleanly
  16 (signal 2 (fn (x) (write-line 2 "Exiting") (close 3) (exit 0)))
  17
  18 ; Resolve the root path
  19 (constant 'HERE (real-path ((match '(* "-w" ? *) (main-args)) 1)))
  20
  21 ; Map absolute path
  22 (define (actual PATH)
  23   (if (starts-with PATH "/") (string HERE PATH) PATH))
  24
  25 ; Rewriting rules: add ".html" or "/index.html" to request path where
  26 ; that results in an actual file.
  27 (define (maybe-html PATH)
  28   (let ((P0 (actual PATH)) (HTML nil))
  29     (if (find ".." PATH) PATH
  30       true
  31       (if (file? (string P0 ".html")) (string PATH ".html")
  32         (file? (string P0 "/index.html"))
  33         (string PATH (if (ends-with PATH "/") "" "/") "index.html")
  34         PATH )
  35       PATH )))
  36
  37 ; Apply rewriting rules for some requests
  38 (define (tag-on-html X)
  39   (write-line 2 (string "> " X ))
  40   (setf X (if (and (string? X) (regex "^([^\\s]+) ([^ ]+) (.+)" X 0))
  41               (let ((A $1) (B $2) (C $3))
  42                 (format "%s %s %s\r\n" A (maybe-html B) C) X)))
  43   (write-line 2 (string "< " X))
  44   X)
  45
  46 (define (filter-request X)
  47   (if (starts-with X "(GET|HEAD)" 0) (tag-on-html X)
  48     "GET /403.html HTTP/1.1"))
  49
  50 (command-event filter-request)