(in-package :uri)

(defclass uri ()
  ((scheme :accessor uri-scheme :initarg :scheme :initform nil)
   (host :accessor uri-host :initarg :host :initform nil)
   (port :accessor uri-port :initarg :port :initform nil)
   (path :accessor uri-path :initarg :path :initform nil)
   (query :accessor uri-query :initarg :query :initform nil)
   (fragment :accessor uri-fragment :initarg :fragment :initform nil)
   parsed-path
   parsed-query
   namestring))

(defmethod uri-scheme ((uri string))
  (uri-scheme (parse-uri uri)))

(defmethod uri-host ((uri string))
  (uri-host (parse-uri uri)))

(defmethod uri-port ((uri string))
  (uri-port (parse-uri uri)))

(defmethod uri-path ((uri string))
  (uri-path (parse-uri uri)))

(defmethod uri-query ((uri string))
  (uri-query (parse-uri uri)))

(defmethod uri-fragment ((uri string))
  (uri-fragment (parse-uri uri)))

(defun parse-path (string)
  (collecting
    (let ((start 0))
      (if (char= (char string 0) #\/)
	  (progn
	    (collect :absolute)
	    (incf start))
	  (collect :relative))
      (loop for end = (position #\/ string :start start)
	    do (collect (http:uri-decode (subseq string start end)))
	    while end do (setf start (1+ end))))))

(defun encode-path (path &optional stream)
  (with-output (stream)
    (when (eq (first path) :absolute)
      (write-char #\/ stream))
    (loop for (component . rest) on (rest path) do
	  (http:uri-encode component stream)
	  (when rest (write-char #\/ stream)))))

(defmethod uri-parsed-path ((uri uri))
  (with-caching-slot (uri 'parsed-path)
    (whereas ((path (uri-path uri)))
      (parse-path path))))

(defmethod uri-parsed-path ((uri string))
  (uri-parsed-path (parse-uri uri)))

(defmethod (setf uri-parsed-path) (path (uri uri))
  (setf (uri-path uri) (encode-path path)
	(slot-value uri 'parsed-path) path))

(defun uri-name (uri)
  (whereas ((name (car (last (uri-parsed-path uri)))))
    (when (plusp (length name))
      name)))

(defun uri-type (uri)
  (whereas ((name (uri-name uri))
	    (start (1+ (or (position #\. name :from-end t) 0))))
    (when (and (> start 1) (< start (length name)))
      (subseq name start))))

(defmethod uri-parsed-query ((uri uri))
  (with-caching-slot (uri 'parsed-query)
    (whereas ((query (uri-query uri)))
      (http:decode-alist query))))

(defmethod uri-parsed-query ((uri string))
  (uri-parsed-query (parse-uri uri)))

(defmethod (setf uri-parsed-query) (query (uri uri))
  (setf (uri-query uri) (http:encode-alist query)
	(slot-value uri 'parsed-query) query))

(defun uri-query-value (uri name)
  (cdr (assoc name (uri-parsed-query uri) :test #'string-equal)))

(defmethod initialize-instance :after ((uri uri) &key &allow-other-keys)
  (whereas ((path (uri-path uri)))
    (when (consp path)
      (setf (uri-parsed-path uri) path)))
  (whereas ((query (uri-query uri)))
    (when (consp query)
      (setf (uri-parsed-query uri) query))))

(defun merge-uris (uri base &key result directory)
  (unless result
    (setf result (make-instance 'uri)))
  (when (stringp uri)
    (setf uri (parse-uri uri)))
  (when (stringp base)
    (setf base (parse-uri base)))
  (when (uri-scheme uri)
    (return-from merge-uris uri))
  (let ((base-path (uri-path base))
	(result (make-instance 'uri)))
    (setf (uri-scheme result) (uri-scheme base)
	  (uri-host result) (or (uri-host uri) (uri-host base))
	  (uri-port result) (or (uri-port uri) (uri-port base))
	  (uri-query result) (or (uri-query uri) (uri-query base))
	  (uri-fragment result) (or (uri-fragment uri) (uri-fragment base)))
    (when (or (not base-path) (eq (car (uri-parsed-path uri)) :absolute))
      (return-from merge-uris result))
    (prog1 result
      (let ((end (position #\/ base-path :from-end t)))
	(when (or directory end)
	  (setf (uri-path result)
		(with-output-to-string (stream)
		  (if directory
		      (progn
			(write-string base-path stream)
			(unless (and end (= end (1- (length base-path))))
			  (write-char #\/ stream)))
		      (write-string base-path stream :end (1+ end)))
		  (write-string (uri-path uri) stream))))))))

(defun parse-uri (string)
  (let (scheme
	host
	port
	path
	query
	fragment
	(start 0)
	token)
    (macrolet ((read-token (&rest stop-at)
		 (unless stop-at
		   (setf stop-at '(#\: #\/ #\? #\#)))
		 (with-unique-names (end char)
		   `(when start
		      (let ((,end ,(when (first stop-at)
				     `(position-if
				       #'(lambda (,char)
					   (case ,char
					     (,stop-at t)))
				       string
				       :start start))))
			(if (and ,end (= ,end start))
			    (progn
			      (setf start (1+ ,end))
			      (char string ,end))
			    (progn
			      (setf token (subseq string start ,end) start ,end)
			      token))))))
	       (maybe-advance (&body body)
		 (with-unique-names (s r)
		   `(let ((,s start)
			  (,r (progn ,@body)))
		      (prog1 ,r
			(unless ,r
			  (setf start ,s)))))))
	(when (maybe-advance
	       (and (stringp (read-token))
		    (eql (read-token) #\:)))
	  (setf scheme token)
	  (when (maybe-advance
		 (and (eql (read-token) #\/)
		      (eql (read-token) #\/)
		      (stringp (read-token))))
	    (setf host token)
	    (when (maybe-advance
		   (and (eql (read-token) #\:)
			(stringp (read-token))))
	      (setf port (parse-integer token :junk-allowed t)))))
	(when (maybe-advance
	       (stringp (read-token #\? #\#)))
	  (setf path token))
	(when (maybe-advance
	       (and (eql (read-token) #\?)
		    (stringp (read-token #\#))))
	  (setf query token))
	(when (maybe-advance
	       (and (eql (read-token) #\#)
		    (stringp (read-token nil))))
	  (setf fragment token)))
    (make-instance
     'uri
     :scheme scheme
     :host host
     :port port
     :path path
     :query query
     :fragment fragment)))

(defun uri (uri)
  (etypecase uri
    (uri uri)
    (string (parse-uri uri))))

(defun uri-namestring (uri)
  (etypecase uri
    (uri
     (with-caching-slot (uri 'namestring)
       (princ-to-string uri)))
    (string uri)))

(defun uri= (a b)
  (and (equalp (uri-scheme a) (uri-scheme b))
       (equalp (uri-host a) (uri-host b))
       (equal (uri-port a) (uri-port b))
       (equal (uri-path a) (uri-path b))
       (equal (uri-query a) (uri-query b))
       (equal (uri-fragment a) (uri-fragment b))))

(defun read-uri (stream char arg)
  (declare (ignore char arg))
  (parse-uri (read stream)))

(defmethod print-object ((uri uri) stream)
  (when *print-escape*
    (write-string "#u\"" stream))
  (with-accessors
	((scheme uri-scheme)
	 (host uri-host)
	 (port uri-port)
	 (path uri-path)
	 (query uri-query)
	 (fragment uri-fragment))
      uri
    (when (plusp (length scheme))
      (format stream "~a:" scheme)
      (when (plusp (length host))
	(format stream "//~a" host)
	(when (integerp port)
	  (format stream ":~d" port))))
    (when (plusp (length path))
      (write-string path stream))
    (when (plusp (length query))
      (write-char #\? stream)
      (print-query-string query stream))
    (when (plusp (length fragment))
      (write-char #\# stream)
      (http:uri-encode fragment stream)))
  (when *print-escape*
    (write-char #\" stream)))

(set-dispatch-macro-character #\# #\u 'read-uri)
(set-dispatch-macro-character #\# #\U 'read-uri)