#!/afs/wsi/i386_fbsd43/bin/scsh -s
!#

;Programmieren für das Internet WS 02/03,
;Blatt2: HTTP-Server, Thomas Gärtner


;Aufgabe 1:
;-- Reguläre Ausdrücke definieren -------------------------------
(define hex (rx (/ "09AFaf")))

(define escaped (rx (: "%" ,hex ,hex)))

(define pchar (rx (| (/ "AZaz09") ("_!\"#$&'()*+,-.") ,escaped)))

(define uri (rx (+ (: "/" (+ ,pchar)))))

(define method (rx (| "OPTIONS"
		      "GET"
		      "HEAD"
		      "POST"
		      "PUT"
		      "DELETE"
		      "TRACE"
		      "CONNECT")))

(define http-version (rx (: "HTTP/" (| "0.9" "1.0" "1.1"))))

(define request-line (rx (: ,method " "  ,uri " " ,http-version)))
;----------------------------------------------------------------
(define (regexp-map re f str)
  (regexp-substitute/global #f re str 'pre f 'post))
    
(define (request-decode str)
  (if (regexp-search? request-line str)
      (let ((method (match:substring (regexp-search method str)))
	    (uri (match:substring (regexp-search uri str)))
	    (version (match:substring (regexp-search http-version str))))
	(list method (uri-decode uri) version))
	#f))

(define (uri-decode str)
  (regexp-map escaped
	      (lambda (m)
		(escaped->string 
		 (match:substring m)))
	      str))

;Escape-Zeichen in string umwandeln , z.B. "%2A" -> "*"
(define (escaped->string hex)
  (let* ((hex-list (string->list hex))
	 (1st (cadr hex-list))
	 (2nd (caddr hex-list))
	 (dec (+ (* 16 (hex->dec 1st))
		 (hex->dec 2nd))))
    (string (ascii->char dec))))

;z.B. #\b -> 11
(define (hex->dec numeral)
  (if (regexp-search? hex (string numeral))
      (case numeral
	((#\a #\A) 10)
	((#\b #\B) 11)
	((#\c #\C) 12)
	((#\d #\D) 13)
	((#\e #\E) 14)
	((#\f #\F) 15)
	(else (string->number (string numeral))))
      #f))


;Aufgabe 2-3: HTTP 1.1 - Webserver

(define (webserver port-num)
  (bind-listen-accept-loop protocol-family/internet client-request port-num))

(define (client-request c-socket client-adress)
  (let* ((inport (socket:inport c-socket))
	 (outport (socket:outport c-socket))
	 (request (read-line inport))
	 (decoded-request (request-decode request))
	 (send-status (send-status-line outport))
	 (request-header
	  (let loop ((header "")
		     (end #f))
	    (if end
		header
		(let* ((line (read-line inport))
		       (new-header (string-append header line)))
		  (if (equal? line "\r")
		      (loop new-header #t)
		      (loop new-header #f)))))))
    (if (not decoded-request)
	(send-status 400)
	(let ((method (car decoded-request))
	      (uri (cadr decoded-request))
	      (version (caddr decoded-request)))
	  (if (equal? version "HTTP/1.1")
	      (cond
	       ((equal? method "GET")
		    (if (send-header uri outport)
			(send-message-body uri outport)))
	       ((equal? method "HEAD")
		     (send-header uri outport))
	       (else (send-status 501)))
	      (send-status 505)))))
  (close-socket c-socket))


(define (status-line code)
  (case code
    ((200) "200 OK")
    ((301) "301 Moved Permanently")
    ((400) "400 Bad Request")
    ((403) "403 Forbidden")
    ((404) "404 Not Found")
    ((501) "Not Implemented")
    ((505) "HTTP Version not supported")
    (else "Unkown status code")))

(define (send-status-line port)
  (lambda (code)
    (write-string
     (string-append "HTTP/1.1 "
		    (status-line code)
		    "\r\n")
     port)))

(define (send-header uri port)
  (let* ((send-status (send-status-line port))
	 (r-uri (substring uri 1 (string-length uri))))
    (chdir home-directory)
    (if (file-exists? r-uri)
	(if (file-readable? r-uri)
	    (begin
	      (send-status 200)
	      (send-header-lines r-uri port)
	      #t)
	    (begin
	      (send-status 403)
	      #f))
	(begin
	  (send-status 404)
	  #f))))
    
(define (send-header-lines requested-uri port)
  (let ((lmodified (date->string (date (file-last-mod requested-uri))))
	(clength (number->string (file-size requested-uri)))
	(crlf "\r\n"))
    (write-string
     (string-append
      "Last-Modified: " lmodified " GMT"  crlf
      "Content-Location: /" requested-uri crlf
      "Content-Length: " clength crlf
      "Content-Type: text/plain" crlf
      crlf)
     port)))

(define (send-message-body uri port)
  (let* ((send-status (send-status-line port))
	 (r-uri (substring uri 1 (string-length uri)))
	 (content (read-file r-uri)))
    (write-string content port)))

(define (read-file fname)
  (let* ((f-in-port (open-input-file fname))
	 (content 
	  (let read-loop ((con "")
			  (in (read-string 100 f-in-port)))
	    (if in
		(read-loop (string-append con in) (read-string 100 f-in-port))
		con))))
    (close f-in-port)
    content))


;HTTP-Server starten  
(webserver 8080)