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

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

created tags and branches

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