;; TODO: Modify this parameter to match the location of Wilbur on your system.
(defparameter *wilbur-location* "/Users/sir03rn/Lisp/wilbur-rdf/")

;; ASDF is needed for loading Araneida and wilbur-ext.
(require 'asdf)
;; (require 'araneida)
(asdf::operate 'asdf::load-op 'araneida)

;; Pathnames for Wilbur.
(setf (logical-pathname-translations "wilbur")
               `(("core;*.lisp"   "wilbur:base;source;*.*")
                 ("core;*.system" "wilbur:base;source;*.*")
                 ("core;*.fasl"   "wilbur:bin;*.*")
                 ("core;*.*"      "wilbur:base;*.*")
                 ("schemata;*.*"  "wilbur:base;schemata;*.*")
                 ("base;**;*.*"   ,(concatenate 'string
					       *wilbur-location*
					       "core/**/*.*"))
                 ("bin;**;*.*"    ,(concatenate 'string
					       *wilbur-location*
					       "binaries/**/*.*"))))

;; Load Nokia's make and Wilbur itself.
(load (concatenate 'string
		   *wilbur-location*
		   "make/mm"))
(load (concatenate 'string
		   *wilbur-location*
		   "core/source/wilbur.system"))

;; Make the module.
(in-package :cl-user)
(make-module :wilbur)     

;; Load Richard's Wilbur extensions.
(asdf::operate 'asdf::load-op 'wilbur-ext)

(defpackage "URIQA"
  (:shadowing-import-from "ARANEIDA"
			  "URL-PORT"
			  "MAKE-URL"
			  "URL-PATH"
			  "URL-HOST"
			  "HTTP-URL"
			  "URL")
  (:use "CL" "ARANEIDA" "WILBUR" "WILBUR-EXT" #+openmcl "CCL"))

(in-package "URIQA")

;; TODO: do these.
(defparameter *access-url* (parse-urlstring "http://localhost:8000/"))
(defparameter *mput-prefix* "http://localhost:8000/mput/")

(eval-when (:compile-toplevel :load-toplevel :execute)
  ;; This is for using Araneida behind a reverse-proxying 
  ;; Apache (or other HTTP proxy) server.  You may need to alter the 
  ;; configuration for your local setup
  #+nil (pushnew :araneida-uses-proxy *features*)
  ;; if you have a threaded SBCL, and want to, you can use the (new,
  ;; whizzy) thread-based server instead of the (older, better tested)
  ;; SERVE-EVENT thing
  #+araneida-threads (pushnew :araneida-uses-threads *features*))

;; ARANEIDA:
#-araneida-uses-proxy
(defvar *listener*
  (make-instance #+araneida-uses-threads 'araneida::threaded-http-listener
                 #-araneida-uses-threads 'araneida::serve-event-http-listener
                 :port (araneida::url-port *access-url*)))

#+araneida-uses-proxy
(defvar *listener*
  (let ((fwd-url (araneida::copy-url *access-url*)))
    (setf (araneida::url-port fwd-url) (+ 1024 (araneida::url-port *access-url*)))
    (make-instance #+araneida-uses-threads 'araneida::threaded-reverse-proxy-listener
                   #-araneida-uses-threads 'araneida::serve-event-reverse-proxy-listener
                   :translations
                   `((,(araneida::urlstring *access-url*) ,(araneida::urlstring fwd-url)))
                   :address #(0 0 0 0)
                   :port (araneida::url-port fwd-url))))    


;; Setup Wilbur.
(setf wilbur::*db* (make-instance 'wilbur::db :emptyp t))

(defclass uriqa-handler (handler) ())
(defclass uriqa-query-handler (handler) ())

;; From rdf-serialiser.lisp
;; TODO: refactor.
(defgeneric serialise (d str out-format))

(defun s-append (s p o) 
  (format nil "~A ~A ~A ." s p o))

;;; These will soon be replaced by Wilbur2's serialiser.
(defmethod serialise (d str (out-format (eql 'label-html)))
  (if (typep d 'wilbur::db)
    (format str "<div class=\"results\"><table><caption>The serialised results of your query.</caption><thead><tr><th>Subject</th><th>Property</th><th>Object</th></tr></thead><tbody>
	    ~{~A~%~}</tbody></table></div>" 
	    (mapcar #'(lambda (x) 
			  (format nil "<tr><td>~A</td><td>~A</td><td>~A</td></tr>" 
				  (label-or-uri (triple-subject x) t d)
				  (label-or-uri (triple-predicate x) t d)
				  (if (typep (triple-object x) 'wilbur::node)
				    (label-or-uri (triple-object x) t d)
				    (literal-or-valid (triple-object x) nil))))
		    (db-triples d)))
    (format str "<div class=\"results\">There were no results for your query.</div>")))

(defmethod serialise (d str (out-format (eql 'html)))
  (if (typep d 'wilbur::db)
    (format str "<div class=\"results\"><table><caption>The serialised results of your query.</caption><thead><tr><th>Subject</th><th>Property</th><th>Object</th></tr></thead><tbody>
	    ~{~A~%~}</tbody></table></div>" 
	    (mapcar #'(lambda (x) 
			  (format nil "<tr><td>~A</td><td>~A</td><td>~A</td></tr>" 
				  (node-uri-or-bnode-id (triple-subject x)) 
				  (node-uri-or-bnode-id (triple-predicate x))
				  (literal-or-valid (triple-object x) nil)))
		    (db-triples d)))
    (format str "<div class=\"results\">There were no results for your query.</div>")))

(defmethod serialise (d str (out-format (eql 'rdf-n3)))
  (if (typep d 'wilbur::db)
    (format str "~{~A~%~}"
            (mapcar #'(lambda (y) (s-append (wilbur-ext::wrapped-node-uri-or-bnode-id (triple-subject y) )
                                            (wilbur-ext::wrapped-node-uri-or-bnode-id (triple-predicate y))
                                            (let ((ob (triple-object y)))
                                              (wilbur-ext::literal-or-wrapped-valid ob))))
                    (db-triples d)))))

(defmethod serialise (d str (out-format (eql 'rdf-xml)))
  (if (typep d 'wilbur::db)
    (let ((path (make-pathname :directory '(:absolute "tmp") 
                               :name 
                               (format nil "tmp-serialise-~A" 
                                       (get-universal-time))
                               :type "n3")))
      (with-open-file (s path :direction :output)
        (serialise d s 'rdf-n3))
      (let ((ret (format str (with-output-to-string (cwm-out)
        (run-program "cwm" `("--n3" ,(namestring path) "--rdf")
                     :output cwm-out)))))
        (delete-file path)
        ret))))                                          

(defun remove-triples (dels &optional (db *db*))
  "Remove all of the triples in dels from db.
   We expect db-del-triple not to work because they're different instances."
  (dolist (x (typecase dels 
	       (wilbur::db (db-triples dels))
	       (list dels)))
    (db-del-triple db (car
			(db-query db 
				  (triple-subject x)
				  (triple-predicate x)
				  (triple-object x))))))

(defun delete-cbd (targ &optional (db *db*))
  "Remove the CBD of the target note from the DB."
  (dolist (x (db-triples (cbd targ db)))
    (db-del-triple db x)))

;;; POST query handler. This means we have to handle the method param.
(defmethod handle-request-response ((handler uriqa-query-handler)
				    (method (eql :post)) request)
  (let* ((pairs (url-query-alist (request-url request)))
	 (uri (cadr (assoc "uri" pairs :test #'string=)))
	 (target-node (if uri
			(node uri))))
    (if target-node
      (let ((meth (cadr (assoc "method" pairs :test #'string=)))
	    (parsed-body 
	      (let ((body-text (request-body request)))
		(if (stringp body-text)
		  (wilbur-ext::rdf->db body-text
				       (make-unique-uri *mput-prefix*))))))
	(cond
	  ((or (null meth) (string-equal meth "MGET"))
	   ;; MGET.
	   (request-send-headers request :content-type "application/rdf+xml")
	   (serialise (cbd target-node) (request-stream request) 'rdf-xml)
	   t)
	  ((string-equal meth "MPUT")
	   ;; MPUT.
	   (if parsed-body
	     (progn
	       ;; For security, we only add the CBD of the target node from
	       ;; the parsed body. This might be the whole DB, but hey.
	       (db-merge *db* (cbd target-node parsed-body))
	       (request-send-headers request)
	       (format (request-stream request) "RDF added to store.~%")
	       t)
	     (request-send-error request 400 "Error: no valid body was provided to MPUT.")))
	  ((string-equal meth "MDELETE")
	   ;; MDELETE.
	   (format t "Deleting CBD for ~A.~%" target-node)
	   (if parsed-body
	     ;; Either remove just the triples in the union of the CBD
	     ;; and the supplied body...
	     (remove-triples (cbd target-node parsed-body) *db*)
	     ;; ... or remove the whole CBD.
	     (delete-cbd target-node *db*))
	   t)
	  (t ;; FAIL.
	    (request-send-headers request :response-code 405 
				  :response-text "Error: Unknown method."
				  :extra-http-headers '(("Allow" "GET, POST, MGET, MDELETE, MPUT"))))))
    nil)))

;;; GET query handler. Take the uri parameter and return a CBD for it.
(defmethod handle-request-response ((handler uriqa-query-handler)
				    (method (eql :get)) request)
  (let ((pairs (url-query-alist (request-url request))))
    (let ((uri (cadr (assoc "uri" pairs :test #'string=)))
	  (inference (cadr (assoc "inference" pairs :test #'string=)))
	  (forma (cadr (assoc "format" pairs :test #'string=)))
	  (naming (cadr (assoc "naming" pairs :test #'string=))))
      (let
	 ((target-node (if uri
			(node uri))))

	 ;; Error checking.
	 (unless (string= inference "include")
	   (setf inference "exclude"))
	 (unless (string= naming "uri")
	   (setf naming "label"))
	 (unless (or (string= forma "text/html")
		     (string= forma "application/xhtml+xml")
		     (string= forma "application/rdf-facets"))
	   (setf forma "application/rdf+xml"))

	 (if target-node
	   (cond
	     ((string= forma "application/rdf+xml")
	      (request-send-headers request :content-type "application/rdf+xml")
	      (serialise (cbd target-node) (request-stream request) 'rdf-xml)
	      t)
	     ((or (string= forma "application/xhtml+xml")
		  (string= forma "text/html"))
	      (request-send-headers request :content-type forma)
	      (format (request-stream request)
		      (html-wrap (format nil "CBD for ~A" 
					 (if (string= naming "uri")
					   (node-uri target-node)
					   (label-or-uri target-node t)))
				 (serialise (cbd target-node)
					    nil
					    (if (string= naming "uri")
					      'html
					      'label-html))))
	      t)
	     (t
	       (request-send-error request 501 "Format type not implemented.")))
	   (request-send-error request 400 
			       (format nil "Error: no target node.")))))))

(defun html-wrap (title h &optional (header title))
  "Typical HTML-wrapping function."
  (concatenate 'string
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>
<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\"
\"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">
<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en-gb\">
<head>
  <title>" title "</title>
</head>
<body>
<h1>" header "</h1>
"
h
"</body></html>"))

(defparameter *default-page*
  (html-wrap "URIQA" 
    (concatenate 'string "<p>Enter a URI below.</p>
  <form id=\"mget-form\" method=\"get\" action=\"" (urlstring *access-url*) "uriqa\">
    <fieldset><legend>Search</legend>
      <label for=\"uri\">URI</label>
      <input type=\"text\" name=\"uri\" id=\"uri\" value=\"\" /><br />
      <select size=\"1\" name=\"format\">
	<option id=\"text/html\">text/html</option>
        <option id=\"application/rdf+xml\">application/rdf+xml</option>
      </select>
      <select size=\"1\" name=\"naming\">
	<option id=\"label\">label</option>
        <option id=\"uri\">uri</option>
      </select>
      <input type=\"submit\" name=\"search-submit\" id=\"search-submit\" value=\"Go!\" /><br />
    </fieldset>
  </form>
   <p>You may also use the following HTTP verbs:</p>
  <ul>
    <li>MGET with a URI to retrieve a response describing that URI.</li>
    <li>MPUT with a URI and a body in application/rdf+xml to store
        a CBD for that URI.</li>
    <li>MDELETE with an optional body to remove that CBD for the URI.</li>
  </ul>
  <p>You might also find the query interface useful. This is described more fully at <a href=\"http://sw.nokia.com/uriqa/URIQA.html\" title=\"URIQA\">the URIQA page</a>.</p>
") "Welcome to the URIQA server."))

;;; GET handler. 
;;; "A URIQA enlightened server should attempt to provide a description of a 
;;; resource when a general GET request fails." --- so we do.
(defmethod handle-request-response ((handler uriqa-handler)
				    (method (eql :get)) request)
  (let ((target-url (urlstring (request-url request)))
	(uri-header (car (request-header request :uriqa-uri))))
    (let ((target-node
	    (if (and uri-header
		     (test-prefix target-url uri-header))
	      (node uri-header)
	      (node target-url))))
      (if (and target-node (not (string= "" (request-unhandled-part request))))
        (progn
	  (request-send-headers request :content-type "application/rdf+xml")
	  (serialise (cbd target-node) (request-stream request) 'rdf-xml))
        (progn
	  (request-send-headers request :content-type "application/xhtml+xml")
	  (format (request-stream request)
		  *default-page*)))
      t)))

;;; MGET handler. Return a CBD for the target resource.
;;; This also accepts the URIQA-uri: header.
(defmethod handle-request-response ((handler uriqa-handler)
				    (method (eql :mget)) request)
  (let ((target-url (urlstring (request-url request)))
	(uri-header (car (request-header request :uriqa-uri))))
    (let ((target-node
	    (if (and uri-header
		     (test-prefix target-url uri-header))
	      (node uri-header)
	      (node target-url))))
      (request-send-headers request)
      (serialise (cbd target-node) (request-stream request) 'rdf-xml)
      t)))

;;; MPUT handler.
(defmethod handle-request-response ((handler uriqa-handler)
				    (method (eql :mput)) request)
  (let ((subject-url (urlstring (request-url request)))
	(uri-header (car (request-header request :uriqa-uri)))
	(body-text (request-body request)))
    ;; Note that we don't actually CARE about the URI!
    ;; This just adds RDF to the store!
    (let ((target-node
	    (if (and uri-header
		     (test-prefix subject-url uri-header))
	      (node uri-header)
	      (node subject-url))))
      (if (and target-node body-text)
	(let ((parsed-body (wilbur-ext::rdf->db body-text (make-unique-uri *mput-prefix*))))
	  (if parsed-body
	    (progn
	      (db-merge *db* (db-merge *db* (cbd target-node parsed-body)))
	      (request-send-headers request)
	      (format (request-stream request) "RDF added to store.~%")
	      t)
	    (request-send-error request 400 "Error: no valid body was provided to MPUT.~%")))
	(request-send-error request 400 
			    (format nil "Error: ~A~A~A~%"
				    (if target-node "" "no target node")
				    (if (and target-node (not body-text)) ", ")
				    (if body-text "." "no body.")))))))

;;; MDELETE handler.
(defmethod handle-request-response ((handler uriqa-handler)
				    (method (eql :mdelete)) request)
  (let ((subject-url (urlstring (request-url request)))
	(uri-header (car (request-header request :uriqa-uri)))
	(body-text (request-body request)))
    (let ((target-node
	    (if (and uri-header
		     (test-prefix subject-url uri-header))
	      (node uri-header)
	      (node subject-url))))
      (if (nodep target-node)
	(let ((parsed-body 
		(if (stringp body-text)
		  (wilbur-ext::rdf->db body-text (make-unique-uri *mput-prefix*)))))
	  (if parsed-body
	    (progn
	      (format t "Deleting provided CBD for ~A.~%" target-node)
	      ;; Either remove just the triples in the union of the CBD
	      ;; and the supplied body...
	      (remove-triples (cbd target-node parsed-body) *db*))
	    ;; ... or remove the whole CBD.
	    (delete-cbd target-node *db*))
	  t)
	(request-send-error request 400 
			    (format nil "Error: no target node.~%"))))))

(install-handler (araneida::http-listener-handler *listener*)
		 (make-instance 'uriqa-handler)
		 (araneida::urlstring (araneida::merge-url *access-url* "")) nil)

(install-handler (araneida::http-listener-handler *listener*)
		 (make-instance 'uriqa-query-handler)
		 (araneida::urlstring (araneida::merge-url *access-url* "uriqa")) nil)

(start-listening *listener*)