release.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
release.lisp (9676B)
---
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))