grauwoelfchen · December 30, 2013 19:18
diff --git a/server.lisp b/server.lisp
 ;; decode

 (defun http-char (c1 c2 &optional (default #\space))
  (let ((code (parse-integer
               (coerce (list c1 c2) 'string)
               :radix 16
               :junk-allowed t)))
    (if code
      (code-char code)
      default)))

 (defun decode-param (s)
  (labels ((f (lst)
              (when lst
                (case (car lst)
                  (#\% (cons (http-char (cadr lst) (caddr lst))
                             (f (cdddr lst))))
                  (#\+ (cons #\space (f (cdr lst))))
                  (otherwise (cons (car lst) (f (cdr lst))))))))
    (coerce (f (coerce s 'list)) 'string)))

 (defun parse-params (s)
  (let ((i1 (position #\= s))
        (i2 (position #\& s)))
    (cond (i1 (cons (cons (intern (string-upcase (subseq s 0 i1)))
                          (decode-param (subseq s (1+ i1) i2)))
                    (and i2 (parse-params (subseq s (1+ i2))))))
          ((equal s "") nil)
          (t s))))


 ;; url

 (defun extract-url (s)
  (let* ((url (subseq s
                      (+ 2 (position #\space s))
                      (position #\space s :from-end t)))
         (x (position #\? url)))
    (if x
      (cons (subseq url 0 x) (parse-params (subseq url (1+ x))))
      (cons url '()))))


 ;; header

 (defun get-header (stream)
  (let* ((s (read-line stream))
         (h (let ((i (position #\: s)))
              (when i
                (cons (intern (string-upcase (subseq s 0 i)))
                      (subseq s (+ i 2)))))))
  (when h
    (cons h (get-header stream)))))


 ;; boady

 (defun get-content (stream header)
  (let ((length (cdr (assoc 'content-length header))))
    (when length
      (let ((content (make-string (parse-integer length))))
        (read-sequence content stream)
        (parse-params content)))))


 ;; server

 (defun serve (request-handler)
  (let ((socket (socket-server 8080)))
    (unwind-protect
      (loop (with-open-stream (stream (socket-accept socket))
               (let* ((url    (extract-url (read-line stream)))
                      (path   (car url))
                      (header (get-header stream))
                      (params (append (cdr url)
                                      (get-content stream header)))
                      (*standard-output* stream))
                (funcall request-handler path header params))))
       (socket-server-close socket))))


 ;; app

 (defun hello-request-handler (path header params)
  (if (equal path "")
      (let* ((head "<head><title>Hello, world!</title></head>")
             (name (assoc 'name params)))
        (format t "HTTP/1.1 200 OK~%~%")
        (if (not name)
            (format t "<html>~a<form>What's your name?<input name='name' /></form></body></html>" head)
            (format t "<html>~aNice to meet you, ~a!</html>" head (cdr name))))
      (princ "Sorry... I cannot respond to that request :-p")))
	;; decode

	(defun http-char (c1 c2 &optional (default #\space))
	(let ((code (parse-integer
	(coerce (list c1 c2) 'string)
	:radix 16
	:junk-allowed t)))
	(if code
	(code-char code)
	default)))

	(defun decode-param (s)
	(labels ((f (lst)
	(when lst
	(case (car lst)
	(#\% (cons (http-char (cadr lst) (caddr lst))
	(f (cdddr lst))))
	(#\+ (cons #\space (f (cdr lst))))
	(otherwise (cons (car lst) (f (cdr lst))))))))
	(coerce (f (coerce s 'list)) 'string)))

	(defun parse-params (s)
	(let ((i1 (position #\= s))
	(i2 (position #\& s)))
	(cond (i1 (cons (cons (intern (string-upcase (subseq s 0 i1)))
	(decode-param (subseq s (1+ i1) i2)))
	(and i2 (parse-params (subseq s (1+ i2))))))
	((equal s "") nil)
	(t s))))


	;; url

	(defun extract-url (s)
	(let* ((url (subseq s
	(+ 2 (position #\space s))
	(position #\space s :from-end t)))
	(x (position #\? url)))
	(if x
	(cons (subseq url 0 x) (parse-params (subseq url (1+ x))))
	(cons url '()))))


	;; header

	(defun get-header (stream)
	(let* ((s (read-line stream))
	(h (let ((i (position #\: s)))
	(when i
	(cons (intern (string-upcase (subseq s 0 i)))
	(subseq s (+ i 2)))))))
	(when h
	(cons h (get-header stream)))))


	;; boady

	(defun get-content (stream header)
	(let ((length (cdr (assoc 'content-length header))))
	(when length
	(let ((content (make-string (parse-integer length))))
	(read-sequence content stream)
	(parse-params content)))))


	;; server

	(defun serve (request-handler)
	(let ((socket (socket-server 8080)))
	(unwind-protect
	(loop (with-open-stream (stream (socket-accept socket))
	(let* ((url (extract-url (read-line stream)))
	(path (car url))
	(header (get-header stream))
	(params (append (cdr url)
	(get-content stream header)))
	(standard-output stream))
	(funcall request-handler path header params))))
	(socket-server-close socket))))


	;; app

	(defun hello-request-handler (path header params)
	(if (equal path "")
	(let* ((head "<head><title>Hello, world!</title></head>")
	(name (assoc 'name params)))
	(format t "HTTP/1.1 200 OK~%~%")
	(if (not name)
	(format t "<html>~a<form>What's your name?<input name='name' /></form></body></html>" head)
	(format t "<html>~aNice to meet you, ~a!</html>" head (cdr name))))
	(princ "Sorry... I cannot respond to that request :-p")))