release.lisp - clic - Clic is an command line interactive client for gopher wri… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
release.lisp (9875B) | |
--- | |
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-garbage") | |
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 clau… | |
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 form… | |
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 initia… | |
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 (let ((current-version (parse-version current-version))) | |
128 (labels ((alternatives (before after) | |
129 (when after | |
130 (cons (append before (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 current-version) | |
135 collect (reduce (lambda (acc next) | |
136 (format nil "~a.~a" acc next)) | |
137 alt))))) | |
138 | |
139 (defun ask-user-for-version (current-version next-versions) | |
140 (format *query-io* "Current version is ~A. Which will be the next one?… | |
141 current-version) | |
142 (loop for i from 1 and version in next-versions | |
143 do (format *query-io* "~T~A) ~A~%" i version)) | |
144 (format *query-io* "? ") | |
145 (finish-output *query-io*) | |
146 (nth (1- (parse-integer (read-line) :junk-allowed t)) | |
147 next-versions)) | |
148 | |
149 (defun git-tag-tree (version) | |
150 (write-line "Tagging the tree...") | |
151 (maybe-cmd! "git tag \"v~A\"" version)) | |
152 | |
153 (defun add-version-to-system-file (version path-in path-out) | |
154 (let ((defsystem-line (format nil "(defsystem ~A" *project-name*))) | |
155 (with-open-file (in path-in :direction :input) | |
156 (with-open-file (out path-out :direction :output) | |
157 (loop for line = (read-line in nil nil) while line | |
158 do (write-line line out) | |
159 when (string= defsystem-line line) | |
160 do (format out " :version ~s~%" version)))))) | |
161 | |
162 (defun create-dist (version distname) | |
163 (write-line "Creating distribution...") | |
164 (cmd! "mkdir \"~a\"" distname) | |
165 (cmd! "git archive master | tar xC \"~A\"" distname) | |
166 (format t "Updating ~A with new version: ~A~%" *asdf-file* version) | |
167 (let* ((asdf-file-path (format nil "~A/~A" distname *asdf-file*)) | |
168 (tmp-asdf-file-path (format nil "~a.tmp" asdf-file-path))) | |
169 (add-version-to-system-file version asdf-file-path tmp-asdf-file-pat… | |
170 (cmd! "mv \"~a\" \"~a\"" tmp-asdf-file-path asdf-file-path))) | |
171 | |
172 (defun tar-and-sign (distname tarball) | |
173 (write-line "Creating and signing tarball...") | |
174 (cmd! "tar czf \"~a\" \"~a\"" tarball distname) | |
175 (cmd! "gpg -b -a \"~a\"" tarball)) | |
176 | |
177 (defparameter *remote-directory* (format nil "~A:~A" *host* *release-dir… | |
178 | |
179 (defun upload-tarball (tarball signature remote-directory) | |
180 (write-line "Copying tarball to web server...") | |
181 (maybe-cmd! "scp \"~A\" \"~A\" \"~A\"" tarball signature remote-direct… | |
182 (format t "Uploaded ~A and ~A.~%" tarball signature)) | |
183 | |
184 (defun update-remote-links (tarball signature host release-dir project-n… | |
185 (format t "Updating ~A_latest links...~%" project-name) | |
186 (maybe-cmd! "ssh \"~A\" ln -sf \"~A\" \"~A/~A_latest.tar.gz\"" | |
187 host tarball release-dir project-name) | |
188 (maybe-cmd! "ssh \"~A\" ln -sf \"~A\" \"~A/~A_latest.tar.gz.asc\"" | |
189 host signature release-dir project-name)) | |
190 | |
191 (defun upload-version-file (version version-file host version-file-dir) | |
192 (format t "Uploading ~A...~%" version-file) | |
193 (with-open-file (out version-file :direction :output) | |
194 (write-string version out)) | |
195 (maybe-cmd! "scp \"~A\" \"~A\":\"~A\"" version-file host version-file-… | |
196 (maybe-cmd! "rm \"~A\"" version-file)) | |
197 | |
198 (defun maybe-clean-things-up (tarball signature) | |
199 (when (y-or-n-p "Clean local tarball and signature?") | |
200 (cmd! "rm \"~A\" \"~A\"" tarball signature))) | |
201 | |
202 (defun run (force version) | |
203 (check-for-unrecorded-changes force) | |
204 ;; figure out what version we'll be preparing. | |
205 (unless version | |
206 (let* ((current-version (find-current-version)) | |
207 (next-versions (new-version-number-candidates current-version… | |
208 (setf version (or (ask-user-for-version current-version next-versi… | |
209 (die "invalid selection."))))) | |
210 (git-tag-tree version) | |
211 (let* ((distname (format nil "~A_~A" *project-name* version)) | |
212 (tarball (format nil "~A.tar.gz" distname)) | |
213 (signature (format nil "~A.asc" tarball))) | |
214 ;; package things up. | |
215 (create-dist version distname) | |
216 (tar-and-sign distname tarball) | |
217 ;; upload. | |
218 (upload-tarball tarball signature *remote-directory*) | |
219 (update-remote-links tarball signature *host* *release-dir* *project… | |
220 (when *version-file* | |
221 (upload-version-file version *version-file* *host* *version-file-d… | |
222 ;; clean up. | |
223 (maybe-clean-things-up tarball signature) | |
224 ;; documentation. | |
225 ;; (write-line "Building and uploading documentation...") | |
226 ;; (maybe-cmd! "make -C doc upload-docs") | |
227 ;; push tags and any outstanding changes. | |
228 (write-line "Pushing tags and changes...") | |
229 (maybe-cmd! "git push --tags origin master"))) | |
230 | |
231 | |
232 ;;;; Do it to it | |
233 | |
234 (let ((force nil) | |
235 (version nil) | |
236 (args ext:*args*)) | |
237 (loop while args | |
238 do (string-case (pop args) | |
239 (("-h" "--help") | |
240 (write-line "No help, sorry. Read the source.") | |
241 (ext:quit 0)) | |
242 (("-f" "--force") | |
243 (setf force t)) | |
244 (("-v" "--version") | |
245 (setf version (pop args))) | |
246 (("-n" "--dry-run") | |
247 (setf *dry-run* t)) | |
248 (t | |
249 (die "Unrecognized argument '~a'" it)))) | |
250 (run force version)) |