250 lines
9.6 KiB
Common Lisp
250 lines
9.6 KiB
Common Lisp
#!/usr/bin/env clisp
|
|
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
|
|
|
|
(defpackage :release-script (:use #:cl #:regexp))
|
|
(in-package :release-script)
|
|
|
|
;;;; Configuration ------------------------------------------------------------
|
|
|
|
(defparameter *project-name* "babel")
|
|
(defparameter *asdf-file* (format nil "~A.asd" *project-name*))
|
|
|
|
(defparameter *host* "common-lisp.net")
|
|
(defparameter *release-dir*
|
|
(format nil "/project/~A/public_html/releases" *project-name*))
|
|
|
|
(defparameter *version-file* "VERSION")
|
|
(defparameter *version-file-dir*
|
|
(format nil "/project/~A/public_html" *project-name*))
|
|
|
|
;;;; --------------------------------------------------------------------------
|
|
|
|
;;;; Utilities
|
|
|
|
(defun ensure-list (x)
|
|
(if (listp x) x (list x)))
|
|
|
|
(defmacro string-case (expression &body clauses)
|
|
`(let ((it ,expression)) ; yes, anaphoric, deal with it.
|
|
(cond
|
|
,@(loop for clause in clauses collect
|
|
`((or ,@(loop for alternative in (ensure-list (first clause))
|
|
collect (or (eq t alternative)
|
|
`(string= it ,alternative))))
|
|
,@(rest clause))))))
|
|
|
|
(defparameter *development-mode* nil)
|
|
|
|
(defun die (format-control &rest format-args)
|
|
(format *error-output* "~?" format-control format-args)
|
|
(if *development-mode*
|
|
(cerror "continue" "die")
|
|
(ext:quit 1)))
|
|
|
|
(defun numeric-split (string)
|
|
(if (digit-char-p (char string 0))
|
|
(multiple-value-bind (number next-position)
|
|
(parse-integer string :junk-allowed t)
|
|
(cons number (when (< next-position (length string))
|
|
(numeric-split (subseq string next-position)))))
|
|
(let ((next-digit-position (position-if #'digit-char-p string)))
|
|
(if next-digit-position
|
|
(cons (subseq string 0 next-digit-position)
|
|
(numeric-split (subseq string next-digit-position)))
|
|
(list string)))))
|
|
|
|
(defun natural-string-< (s1 s2)
|
|
(labels ((aux< (l1 l2)
|
|
(cond ((null l1) (not (null l2)))
|
|
((null l2) nil)
|
|
(t (destructuring-bind (x . xs) l1
|
|
(destructuring-bind (y . ys) l2
|
|
(cond ((and (numberp x) (stringp y))
|
|
t)
|
|
((and (numberp y) (stringp x))
|
|
nil)
|
|
((and (numberp x) (numberp y))
|
|
(or (< x y) (and (= x y) (aux< xs ys))))
|
|
(t
|
|
(or (string-lessp x y)
|
|
(and (string-equal x y)
|
|
(aux< xs ys)))))))))))
|
|
(aux< (numeric-split s1)
|
|
(numeric-split s2))))
|
|
|
|
;;;; Running commands
|
|
|
|
(defparameter *dry-run* nil)
|
|
|
|
(defun cmd? (format-control &rest format-args)
|
|
(let ((cmd (format nil "~?" format-control format-args)))
|
|
(with-open-stream (s1 (ext:run-shell-command cmd :output :stream))
|
|
(loop for line = (read-line s1 nil nil)
|
|
while line
|
|
collect line))))
|
|
|
|
;; XXX: quote arguments.
|
|
(defun cmd (format-control &rest format-args)
|
|
(when *development-mode*
|
|
(format *debug-io* "CMD: ~?~%" format-control format-args))
|
|
(let ((ret (ext:run-shell-command (format nil "~?" format-control format-args))))
|
|
(or (null ret)
|
|
(zerop ret))))
|
|
|
|
(defun cmd! (format-control &rest format-args)
|
|
(or (apply #'cmd format-control format-args)
|
|
(die "cmd '~?' failed." format-control format-args)))
|
|
|
|
(defun maybe-cmd! (format-control &rest format-args)
|
|
(if *dry-run*
|
|
(format t "SUPPRESSING: ~?~%" format-control format-args)
|
|
(apply #'cmd! format-control format-args)))
|
|
|
|
;;;;
|
|
|
|
(defun find-current-version ()
|
|
(subseq (reduce (lambda (x y) (if (natural-string-< x y) y x))
|
|
(or (cmd? "git tag -l v\\*")
|
|
(die "no version tags found. Please specify initial version.")))
|
|
1))
|
|
|
|
(defun parse-version (string)
|
|
(mapcar (lambda (x)
|
|
(parse-integer x :junk-allowed t))
|
|
(loop repeat 3 ; XXX: parameterize
|
|
for el in (regexp-split "\\." (find-current-version))
|
|
collect el)))
|
|
|
|
(defun check-for-unrecorded-changes (&optional force)
|
|
(unless (cmd "git diff --exit-code")
|
|
(write-line "Unrecorded changes.")
|
|
(if force
|
|
(write-line "Continuing anyway.")
|
|
(die "Aborting.~@
|
|
Use -f or --force if you want to make a release anyway."))))
|
|
|
|
(defun new-version-number-candidates (current-version)
|
|
(let ((current-version (parse-version current-version)))
|
|
(labels ((alternatives (before after)
|
|
(when after
|
|
(cons (append before (list (1+ (first after)))
|
|
(mapcar (constantly 0) (rest after)))
|
|
(alternatives (append before (list (first after)))
|
|
(rest after))))))
|
|
(loop for alt in (alternatives nil current-version)
|
|
collect (reduce (lambda (acc next)
|
|
(format nil "~a.~a" acc next))
|
|
alt)))))
|
|
|
|
(defun ask-user-for-version (current-version next-versions)
|
|
(format *query-io* "Current version is ~A. Which will be the next one?~%"
|
|
current-version)
|
|
(loop for i from 1 and version in next-versions
|
|
do (format *query-io* "~T~A) ~A~%" i version))
|
|
(format *query-io* "? ")
|
|
(finish-output *query-io*)
|
|
(nth (1- (parse-integer (read-line) :junk-allowed t))
|
|
next-versions))
|
|
|
|
(defun git-tag-tree (version)
|
|
(write-line "Tagging the tree...")
|
|
(maybe-cmd! "git tag \"v~A\"" version))
|
|
|
|
(defun add-version-to-system-file (version path-in path-out)
|
|
(with-open-file (in path-in :direction :input)
|
|
(with-open-file (out path-out :direction :output)
|
|
(loop for line = (read-line in nil nil) while line
|
|
do (write-line line out)
|
|
when (string= #1="(defsystem " line
|
|
:end2 (min (length #1#) (length line)))
|
|
do (format out " :version ~s~%" version)))))
|
|
|
|
(defun create-dist (version distname)
|
|
(write-line "Creating distribution...")
|
|
(cmd! "mkdir \"~a\"" distname)
|
|
(cmd! "git archive master | tar xC \"~A\"" distname)
|
|
(format t "Updating ~A with new version: ~A~%" *asdf-file* version)
|
|
(let* ((asdf-file-path (format nil "~A/~A" distname *asdf-file*))
|
|
(tmp-asdf-file-path (format nil "~a.tmp" asdf-file-path)))
|
|
(add-version-to-system-file version asdf-file-path tmp-asdf-file-path)
|
|
(cmd! "mv \"~a\" \"~a\"" tmp-asdf-file-path asdf-file-path)))
|
|
|
|
(defun tar-and-sign (distname tarball)
|
|
(write-line "Creating and signing tarball...")
|
|
(cmd! "tar czf \"~a\" \"~a\"" tarball distname)
|
|
(cmd! "gpg -b -a \"~a\"" tarball))
|
|
|
|
(defparameter *remote-directory* (format nil "~A:~A" *host* *release-dir*))
|
|
|
|
(defun upload-tarball (tarball signature remote-directory)
|
|
(write-line "Copying tarball to web server...")
|
|
(maybe-cmd! "scp \"~A\" \"~A\" \"~A\"" tarball signature remote-directory)
|
|
(format t "Uploaded ~A and ~A.~%" tarball signature))
|
|
|
|
(defun update-remote-links (tarball signature host release-dir project-name)
|
|
(format t "Updating ~A_latest links...~%" project-name)
|
|
(maybe-cmd! "ssh \"~A\" ln -sf \"~A\" \"~A/~A_latest.tar.gz\""
|
|
host tarball release-dir project-name)
|
|
(maybe-cmd! "ssh \"~A\" ln -sf \"~A\" \"~A/~A_latest.tar.gz.asc\""
|
|
host signature release-dir project-name))
|
|
|
|
(defun upload-version-file (version version-file host version-file-dir)
|
|
(format t "Uploading ~A...~%" version-file)
|
|
(with-open-file (out version-file :direction :output)
|
|
(write-string version out))
|
|
(maybe-cmd! "scp \"~A\" \"~A\":\"~A\"" version-file host version-file-dir)
|
|
(maybe-cmd! "rm \"~A\"" version-file))
|
|
|
|
(defun maybe-clean-things-up (tarball signature)
|
|
(when (y-or-n-p "Clean local tarball and signature?")
|
|
(cmd! "rm \"~A\" \"~A\"" tarball signature)))
|
|
|
|
(defun run (force version)
|
|
(check-for-unrecorded-changes force)
|
|
;; figure out what version we'll be preparing.
|
|
(unless version
|
|
(let* ((current-version (find-current-version))
|
|
(next-versions (new-version-number-candidates current-version)))
|
|
(setf version (or (ask-user-for-version current-version next-versions)
|
|
(die "invalid selection.")))))
|
|
(git-tag-tree version)
|
|
(let* ((distname (format nil "~A_~A" *project-name* version))
|
|
(tarball (format nil "~A.tar.gz" distname))
|
|
(signature (format nil "~A.asc" tarball)))
|
|
;; package things up.
|
|
(create-dist version distname)
|
|
(tar-and-sign distname tarball)
|
|
;; upload.
|
|
(upload-tarball tarball signature *remote-directory*)
|
|
(update-remote-links tarball signature *host* *release-dir* *project-name*)
|
|
(when *version-file*
|
|
(upload-version-file version *version-file* *host* *version-file-dir*))
|
|
;; clean up.
|
|
(maybe-clean-things-up tarball signature)
|
|
;; documentation.
|
|
;; (write-line "Building and uploading documentation...")
|
|
;; (maybe-cmd! "make -C doc upload-docs")
|
|
;; push tags and any outstanding changes.
|
|
(write-line "Pushing tags and changes...")
|
|
(maybe-cmd! "git push --tags origin master")))
|
|
|
|
|
|
;;;; Do it to it
|
|
|
|
(let ((force nil)
|
|
(version nil)
|
|
(args ext:*args*))
|
|
(loop while args
|
|
do (string-case (pop args)
|
|
(("-h" "--help")
|
|
(write-line "No help, sorry. Read the source.")
|
|
(ext:quit 0))
|
|
(("-f" "--force")
|
|
(setf force t))
|
|
(("-v" "--version")
|
|
(setf version (pop args)))
|
|
(("-n" "--dry-run")
|
|
(setf *dry-run* t))
|
|
(t
|
|
(die "Unrecognized argument '~a'" it))))
|
|
(run force version))
|