source: project/release/3/eggref-post-commit/trunk/chicken-eggref-post-commit.scm @ 13166

Last change on this file since 13166 was 13166, checked in by Ivan Raikov, 12 years ago

Bug fixes in the eggref-post-commit script.

File size: 7.9 KB
Line 
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))
Note: See TracBrowser for help on using the repository browser.