;;;; -*- 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))

(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-file+
  #p"/home/loliveira/public_html/ediware/ediware-tarballs")

(defparameter +stampfile+
  #p"/home/loliveira/public_html/ediware/ediware-timestamps")

(defparameter +tmptarball+
  #p"/home/loliveira/public_html/ediware/tmptarball.tgz")

(defparameter +darcs-dir+
  #p"/home/loliveira/public_html/ediware/")

(defparameter +report-file+
  #p"/home/loliveira/public_html/ediware/index.html")

(defparameter +base-url+ "http://common-lisp.net/~loliveira/ediware/")

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

;; list of (name . url)
(defvar *tarballs* 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 (cons name (last-modified url))))

(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 load-tarball-urls ()
  (with-open-file (in +tarballs-file+ :direction :input)
    (let ((*read-eval* nil))
      (setq *tarballs* (read in)))))

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

(defun grab-tarball (url)
  (let ((stream (http-request 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-path=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)
  (let ((file (find-file path "CHANGELOG" "CHANGELOG.txt")))
    (with-open-file (in file :direction :input)
      (string-downcase (read-line in)))))

(defun darcs-init (path)
  (format t "path: ~A~%" path)
  (print (asdf:run-shell-command "cd \"~A\" && darcs init" path)))

(defun darcs-register (path message)
  (asdf:run-shell-command "darcs record -la --repodir=~A -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 "Ediware"))
       (:body
        (:h1 "Ediware")
        (:p "The following is a collection of darcs trees nightly generated by "
            (:a :href "ediware.lisp" "this ugly program")
             " for some of the tarballs released by "
            (:a :href "http://weitz.de" "Edi Weitz") ".")
        (: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 (format nil "http://weitz.de/~A" lname) (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)))))))))))))))

;; don't use ignore-errors like this at home...
(defun run ()
  (load-timestamps)
  (load-tarball-urls)
  (let ((new-stamps (ignore-errors (poll-tarballs))))
    (loop for name in (collect-changed *timestamps* new-stamps)
          for dir = (darcs-dir name) do
          (ignore-errors
	    (ensure-directories-exist dir)
            (format t "Updating ~A...~%" name)
            (grab-tarball (get-url name))
            (unpack-tarball dir)
            (unless (assoc name *timestamps*)
	      (format t "Initializing repository...~%")
	      (darcs-init dir)
	      (push (list name nil nil) *timestamps*)
	      (format t "Done.~%"))
	    (let ((version (get-version dir)))
              (darcs-register dir version)
              (update-version name version))
            (update-time name (cdr (assoc name new-stamps))))))
  (save-timestamps)
  (output-report)
  (ignore-errors (delete-file +tmptarball+)))