1 | ;;;; post-commit.scm |
---|
2 | |
---|
3 | |
---|
4 | (use svn-post-commit-hooks svn-client utils srfi-1 srfi-13 regex-case versions) |
---|
5 | |
---|
6 | |
---|
7 | (define +repository+ "http://galinha.ucpel.tche.br/svn/chicken-eggs") |
---|
8 | (define +last-revision-file+ "chicken-eggref-post-commit-last-revision") |
---|
9 | (define +credentials-file+ "post-commit-credentials") |
---|
10 | (define +changed-file+ "chicken-eggref-post-commit-changed") |
---|
11 | (define +log-file+ "chicken-eggref-post-commit.log") |
---|
12 | (define +cumulative-log-file+ "chicken-eggref-post-commit-cumulative.log") |
---|
13 | (define +police-file+ "post-commit-police") |
---|
14 | (define +recipients-file+ "post-commit-recipients") |
---|
15 | |
---|
16 | |
---|
17 | (define *top-revision* #f) |
---|
18 | (define *report* #f) |
---|
19 | |
---|
20 | ; tags-dir is a directory with files named as software versions (eg. "1.2.29", |
---|
21 | ; "1.3"). Returns the name of the file corresponding to the greatest software |
---|
22 | ; version. |
---|
23 | |
---|
24 | (define (pick-latest-version tags-dir) |
---|
25 | (fold |
---|
26 | (lambda (a pick) |
---|
27 | (let ((a-nums (string->version a))) |
---|
28 | (if (or (not pick) (version>? a-nums (string->version pick))) a pick))) |
---|
29 | #f |
---|
30 | (directory tags-dir))) |
---|
31 | |
---|
32 | (define (get-egg-dir eggname) |
---|
33 | (or (let ((tags-dir (make-pathname eggname "tags"))) |
---|
34 | (and (file-exists? tags-dir) |
---|
35 | (make-pathname tags-dir (pick-latest-version tags-dir)))) |
---|
36 | eggname)) |
---|
37 | |
---|
38 | (define (read-egg-files ename f) |
---|
39 | (and (directory? f) |
---|
40 | (let* ((edir (get-egg-dir f)) |
---|
41 | (mf (make-pathname edir ename "meta"))) |
---|
42 | (and (file-exists? mf) |
---|
43 | (cons mf |
---|
44 | (apply glob |
---|
45 | (map (lambda (f) (make-pathname edir f) ) |
---|
46 | (cdr (assq 'files (car (read-file mf)))) ) ) ) ) ) ) ) |
---|
47 | |
---|
48 | (define (collect-changes . rest) |
---|
49 | (let ((changed '()) |
---|
50 | (branch (and (pair? rest) (car rest)))) |
---|
51 | (define (find-changed-files) |
---|
52 | (let ((base (if branch (string-append "release/" branch) ""))) |
---|
53 | (process-entry |
---|
54 | (post-commit-changed-files |
---|
55 | +repository+ |
---|
56 | base |
---|
57 | "anonymous" |
---|
58 | "" |
---|
59 | *top-revision*) |
---|
60 | ""))) |
---|
61 | (define (process-entry entry name) |
---|
62 | (for-each (cut process-change name <>) (entry-changes entry)) |
---|
63 | (hash-table-walk |
---|
64 | (entry-subs entry) |
---|
65 | (lambda (sub-name sub-entry) |
---|
66 | (process-entry sub-entry (string-append name "/" sub-name))))) |
---|
67 | (define (process-change name change) |
---|
68 | (let ((rev (change-rev change))) |
---|
69 | (set! *top-revision* (if *top-revision* (max *top-revision* rev) rev)) |
---|
70 | (match (string-split name "/") |
---|
71 | (("release" _ _ "trunk" . _) #f) |
---|
72 | ((_ "trunk" . _) #f) |
---|
73 | (_ (set! changed (cons (substring name 1) changed)))))) |
---|
74 | (find-changed-files) |
---|
75 | changed)) |
---|
76 | |
---|
77 | (define (should-autoupdate? path) |
---|
78 | (let ((results (svn-propget "autoupdate" path "anonymous" "" '()))) |
---|
79 | (or (null? results) |
---|
80 | (not (string=? (cadar results) "no"))))) |
---|
81 | |
---|
82 | (define (egg-info dir) |
---|
83 | (regex-case dir |
---|
84 | ("release/(\\d+)/([^/]+).*" (_ rel ename) |
---|
85 | (values (conc "release/" rel "/" ename) rel ename) ) |
---|
86 | (else (values dir "2" dir)))) |
---|
87 | |
---|
88 | (define (compute-changed-eggs missing . rest) |
---|
89 | (let* ((branch (and (pair? rest) (car rest))) |
---|
90 | (changed (if branch (collect-changes branch) (collect-changes)))) |
---|
91 | (let loop ((changed changed) (eggs '())) |
---|
92 | (if (null? changed) (delete-duplicates eggs) |
---|
93 | (let* ((f1 (car changed)) |
---|
94 | (dir0 (pathname-directory f1)) |
---|
95 | (dir (if (and branch dir0) (string-append "release/" branch "/" dir0) dir0)) |
---|
96 | ) |
---|
97 | |
---|
98 | (if (and dir (not (string-match "release/\\d+" dir))) |
---|
99 | (let-values (((ftop rel ename) (egg-info dir))) |
---|
100 | (pp `(,ftop ,rel ,ename)) |
---|
101 | ; shouldnt this be dir and not dir0 ? |
---|
102 | (let ((prefix (if branch dir (conc ftop "/"))) |
---|
103 | (efs (read-egg-files ename ftop))) |
---|
104 | (let-values (((fs others) |
---|
105 | (partition (lambda (x) (string-prefix? prefix x)) (cdr changed)))) |
---|
106 | (cond ((and efs (should-autoupdate? ftop)) |
---|
107 | (let ((m (filter (complement file-exists?) (cdr efs)))) |
---|
108 | (cond ((or (null? m) |
---|
109 | (and (= 1 (length m)) |
---|
110 | (string=? (conc ename ".html") (pathname-strip-directory (car m))) |
---|
111 | (let ((meta (with-input-from-file |
---|
112 | (pathname-replace-extension (car m) "meta") |
---|
113 | read))) |
---|
114 | (or (assq 'doc-from-wiki meta) |
---|
115 | (assq 'eggdoc meta) ) ) ) ) |
---|
116 | (with-output |
---|
117 | (lambda () |
---|
118 | (print "Changes for egg " ftop ":") |
---|
119 | (pp (cons f1 fs)) |
---|
120 | (newline) ) ) |
---|
121 | (loop others (alist-cons rel ename eggs))) |
---|
122 | (else |
---|
123 | (missing ftop m) |
---|
124 | (loop others eggs))))) |
---|
125 | (else (loop others eggs))))) ) |
---|
126 | (loop (cdr changed) eggs)))))) ) |
---|
127 | |
---|
128 | (define last-status 0) |
---|
129 | |
---|
130 | (define (runcmd cmd) |
---|
131 | (let ((cmds (sprintf "~a >>~a 2>&1" cmd +log-file+))) |
---|
132 | ; (with-output (cut print "running: " cmds)) |
---|
133 | (set! last-status (system cmds)) |
---|
134 | (zero? last-status)) ) |
---|
135 | |
---|
136 | (define (with-output thunk) |
---|
137 | (if *report* |
---|
138 | (thunk) |
---|
139 | (with-output-to-file +log-file+ thunk append:) ) ) |
---|
140 | |
---|
141 | (define (mailto addr subj file) |
---|
142 | (void)) |
---|
143 | ; (runcmd (sprintf "mail -a \"From: mario@ucpel.tche.br\" -s \"chicken-eggref-post-commit ~a\" ~a <~a" |
---|
144 | ; subj addr file))) |
---|
145 | |
---|
146 | (define (partition-eggs-by-release eggs) |
---|
147 | (match eggs |
---|
148 | (() '()) |
---|
149 | (((rel . eggname) . more) |
---|
150 | (let-values (((es others) |
---|
151 | (partition (lambda (egg2) (equal? (car egg2) rel)) eggs) ) ) |
---|
152 | (alist-cons |
---|
153 | rel (map cdr es) |
---|
154 | (partition-eggs-by-release others) ) ) ) ) ) |
---|
155 | |
---|
156 | (define (main args) |
---|
157 | (let* ((problems #f) |
---|
158 | (idle #f) |
---|
159 | (toprev (and-let* ((a (member "-revision" args))) (string->number (cadr a)))) |
---|
160 | (branch (and-let* ((a (member "-branch" args))) (cadr a))) |
---|
161 | (wiki-prefix (and-let* ((p (and branch (>= (string->number branch) 3) |
---|
162 | (make-pathname "eggref" (->string branch))))) p)) |
---|
163 | ) |
---|
164 | (delete-file* +log-file+) |
---|
165 | (with-output |
---|
166 | (cut printf "=================================== ~a~%" |
---|
167 | (seconds->string (current-seconds)))) |
---|
168 | (when (member "-report" args) (set! *report* #t)) |
---|
169 | (handle-exceptions ex |
---|
170 | (with-output |
---|
171 | (lambda () |
---|
172 | (print-error-message ex) |
---|
173 | (print-call-chain) |
---|
174 | (set! problems #t) ) ) |
---|
175 | (cond ((and (not *report*) (not (runcmd "svn revert wiki/* && svn up"))) |
---|
176 | (with-output (cut print "Updating the repository failed.")) |
---|
177 | (set! problems #t) ) |
---|
178 | (else |
---|
179 | (set! *top-revision* |
---|
180 | (or toprev |
---|
181 | (and (file-exists? +last-revision-file+) |
---|
182 | (with-input-from-file +last-revision-file+ read)))) |
---|
183 | (with-output (cut print "Previously latest revision is " *top-revision*)) |
---|
184 | (let ((eggs (compute-changed-eggs |
---|
185 | (lambda (egg files) |
---|
186 | (with-output |
---|
187 | (cut printf "Files are missing from ~a: ~s~%" egg files)) |
---|
188 | (set! problems #t)) |
---|
189 | branch |
---|
190 | ))) |
---|
191 | (print "after compute-changed-eggs: eggs = " eggs) |
---|
192 | (match-let (((user passwd) (read-file +credentials-file+))) |
---|
193 | (with-output |
---|
194 | (lambda () |
---|
195 | (print "Changed eggs:") |
---|
196 | (pp eggs))) |
---|
197 | (with-output-to-file +changed-file+ |
---|
198 | (lambda () |
---|
199 | (for-each pp eggs) |
---|
200 | (newline))) |
---|
201 | (cond ((null? eggs) |
---|
202 | (set! idle #t) |
---|
203 | (with-output (cut print "Nothing to do."))) |
---|
204 | ((not *report*) |
---|
205 | (for-each |
---|
206 | (match-lambda |
---|
207 | ((rel eggs ...) |
---|
208 | (or (runcmd (sprintf "./eggref-post-commit ~a ~a ~a ~a ~a" |
---|
209 | (if rel (conc "-rel " rel) "") |
---|
210 | (if wiki-prefix (conc "-wiki-prefix " wiki-prefix) "") |
---|
211 | user passwd |
---|
212 | (string-intersperse eggs))) |
---|
213 | (begin |
---|
214 | (with-output |
---|
215 | (cut print "eggref-post-commit failed with exit-status " last-status)) |
---|
216 | (set! problems #t)))) ) |
---|
217 | (partition-eggs-by-release eggs))))))))) |
---|
218 | (unless *report* |
---|
219 | (cond (idle) |
---|
220 | (problems |
---|
221 | (for-each |
---|
222 | (cut mailto <> "(problem)" +log-file+) |
---|
223 | (remove string-null? (read-lines +police-file+))) ) |
---|
224 | (else |
---|
225 | (for-each |
---|
226 | (cut mailto <> "(update)" +changed-file+) |
---|
227 | (remove string-null? (read-lines +recipients-file+))) ) ) |
---|
228 | (when *top-revision* |
---|
229 | (with-output (cut printf "Setting top revision to ~a~%" *top-revision*)) |
---|
230 | (with-output-to-file +last-revision-file+ |
---|
231 | (cut pp *top-revision*)) ) |
---|
232 | (with-output (cut print "(chicken-eggref-post-commit) Finished.")) |
---|
233 | (if *report* |
---|
234 | (system (conc "cat " +log-file+)) |
---|
235 | (system (sprintf "cat ~a >>~a" +log-file+ +cumulative-log-file+)))) |
---|
236 | )) |
---|
237 | |
---|
238 | (main (command-line-arguments)) |
---|