Content-type: text/html
#!/usr/bin/newlisp
;
; httpd - web server v.4.1
; v 4.1 - change 'integer' to 'int'
; handles cgi but no cookies
;
; does GET and POST requests
;
; USAGE: httpd portNo rootDir
;
; EXAMPLE Linux: httpd 80 /home/httpd/html/
; 
; EXAMPLE Win32: newlisp.exe httpd 80 /home/httpd/html/
;

(context 'HTTPD)

(define version "4.1")

(define debug-flag nil)

(set 'os (& 0xF (last (sys-info))))

(set 'exe-extensions '(
	"cgi"
	"lsp"))

(set 'default-files '("index.html" "index.cgi"))

(set 'mime-types '(
  ("txt" "text/plain")
  ("html" "text/html")
  ("shtml" "text/html")
  ("htm" "text/html")
  ("gif" "image/gif")
  ("jpg" "image/jpeg")
  ("jpeg" "image/jpeg")
  ("png" "image/png")
  ("jar" "application/java-archive")
  ("class" "application/java")
  ("pdf" "application/pdf")))


(set 'cgi-header (append
    "HTTP/1.0 200 OK\r\n"
    "Server: newLISP v." (string (nth -2 (sys-info))) " HTTPD v." version "\r\n"))

(define (startServer port dir)
  (if (not (set 'socket (net-listen (int port)))) 
    (print "Listen failed: " (net-error) "\n") 
    (begin
      (set 'online true)
        (set 'root-dir dir)
        (print "Server started listening on port: " port "\n")
        (print "Root directory: " root-dir "\n")
        (if (not (change-dir root-dir))
		(begin
			(println "Could not change to: " root-dir)
			(exit)))
        (net-server-accept socket))))

(define (net-server-accept listenSocket)
  (while online 
    (if (set 'connection (net-accept listenSocket))
      (begin
        (if (net-receive connection 'buff 2024 "\r\n\r\n")
          (begin
            (process-http-request buff)
            (net-close connection)))))))

(define (process-http-request request)
  (set 'request-type (first (parse request)))
  (if debug-flag (print request))
  (log-request request)
  (case request-type
    ("GET" (process-GET-request request))
    ("POST" (process-POST-request request))
    ("HEAD" (process-HEAD-request request))
    (true (html-error 400 "Cannot handle request"))))


(define (process-GET-request request)
  (set 'query (nth 1 (parse (first (parse request "\r\n")) " ")))

  (if (starts-with query "http://" nil) 
    (begin
      (set 'query (slice query 7))
      (set 'query (slice query (find "/" query)))))

  (set 'query (slice query 1))
  (if (= query "") 
    (begin
      (set 'query (first default-files))
      (dolist (fle default-files)
        (if (file? fle) (set 'query fle)))))

  (if (set 'pos (find "?" query))
    (begin
      (set 'queryData (slice query (+ pos 1)))
	(env "QUERY_STRING" queryData)
	 (set 'query (first (parse query "?")))
      (execute-file query (append queryData "\r\n")))
    (begin	
	(env "QUERY_STRING" "")
      (if (find {.*\.\..*} query 0)
        (html-error 405 "Access not allowed")
	  (if (has-exe-extension query)
		(execute-file query "")
  		(send-file query))))))


(define (process-POST-request request)
  (if (find ".*content-length:(.*)" request 1)
    (begin
        (set 'contentLength (int (trim $1)))
        (set 'postData (receive-POST-data contentLength))) 
    (set 'postData (net-receive connection 'data 1024)))
  (if debug-flag (print postData "\n"))
  (set 'query (nth 1 (parse (first (parse request "\r\n")))))
  (if (find {.*\.\..*} query 0)
    (html-error 405 "Access not allowed")
    (execute-file query postData)))

(define (receive-POST-data len)
  (set 'page '(""))
  (set 'receivedBytes 0)
  (set 'bytes 0)
  (while (and bytes (< receivedBytes len))
    (if (set 'bytes (net-receive connection 'data len))
	(inc 'receivedBytes bytes))
    (push data page))
  ; drain socket 
  (while (net-select connection "read" 500)
	(net-receive connection 'data 1024))
  (join (reverse page)))

(define (process-HEAD-request request)
  (html-error 400 "Cannot handle request"))

(define (has-exe-extension fileName)
  (find (extension fileName) exe-extensions))

(define (extension fname)
  (if (find ".*\\.(.*)" fname 0) 
   (trim $1) ""))

(define (send-file fileName)
  (set 'ext (extension fileName))
  (if (not (set 'mime-type (assoc ext mime-types)))
    (html-error 405 "Filetype not allowed")
    (begin
      (set 'buffer (read-file fileName))
      (if (not buffer)
        (html-error 404 (append "File not found: " fileName) )
        (begin
          (set 'header (make-header mime-type fileName))
          (net-send connection header)
          (net-send connection buffer))))))

(define (make-header mimeType fileName)
  (append "HTTP/1.0 200 OK\r\n"
          "Server: newLISP HTTPD v." version "\r\n"
          "Content-type: " (nth 1 mimeType) "\r\n"
          "Content-length: "
          (string (first (file-info fileName)))
          "\r\n\r\n"))

(define (execute-file fileName data)
  (if (starts-with fileName "/") (set 'fileName (slice fileName 1)))
  (if (not (file? (append "./" fileName)))
    (html-error 404 (append "File not found: ./" fileName) )
    (begin
      (if (or (= os 5) (= os 6))
        (set 'procStr (append "newlisp ./" fileName " > /tmp/pcgi" )) ;; for win32
        (set 'procStr (append "./" fileName " > /tmp/pcgi" )))         ;; for UNIX
      (if debug-flag (println procStr))
      (exec procStr data)
      (set 'buffer (read-file "/tmp/pcgi"))
      (replace "\r\r\n" buffer "\r\n")
      (set 'header "HTTP/1.0 200 OK\r\n")
      (if (not buffer)
        (html-error 400 "Cannot handle request")
        (begin
            (net-send connection cgi-header)
            (net-send connection buffer))))))

(define (log-request request)
  (print (date (apply date-value (now))) " " 
    (first (net-peer connection)) " "
    (first (parse request "\r\n")) "\n" ))
  
(define (html-error error-no error-txt)
  (set 'header "HTTP/1.0 200 OK\r\nContent-type: text/html\r\n\r\n")
  (set 'message (append
    "<HTML><H1>newLISP v." (string (nth -2 (sys-info))) " HTTPD v." version "<BR>"
    "Error: "  (string error-no) " " error-txt "<BR></H1></HTML>"))
  (set 'buffer (append header message ))
  (net-send connection buffer))

(context 'MAIN)

### MAIN ENTRY POINT ###
(set 'params (main-args))
(if (< (length params) 3) 
	(begin
		(print "USAGE: httpd portNumber rootDirectory\n")
		(exit)))

(print (HTTPD:startServer (nth 2 params) (nth 3 params)))
(exit)

# eof



syntax highlighting with newLISP and syntax.cgi