Introduction
Introduction Statistics Contact Development Disclaimer Help
trelease.lisp - clic - Clic is an command line interactive client for gopher wr…
git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
Log
Files
Refs
Tags
LICENSE
---
trelease.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))
You are viewing proxied material from bitreich.org. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.