(in-package :http)

(defun encode-alist (alist &optional stream (separator "&"))
  (with-output (stream)
    (loop for ((key . value) . rest) on alist do
	  (uri-encode key stream)
	  (write-char #\= stream)
	  (uri-encode value stream)
	  (when rest (write-string separator stream)))))

(defun safe-char-p (char)
  (or (alphanumericp char) (case char ((#\- #\_ #\.) t))))

(defun token-char-p (char)
  (or (safe-char-p char) (case char ((#\/ #\+ #\*) t))))

(defun uri-encode (string &optional stream)
  (with-output (stream)
    (loop for char across string
	  do (cond ((char= char #\Space)
		    (write-char #\+ stream))
		   ((safe-char-p char)
		    (write-char char stream))
		   (t
		    (format stream "%~:@(~2,'0x~)" (char-code char)))))))

(defun uri-decode (string)
  (with-output-to-string (buf)
    (loop with length = (length string)
	  for i from 0 below length
	  for char = (char string i)
	  do (case char
	       (#\+ (write-char #\Space buf))
	       (#\% (when (< (+ i 2) length)
		      (let* ((x (char string (incf i)))
			     (y (char string (incf i)))
			     (code (+ (* (digit-char-p x 16) 16)
				      (digit-char-p y 16))))
			(write-char (code-char code) buf))))
	       (t (write-char char buf))))))

(defun http-get (uri &key (redirect 5))
  (when (and (plusp redirect)
	     (setf uri (uri uri))
	     (uri-host uri)
	     (string= (uri-scheme uri) "http"))
    (let ((result
	   (%http-get (uri-host uri)
		      (or (uri-port uri) 80)
		      (or (uri-path uri) "/")
		      (uri-query uri))))
      (whereas ((status (%retrieve-object result 0)))
	(if (< status 300)
	    (values (%retrieve-object result 1)
		    (%retrieve-object result 2))
	    (http-get (%retrieve-object result 1)
		      :redirect (1- redirect)))))))

(defun http-get-xml (uri)
  (multiple-value-bind (pathname content-type) (http-get uri)
    (when (and pathname (search "xml" content-type))
      (multiple-value-prog1 (xml:read-xml pathname)
	(delete-file pathname)))))