3rdparties/software/trivial-features-20200427-git/release.lisp (9676 bytes)
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* "trivial-features") 10 (defparameter *asdf-file* (format nil "~A.asd" *project-name*)) 11 12 (defparameter *host* "common-lisp.net") 13 (defparameter *release-dir* 14 (format nil "public_html/tarballs/~A/" *project-name*)) 15 16 (defparameter *version-file* nil) 17 (defparameter *version-file-dir* nil) 18 19 ;;;; -------------------------------------------------------------------------- 20 21 ;;;; Utilities 22 23 (defun ensure-list (x) 24 (if (listp x) x (list x))) 25 26 (defmacro string-case (expression &body clauses) 27 `(let ((it ,expression)) ; yes, anaphoric, deal with it. 28 (cond 29 ,@(loop for clause in clauses collect 30 `((or ,@(loop for alternative in (ensure-list (first clause)) 31 collect (or (eq t alternative) 32 `(string= it ,alternative)))) 33 ,@(rest clause)))))) 34 35 (defparameter *development-mode* t) 36 37 (defun die (format-control &rest format-args) 38 (format *error-output* "~?" format-control format-args) 39 (if *development-mode* 40 (cerror "continue" "die") 41 (ext:quit 1))) 42 43 (defun numeric-split (string) 44 (if (digit-char-p (char string 0)) 45 (multiple-value-bind (number next-position) 46 (parse-integer string :junk-allowed t) 47 (cons number (when (< next-position (length string)) 48 (numeric-split (subseq string next-position))))) 49 (let ((next-digit-position (position-if #'digit-char-p string))) 50 (if next-digit-position 51 (cons (subseq string 0 next-digit-position) 52 (numeric-split (subseq string next-digit-position))) 53 (list string))))) 54 55 (defun natural-string-< (s1 s2) 56 (labels ((aux< (l1 l2) 57 (cond ((null l1) (not (null l2))) 58 ((null l2) nil) 59 (t (destructuring-bind (x . xs) l1 60 (destructuring-bind (y . ys) l2 61 (cond ((and (numberp x) (stringp y)) 62 t) 63 ((and (numberp y) (stringp x)) 64 nil) 65 ((and (numberp x) (numberp y)) 66 (or (< x y) (and (= x y) (aux< xs ys)))) 67 (t 68 (or (string-lessp x y) 69 (and (string-equal x y) 70 (aux< xs ys))))))))))) 71 (aux< (numeric-split s1) 72 (numeric-split s2)))) 73 74 ;;;; Running commands 75 76 (defparameter *dry-run* nil) 77 78 (defun cmd? (format-control &rest format-args) 79 (let ((cmd (format nil "~?" format-control format-args))) 80 (with-open-stream (s1 (ext:run-shell-command cmd :output :stream)) 81 (loop for line = (read-line s1 nil nil) 82 while line 83 collect line)))) 84 85 ;; XXX: quote arguments. 86 (defun cmd (format-control &rest format-args) 87 (when *development-mode* 88 (format *debug-io* "CMD: ~?~%" format-control format-args)) 89 (let ((ret (ext:run-shell-command (format nil "~?" format-control format-args)))) 90 (or (null ret) 91 (zerop ret)))) 92 93 (defun cmd! (format-control &rest format-args) 94 (or (apply #'cmd format-control format-args) 95 (die "cmd '~?' failed." format-control format-args))) 96 97 (defun maybe-cmd! (format-control &rest format-args) 98 (if *dry-run* 99 (format t "SUPPRESSING: ~?~%" format-control format-args) 100 (apply #'cmd! format-control format-args))) 101 102 ;;;; 103 104 (defun find-current-version () 105 (subseq (reduce (lambda (x y) (if (natural-string-< x y) y x)) 106 (cmd? "git tag -l v\\*")) 107 1)) 108 109 (defun parse-version (string) 110 (mapcar (lambda (x) 111 (parse-integer x :junk-allowed t)) 112 (loop repeat 3 ; XXX: parameterize 113 for el in (regexp-split "\\." (find-current-version)) 114 collect el))) 115 116 (defun check-for-unrecorded-changes (&optional force) 117 (unless (cmd "git diff --exit-code") 118 (write-line "Unrecorded changes.") 119 (if force 120 (write-line "Continuing anyway.") 121 (die "Aborting.~@ 122 Use -f or --force if you want to make a release anyway.")))) 123 124 (defun new-version-number-candidates (current-version) 125 (let ((current-version (parse-version current-version))) 126 (labels ((alternatives (before after) 127 (when after 128 (cons (append before (list (1+ (first after))) 129 (mapcar (constantly 0) (rest after))) 130 (alternatives (append before (list (first after))) 131 (rest after)))))) 132 (loop for alt in (alternatives nil current-version) 133 collect (reduce (lambda (acc next) 134 (format nil "~a.~a" acc next)) 135 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 (with-open-file (in path-in :direction :input) 153 (with-open-file (out path-out :direction :output) 154 (loop for line = (read-line in nil nil) while line 155 do (write-line line out) 156 when (string= #1="(defsystem " line 157 :end2 (min (length #1#) (length 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 (maybe-cmd! "echo -n \"~A\" > \"~A\"" version version-file) 192 (maybe-cmd! "scp \"~A\" \"~A\":\"~A\"" version-file host version-file-dir) 193 (maybe-cmd! "rm \"~A\"" version-file)) 194 195 (defun maybe-clean-things-up (tarball signature) 196 (when (y-or-n-p "Clean local tarball and signature?") 197 (cmd! "rm \"~A\" \"~A\"" tarball signature))) 198 199 (defun run (force version) 200 (check-for-unrecorded-changes force) 201 ;; figure out what version we'll be preparing. 202 (unless version 203 (let* ((current-version (find-current-version)) 204 (next-versions (new-version-number-candidates current-version))) 205 (setf version (or (ask-user-for-version current-version next-versions) 206 (die "invalid selection."))))) 207 (git-tag-tree version) 208 (let* ((distname (format nil "~A_~A" *project-name* version)) 209 (tarball (format nil "~A.tar.gz" distname)) 210 (signature (format nil "~A.asc" tarball))) 211 ;; package things up. 212 (create-dist version distname) 213 (tar-and-sign distname tarball) 214 ;; upload. 215 (upload-tarball tarball signature *remote-directory*) 216 (update-remote-links tarball signature *host* *release-dir* *project-name*) 217 (when *version-file* 218 (upload-version-file version *version-file* *host* *version-file-dir*)) 219 ;; clean up. 220 (maybe-clean-things-up tarball signature) 221 ;; documentation. 222 ;; (write-line "Building and uploading documentation...") 223 ;; (maybe-cmd! "make -C doc upload-docs") 224 ;; push tags and any outstanding changes. 225 (write-line "Pushing tags and changes...") 226 (maybe-cmd! "git push --tags origin master"))) 227 228 229 ;;;; Do it to it 230 231 (let ((force nil) 232 (version nil) 233 (args ext:*args*)) 234 (loop while args 235 do (string-case (pop args) 236 (("-h" "--help") 237 (write-line "No help, sorry. Read the source.") 238 (ext:quit 0)) 239 (("-f" "--force") 240 (setf force t)) 241 (("-v" "--version") 242 (setf version (pop args))) 243 (("-n" "--dry-run") 244 (setf *dry-run* t)) 245 (t 246 (die "Unrecognized argument '~a'" it)))) 247 (run force version))