scripts/release.lisp

   1 #!/usr/bin/env clisp
   2 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   3
   4 (defpackage :release-script (:use #:cl #:regexp))
   5 (in-package :release-script)
   6
   7 ;;;; Configuration ------------------------------------------------------------
   8
   9 (defparameter *project-name* "cffi")
  10 (defparameter *asdf-file* (format nil "~A.asd" *project-name*))
  11
  12 (defparameter *host* "common-lisp.net")
  13 (defparameter *release-dir*
  14   (format nil "/project/~A/public_html/releases" *project-name*))
  15
  16 (defparameter *version-file* "VERSION")
  17 (defparameter *version-file-dir*
  18   (format nil "/project/~A/public_html" *project-name*))
  19
  20 ;;;; --------------------------------------------------------------------------
  21
  22 ;;;; Utilities
  23
  24 (defun ensure-list (x)
  25   (if (listp x) x (list x)))
  26
  27 (defmacro string-case (expression &body clauses)
  28   `(let ((it ,expression)) ; yes, anaphoric, deal with it.
  29      (cond
  30        ,@(loop for clause in clauses collect
  31                `((or ,@(loop for alternative in (ensure-list (first clause))
  32                              collect (or (eq t alternative)
  33                                          `(string= it ,alternative))))
  34                  ,@(rest clause))))))
  35
  36 (defparameter *development-mode* nil)
  37
  38 (defun die (format-control &rest format-args)
  39   (format *error-output* "~?" format-control format-args)
  40   (if *development-mode*
  41       (cerror "continue" "die")
  42       (ext:quit 1)))
  43
  44 (defun numeric-split (string)
  45   (if (digit-char-p (char string 0))
  46       (multiple-value-bind (number next-position)
  47           (parse-integer string :junk-allowed t)
  48         (cons number (when (< next-position (length string))
  49                        (numeric-split (subseq string next-position)))))
  50       (let ((next-digit-position (position-if #'digit-char-p string)))
  51         (if next-digit-position
  52             (cons (subseq string 0 next-digit-position)
  53                   (numeric-split (subseq string next-digit-position)))
  54             (list string)))))
  55
  56 (defun natural-string-< (s1 s2)
  57   (labels ((aux< (l1 l2)
  58              (cond ((null l1) (not (null l2)))
  59                    ((null l2) nil)
  60                    (t (destructuring-bind (x . xs) l1
  61                         (destructuring-bind (y . ys) l2
  62                           (cond ((and (numberp x) (stringp y))
  63                                  t)
  64                                 ((and (numberp y) (stringp x))
  65                                  nil)
  66                                 ((and (numberp x) (numberp y))
  67                                  (or (< x y) (and (= x y) (aux< xs ys))))
  68                                 (t
  69                                  (or (string-lessp x y)
  70                                      (and (string-equal x y)
  71                                           (aux< xs ys)))))))))))
  72     (aux< (numeric-split s1)
  73           (numeric-split s2))))
  74
  75 ;;;; Running commands
  76
  77 (defparameter *dry-run* nil)
  78
  79 (defun cmd? (format-control &rest format-args)
  80   (let ((cmd (format nil "~?" format-control format-args)))
  81     (with-open-stream (s1 (ext:run-shell-command cmd :output :stream))
  82       (loop for line = (read-line s1 nil nil)
  83             while line
  84             collect line))))
  85
  86 ;; XXX: quote arguments.
  87 (defun cmd (format-control &rest format-args)
  88   (when *development-mode*
  89     (format *debug-io* "CMD: ~?~%" format-control format-args))
  90   (let ((ret (ext:run-shell-command (format nil "~?" format-control format-args))))
  91     (or (null ret)
  92         (zerop ret))))
  93
  94 (defun cmd! (format-control &rest format-args)
  95   (or (apply #'cmd format-control format-args)
  96       (die "cmd '~?' failed." format-control format-args)))
  97
  98 (defun maybe-cmd! (format-control &rest format-args)
  99   (if *dry-run*
 100       (format t "SUPPRESSING: ~?~%" format-control format-args)
 101       (apply #'cmd! format-control format-args)))
 102
 103 ;;;;
 104
 105 (defun find-current-version ()
 106   (subseq (reduce (lambda (x y) (if (natural-string-< x y) y x))
 107                   (or (cmd? "git tag -l v\\*")
 108                       (die "no version tags found. Please specify initial version.")))
 109           1))
 110
 111 (defun parse-version (string)
 112   (mapcar (lambda (x)
 113             (parse-integer x :junk-allowed t))
 114           (loop repeat 3 ; XXX: parameterize
 115                 for el in (regexp-split "\\." (find-current-version))
 116                 collect el)))
 117
 118 (defun check-for-unrecorded-changes (&optional force)
 119   (unless (cmd "git diff --exit-code")
 120     (write-line "Unrecorded changes.")
 121     (if force
 122         (write-line "Continuing anyway.")
 123         (die "Aborting.~@
 124               Use -f or --force if you want to make a release anyway."))))
 125
 126 (defun new-version-number-candidates (current-version)
 127   (labels ((alternatives (before after)
 128              (when after
 129                (cons (append before
 130                              (list (1+ (first after)))
 131                              (mapcar (constantly 0) (rest after)))
 132                      (alternatives (append before (list (first after)))
 133                                    (rest after))))))
 134     (loop for alt in (alternatives nil (parse-version current-version))
 135           collect (format nil "~{~d~^.~}" alt))))
 136
 137 (defun ask-user-for-version (current-version next-versions)
 138   (format *query-io* "Current version is ~A. Which will be the next one?~%"
 139           current-version)
 140   (loop for i from 1 and version in next-versions
 141         do (format *query-io* "~T~A) ~A~%" i version))
 142   (format *query-io* "? ")
 143   (finish-output *query-io*)
 144   (nth (1- (parse-integer (read-line) :junk-allowed t))
 145        next-versions))
 146
 147 (defun git-tag-tree (version)
 148   (write-line "Tagging the tree...")
 149   (maybe-cmd! "git tag \"v~A\"" version))
 150
 151 (defun add-version-to-system-file (version path-in path-out)
 152   (let ((defsystem-line (format nil "(defsystem :~A" *project-name*)))
 153     (with-open-file (in path-in :direction :input)
 154       (with-open-file (out path-out :direction :output)
 155         (loop for line = (read-line in nil nil) while line
 156               do (write-line line out)
 157               when (string= defsystem-line line)
 158                 do (format out "  :version ~s~%" version))))))
 159
 160 (defun create-dist (version distname)
 161   (write-line "Creating distribution...")
 162   (cmd! "mkdir \"~a\"" distname)
 163   (cmd! "git archive master | tar xC \"~A\"" distname)
 164   (format t "Updating ~A with new version: ~A~%" *asdf-file* version)
 165   (let* ((asdf-file-path (format nil "~A/~A" distname *asdf-file*))
 166          (tmp-asdf-file-path (format nil "~a.tmp" asdf-file-path)))
 167     (add-version-to-system-file version asdf-file-path tmp-asdf-file-path)
 168     (cmd! "mv \"~a\" \"~a\"" tmp-asdf-file-path asdf-file-path)))
 169
 170 (defun tar-and-sign (distname tarball)
 171   (write-line "Creating and signing tarball...")
 172   (cmd! "tar czf \"~a\" \"~a\"" tarball distname)
 173   (cmd! "gpg -b -a \"~a\"" tarball))
 174
 175 (defparameter *remote-directory* (format nil "~A:~A" *host* *release-dir*))
 176
 177 (defun upload-tarball (tarball signature remote-directory)
 178   (write-line "Copying tarball to web server...")
 179   (maybe-cmd! "scp \"~A\" \"~A\" \"~A\"" tarball signature remote-directory)
 180   (format t "Uploaded ~A and ~A.~%" tarball signature))
 181
 182 (defun update-remote-links (tarball signature host release-dir project-name)
 183   (format t "Updating ~A_latest links...~%" project-name)
 184   (maybe-cmd! "ssh \"~A\" ln -sf \"~A\" \"~A/~A_latest.tar.gz\""
 185               host tarball release-dir project-name)
 186   (maybe-cmd! "ssh \"~A\" ln -sf \"~A\" \"~A/~A_latest.tar.gz.asc\""
 187               host signature release-dir project-name))
 188
 189 (defun upload-version-file (version version-file host version-file-dir)
 190   (format t "Uploading ~A...~%" version-file)
 191   (with-open-file (out version-file :direction :output)
 192     (write-string version out))
 193   (maybe-cmd! "scp \"~A\" \"~A\":\"~A\"" version-file host version-file-dir)
 194   (maybe-cmd! "rm \"~A\"" version-file))
 195
 196 (defun maybe-clean-things-up (tarball signature)
 197   (when (y-or-n-p "Clean local tarball and signature?")
 198     (cmd! "rm \"~A\" \"~A\"" tarball signature)))
 199
 200 (defun run (force version)
 201   (check-for-unrecorded-changes force)
 202   ;; figure out what version we'll be preparing.
 203   (unless version
 204     (let* ((current-version (find-current-version))
 205            (next-versions (new-version-number-candidates current-version)))
 206       (setf version (or (ask-user-for-version current-version next-versions)
 207                         (die "invalid selection.")))))
 208   (git-tag-tree version)
 209   (let* ((distname (format nil "~A_~A" *project-name* version))
 210          (tarball (format nil "~A.tar.gz" distname))
 211          (signature (format nil "~A.asc" tarball)))
 212     ;; package things up.
 213     (create-dist version distname)
 214     (tar-and-sign distname tarball)
 215     ;; upload.
 216     (upload-tarball tarball signature *remote-directory*)
 217     (update-remote-links tarball signature *host* *release-dir* *project-name*)
 218     (when *version-file*
 219       (upload-version-file version *version-file* *host* *version-file-dir*))
 220     ;; clean up.
 221     (maybe-clean-things-up tarball signature)
 222     ;; documentation.
 223     (write-line "Building and uploading documentation...")
 224     (maybe-cmd! "make -C doc upload-docs")
 225     ;; push tags and any outstanding changes.
 226     (write-line "Pushing tags and changes...")
 227     (maybe-cmd! "git push --tags origin master")))
 228
 229
 230 ;;;; Do it to it
 231
 232 (let ((force nil)
 233       (version nil)
 234       (args ext:*args*))
 235   (loop while args
 236         do (string-case (pop args)
 237              (("-h" "--help")
 238               (write-line "No help, sorry. Read the source.")
 239               (ext:quit 0))
 240              (("-f" "--force")
 241               (setf force t))
 242              (("-v" "--version")
 243               (setf version (pop args)))
 244              (("-n" "--dry-run")
 245               (setf *dry-run* t))
 246              (t
 247               (die "Unrecognized argument '~a'" it))))
 248   (run force version))