source: project/release/3/egg-post-commit/trunk/post-commit.scm @ 8895

Last change on this file since 8895 was 8895, checked in by felix winkelmann, 12 years ago

updates, update info in generated wikipage

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