;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
;;;
;;; ediware.lisp --- Luis Oliveira <loliveira at common-lisp.net>
;;;
;;; This code is placed in the public domain by the author with
;;; absolutely no warranty.

#+:sbcl
(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :asdf))

#+(or)  ;for now, assume they are already loaded
(eval-when (:compile-toplevel :load-toplevel :execute)
  (asdf:oos 'asdf:load-op :drakma)
  (asdf:oos 'asdf:load-op :cl-who)
  (asdf:oos 'asdf:load-op :net-telent-date))

(defpackage #:ediware
  (:use #:cl #:drakma #:cl-who)
  (:import-from #:date #:parse-time))
(in-package #:ediware)

(defparameter +tarballs+
  '((cl-webdav     . "http://weitz.de/files/cl-webdav.tar.gz")
    (skippy         . "http://www.xach.com/lisp/skippy.tgz")
    (salza         . "http://www.xach.com/lisp/salza/salza-0.7.2.tar.gz")
    (trivial-sockets
     . "http://ftp.linux.org.uk/pub/lisp/cclan/trivial-sockets.tar.gz")
    (split-sequence
     . "http://ftp.linux.org.uk/pub/lisp/cclan/split-sequence.tar.gz")
    (rfc2388
     . "http://common-lisp.net/project/rfc2388/rfc2388_latest.tar.gz")
    (parse-number
     . "http://common-lisp.net/project/asdf-packaging/parse-number-latest.tar.gz")
    (net-telent-date
     . "http://ftp.linux.org.uk/pub/lisp/cclan/net-telent-date.tar.gz")
    (ltk :page "Ltk" :prefix "http://www.peter-herth.de/ltk/ltk-")
    (ironclad . "http://www.method-combination.net/lisp/files/ironclad.tar.gz")
    (chipz . "http://www.method-combination.net/lisp/files/chipz.tar.gz")
    (psgraph
     . "http://common-lisp.net/project/asdf-packaging/psgraph-latest.tar.gz")))

(defparameter +stampfile+
  #p"/project/clbuild/public_html/mirror/ediware-timestamps")

(defparameter +tmptarball+
  #p"/project/clbuild/public_html/mirror/tmptarball.tgz")

(defparameter +darcs-dir+
  #p"/project/clbuild/public_html/mirror/")

(defparameter +report-file+
  #p"/project/clbuild/public_html/mirror/index.html")

(defparameter +base-url+ "http://common-lisp.net/project/clbuild/mirror/")

;; list of (name universal-time version-string)
(defvar *timestamps* nil)

(defun get-url (name)
  (cdr (assoc name +tarballs+)))

(defun update-version (name version)
  (let ((entry (assoc name *timestamps*)))
    (setf (cdr entry) (list (second entry) version))))

(defun update-time (name time)
  (let ((entry (assoc name *timestamps*)))
    (setf (cdr entry) (list time (third entry)))))

(defun last-modified (url)
  (let ((headers (nth-value 2 (http-request url :method :head))))
    (parse-time (cdr (assoc :last-modified headers)))))

(defun poll-tarballs ()
  (loop for (name . url) in +tarballs+
        collect (list name (last-modified (uri-from-spec url)) "initial version")))

(defun save-timestamps ()
  (with-open-file (out +stampfile+ :direction :output
                       :if-exists :supersede)
    (prin1 *timestamps* out)))

(defun load-timestamps ()
  (with-open-file (in +stampfile+ :direction :input)
    (let ((*package* (find-package '#:ediware))
          (*read-eval* nil))
      (setq *timestamps* (read in)))))

(defun collect-changed (old new)
  (loop for (name . time) in new
        unless (eql (second (assoc name old)) time)
        collect name))

(defun harmless-uri-character-p (c)
  (or (alpha-char-p c)
      (digit-char-p c)
      (find c "-_.")))

(defun get-url-from-cliki (spec)
  (destructuring-bind (&key page prefix) spec
    (multiple-value-bind (ignore code plist)
        (drakma:http-request
         (format nil "http://www.cliki.net/~A?download" page)
         :redirect nil)
      (declare (ignore ignore))
      (check-type code (eql 302))
      (let ((url (cdr (assoc :location plist))))
        (unless (and (eql (mismatch prefix url)
                          (length prefix))
                     (null
                      (position-if-not #'harmless-uri-character-p
                                       url
                                       :start (length prefix))))
          (error "url for ~A doesn't match prefix ~A: ~A"
                 page prefix url))
        url))))

(defun uri-from-spec (spec)
  (if (consp spec)
      (get-url-from-cliki spec)
      spec))

(defun grab-tarball (url)
  (let ((stream (http-request (uri-from-spec url) :want-stream t)))
    (with-open-file (out +tmptarball+ :direction :output
                         :if-exists :supersede
                         :element-type '(unsigned-byte 8))
      (loop for byte = (read-byte stream nil nil)
            while byte do (write-byte byte out)))))

(defun unpack-tarball (dest)
  (asdf:run-shell-command "tar --strip=1 -C ~A -xzf ~A"
                          dest +tmptarball+))

(defun darcs-dir (name)
  (let ((subdir (list :relative (string-downcase (symbol-name name)))))
    (merge-pathnames (make-pathname :directory subdir) +darcs-dir+)))

(defun find-file (path &rest alternatives)
  (loop for alt in alternatives
        for ret = (probe-file (merge-pathnames alt path))
        when ret do (return ret)))

(defun get-version (path)
  #+nil
  (let ((file (find-file path "CHANGELOG" "CHANGELOG.txt")))
    (with-open-file (in file :direction :input)
      (string-downcase (read-line in))))
  (write-to-string (get-universal-time)))

(defun darcs-init (path)
  (asdf:run-shell-command "cd ~A; darcs init " path))

(defun darcs-register (path message)
  (asdf:run-shell-command "cd ~A; darcs record -la -m \"~A\" -A ediware"
                          path message))

(defun format-date (time)
  (date:universal-time-to-rfc2822-date time))

(defun output-report ()
  (with-open-file (out +report-file+ :direction :output
                       :if-exists :supersede)
    (with-html-output (out nil :prologue t)
      (:html
       (:head (:title "Mirror"))
       (:body
        (:h1 "Mirror")
        (:p "The following is a collection of darcs trees nightly generated by "
            (:a :href "work/ediware.lisp" "this program")
             " (stolen from ~loliveira) for some of the tarballs required by clbuild.")
        (:p "Last update: " (str (format-date (get-universal-time))))
        (:ul
         (loop for (name time version) in *timestamps*
               for lname = (string-downcase (symbol-name name)) do
               (htm
                (:li
                 (:p (:a :href "#fixme" (str name)) 
                    " &mdash; " (str version)
                     " &mdash; last changed: " (str (format-date time))
                     (:br)
                     (let ((url (format nil "~A~A" +base-url+ lname)))
                       (htm (:code (:a :href url (str url)))))))))))))))

(defun first-run ()
  (setq *timestamps* (poll-tarballs))
  (loop for (name . url) in +tarballs+
        for dir = (darcs-dir name) do
        (format t "Grabbing ~A onto ~A...~%" name dir)
        (ensure-directories-exist dir)
        (grab-tarball url)
        (unpack-tarball dir)
        (darcs-init dir)
        (let ((version (get-version dir)))
          (darcs-register dir version)
          (update-version name version)))
  (save-timestamps)
  (output-report))

;; don't use ignore-errors like this at home...
(defmacro ignore-errors* (&body body)
  `(handler-case
       (progn ,@body)
     (error (c)
       (warn "ignoring ~A" c))))
(defun run ()
  (load-timestamps)
  (let ((new-stamps (ignore-errors* (poll-tarballs))))
    (loop for name in (collect-changed *timestamps* new-stamps)
          for dir = (darcs-dir name) do
          (ignore-errors*
           (format t "Updating ~A...~%" name)
           (grab-tarball (get-url name))
           (unpack-tarball dir)
           (let ((version (get-version dir)))
             (darcs-register dir version)
             (update-version name version))
           (update-time name (second (assoc name new-stamps))))))
  (save-timestamps)
  (output-report)
  (ignore-errors* (delete-file +tmptarball+)))
(trace collect-changed)
(trace poll-tarballs)
(trace get-version)
(trace darcs-register)
(trace darcs-init)
(trace update-version)
(trace update-time)
(trace asdf:run-shell-command)
(trace get-url-from-cliki)