(in-package :asdf-install)

(defvar *proxy* (posix-getenv "http_proxy"))
(defvar *cclan-mirror*
  (or (posix-getenv "CCLAN_MIRROR")
      "http://ftp.linux.org.uk/pub/lisp/cclan/"))
    
(defun directorify (name)
  ;; input name may or may not have a training #\/, but we know we
  ;; want a directory
  (let ((path (pathname name)))
    (if (pathname-name path)
	(merge-pathnames
	 (make-pathname :directory `(:relative ,(pathname-name path))
			:name "")
	 path)
	path)))

(defvar *sbcl-home* (directorify (posix-getenv "SBCL_HOME")))
(defvar *dot-sbcl*
  (merge-pathnames (make-pathname :directory '(:relative ".sbcl"))
		   (user-homedir-pathname)))

(defvar *verify-gpg-signatures* :unknown-locations
  "Should we get detached GPG signatures for the packages and verify them?
NIL - no, T - yes, :UNKNOWN-LOCATIONS - for any URL which isn't in CCLAN
and doesn't begin with one of the prefixes in *SAFE-URL-PREFIXES*")
(defvar *safe-url-prefixes*
  (list "http://ftp.linux.org.uk/pub/lisp/"
	"http://files.b9.com/"))

(defun verify-gpg-signatures-p (url)
  (labels ((prefixp (prefix string)
	     (let ((m (mismatch prefix string)))
	       (or (not m) (>= m (length prefix))))))
    (case *verify-gpg-signatures*
      (nil nil)
      (:unknown-locations
       (notany
	(lambda (x) (prefixp x url))
	(cons *cclan-mirror* *safe-url-prefixes*)))
      (t t))))
	  
(defvar *locations*
  `((,(merge-pathnames "site/" *sbcl-home*)
     ,(merge-pathnames "site-systems/" *sbcl-home*)
     "System-wide install")
    (,(merge-pathnames "site/" *dot-sbcl*)
     ,(merge-pathnames "systems/" *dot-sbcl*)
     "Personal installation")))

(let* ((*package* (find-package :asdf-install-customize))
       (file (probe-file (merge-pathnames
			  (make-pathname :name ".asdf-install")
			  (user-homedir-pathname)))))
  (when file (load file)))

(define-condition download-error (error)
  ((url :initarg :url :reader download-url)
   (response :initarg :response :reader download-response))
  (:report (lambda (c s)
	     (format s "Server responded ~A for GET ~A"
		     (download-response c) (download-url c)))))

(define-condition signature-error (error)
  ((cause :initarg :cause :reader signature-error-cause))
  (:report (lambda (c s)
	     (format s "Cannot verify package signature:  ~A"
		     (signature-error-cause c)))))
	     
(defun url-host (url)
  (assert (string-equal url "http://" :end1 7))
  (let* ((port-start (position #\: url :start 7))
	 (host-end (min (or (position #\/ url :start 7) (length url))
			(or port-start (length url)))))
    (subseq url 7 host-end)))

(defun url-port (url)
  (assert (string-equal url "http://" :end1 7))
  (let ((port-start (position #\: url :start 7)))
    (if port-start (parse-integer url :start port-start :junk-allowed t) 80)))

(defun url-connection (url)
  (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))
	(host (url-host url))
	(port (url-port url)))
    (socket-connect
     s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url)))))
     (url-port (or  *proxy* url)))
    (let ((stream (socket-make-stream s :input t :output t :buffering :full)))
      ;; we are exceedingly unportable about proper line-endings here.
      ;; Anyone wishing to run this under non-SBCL should take especial care
      (format stream "GET ~A HTTP/1.0~%Host: ~A~%Cookie: CCLAN-SITE=~A~%~%"
	      url host *cclan-mirror*)
      (force-output stream)
      (list
       (let* ((l (read-line stream))
	      (space (position #\Space l)))
	 (parse-integer l :start (1+ space) :junk-allowed t))
       (loop for line = (read-line stream nil nil)
	     until (or (null line) (eql (elt line 0) (code-char 13)))
	     collect
	     (let ((colon (position #\: line)))
	       (cons (intern (string-upcase (subseq line 0 colon)) :keyword)
		     (string-trim (list #\Space (code-char 13))
				  (subseq line (1+ colon))))))
       stream))))

(defun download-files-for-package (package-name-or-url file-name)
  (let ((url
	 (if (= (mismatch package-name-or-url "http://") 7)
	     package-name-or-url
	     (format nil "http://www.cliki.net/~A?download"
		     package-name-or-url))))
    (destructuring-bind (response headers stream)
	(block got
	  (loop
	   (destructuring-bind (response headers stream) (url-connection url)
	     (unless (member response '(301 302))	       
	       (return-from got (list response headers stream)))
	     (close stream)
	     (setf url (cdr (assoc :location headers))))))
      (if (>= response 400)
	(error 'download-error :url url :response response))
      (let ((length (parse-integer
		     (or (cdr (assoc :content-length headers)) "")
		     :junk-allowed t)))
	(format t "Downloading ~A bytes from ~A ..."
		(if length length "some unknown number of") url)
	(force-output)
	(with-open-file (o file-name :direction :output)
	  (if length
	      (let ((buf (make-array length
				     :element-type
				     (stream-element-type stream)  )))
		(read-sequence buf stream)
		(write-sequence buf o)) 
	      (sb-executable:copy-stream stream o))))
      (close stream)
      (terpri)
      ;; seems to have worked.  let's try for a detached gpg signature too
      (when (verify-gpg-signatures-p url)
	(verify-gpg-signature url file-name)))))

(defun verify-gpg-signature (url file-name)
  (destructuring-bind (response headers stream)
      (url-connection (concatenate 'string url ".asc"))
    (unwind-protect
	 (if (= response 200)
	     ;; sadly, we can't pass the stream directly to run-program,
	     ;; because (at least in sbcl 0.8) that ignores existing buffered
	     ;; data and only reads new fresh data direct from the file
	     ;; descriptor
	     (let ((data (make-string (parse-integer
				       (cdr (assoc :content-length headers))
				       :junk-allowed t))))
	       (read-sequence data stream)
	       (let ((ret
		      (process-exit-code
		       (sb-ext:run-program "gpg"
					   (list "--verify" "-"
						 (namestring file-name))
					   :output t
					   :search t
					   :input (make-string-input-stream data)
					   :wait t))))
		 (unless (zerop ret)
		   (error 'signature-error
			  :cause (make-condition
				  'simple-error
				  :format-control "GPG returned exit status ~A"
				  :format-arguments (list ret))))))
	     (error 'signature-error
		    :cause
		    (make-condition
		     'download-error :url  (concatenate 'string url ".asc")
		     :response response)))
      (close stream))))
	
    


(defun where ()  
  (format t "Install where?~%")
  (loop for (source system name) in *locations*
	for i from 1
	do (format t "~A) ~A: ~%   System in ~A~%   Files in ~A ~%"
		   i name system source))
  (format t " --> ") (force-output)
  (let ((response (read)))
    (when (> response 0)
      (elt *locations* (1- response)))))

(defun install-package (source system packagename)
  "Returns a list of asdf system names for installed asdf systems"
  (ensure-directories-exist source )
    (ensure-directories-exist system )
  (let* ((tar
	  (with-output-to-string (o)
	    (or
	     (sb-ext:run-program "tar"
				 (list "-C" (namestring source)
				       "-xzvf" (namestring packagename))
				 :output o
				 :search t
				 :wait t)
	     (error "can't untar"))))
	 (dummy (princ tar))
	 (pos-slash (position #\/ tar))
	 (*default-pathname-defaults*
	  (merge-pathnames
	   (make-pathname :directory
			  `(:relative ,(subseq tar 0 pos-slash)))
	   source)))
    (loop for asd in (directory
		      (make-pathname :name :wild :type "asd"))
	  do (let ((target (merge-pathnames
			    (make-pathname :name (pathname-name asd)
					   :type (pathname-type asd))
			    system)))
	       (when (probe-file target)
		 (sb-posix:unlink target))
	       (sb-posix:symlink asd target))
	  collect (pathname-name asd))))

(defvar *temporary-files*)
(defun temp-file-name (p)
  (let* ((pos-slash (position #\/ p :from-end t))
	 (pos-dot (position #\. p :start (or pos-slash 0))))
    (merge-pathnames
     (make-pathname
      :name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot)
      :type "asdf-install-tmp"))))
		     

;; this is the external entry point
(defun install (&rest packages)
  (let ((*temporary-files* nil))
    (unwind-protect
	 (destructuring-bind (source system name) (where)
	   (labels ((one-iter (packages)
		      (dolist (asd
				(loop for p in (mapcar 'string packages)
				      unless (probe-file p)
				      do (let ((tmp (temp-file-name p)))
					   (pushnew tmp *temporary-files*)
					   (download-files-for-package p tmp)
					   (setf p tmp))
				      end
				      do (format t "Installing ~A in ~A,~A~%"
						 p source system)
				      append (install-package source system p)))
			(handler-case
			    (asdf:operate 'asdf:load-op asd)
			  (asdf:missing-dependency (c)
			    (format t
				    "Downloading package ~A, required by ~A~%"
				    (asdf::missing-requires c)
				    (asdf:component-name
				     (asdf::missing-required-by c)))
			    (one-iter (list
				       (symbol-name
					(asdf::missing-requires c)))))))))
	     (one-iter packages)))
      (dolist (l *temporary-files*)
	    (when (probe-file l) (delete-file l))))))