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

;;;; post-commit.scm


(use svn-post-commit-hooks svn-client utils srfi-1 srfi-13 regex-case versions)


(define +repository+ "http://galinha.ucpel.tche.br/svn/chicken-eggs")
(define +last-revision-file+ "chicken-eggref-post-commit-last-revision")
(define +credentials-file+ "post-commit-credentials")
(define +changed-file+ "chicken-eggref-post-commit-changed")
(define +log-file+ "chicken-eggref-post-commit.log")
(define +cumulative-log-file+ "chicken-eggref-post-commit-cumulative.log")
(define +police-file+ "post-commit-police")
(define +recipients-file+ "post-commit-recipients")


(define *top-revision* #f)
(define *report* #f)

; tags-dir is a directory with files named as software versions (eg. "1.2.29",
; "1.3").  Returns the name of the file corresponding to the greatest software
; version.

(define (pick-latest-version tags-dir)
  (fold
    (lambda (a pick)
      (let ((a-nums (string->version a)))
        (if (or (not pick) (version>? a-nums (string->version pick))) a pick)))
    #f
    (directory tags-dir)))

(define (get-egg-dir eggname)
  (or (let ((tags-dir (make-pathname eggname "tags")))
        (and (file-exists? tags-dir)
             (make-pathname tags-dir (pick-latest-version tags-dir))))
  eggname))

(define (read-egg-files ename f)
  (and (directory? f)
       (let* ((edir (get-egg-dir f))
              (mf (make-pathname edir ename "meta")))
         (and (file-exists? mf)
              (cons mf
               (apply glob
                      (map (lambda (f) (make-pathname edir f) )
                           (cdr (assq 'files (car (read-file mf)))) ) ) ) ) ) ) )

(define (collect-changes . rest)
  (let ((changed '())
        (branch (and (pair? rest) (car rest))))
    (define (find-changed-files)
      (let ((base  (if branch (string-append "release/" branch) "")))
        (process-entry
         (post-commit-changed-files
          +repository+
          base
          "anonymous"
          ""
          *top-revision*) 
         "")))
    (define (process-entry entry name)
      (for-each (cut process-change name <>) (entry-changes entry))
      (hash-table-walk
       (entry-subs entry)
       (lambda (sub-name sub-entry)
         (process-entry sub-entry (string-append name "/" sub-name)))))
    (define (process-change name change)
      (let ((rev (change-rev change)))
        (set! *top-revision* (if *top-revision* (max *top-revision* rev) rev))
        (match (string-split name "/")
          (("release" _ _ "trunk" . _) #f)
          ((_ "trunk" . _) #f)
          (_ (set! changed (cons (substring name 1) changed))))))
    (find-changed-files) 
    changed))

(define (should-autoupdate? path)
  (let ((results (svn-propget "autoupdate" path "anonymous" "" '())))
    (or (null? results)
        (not (string=? (cadar results) "no")))))

(define (egg-info dir)
  (regex-case dir
    ("release/(\\d+)/([^/]+).*" (_ rel ename)
     (values (conc "release/" rel "/" ename) rel ename) )
    (else (values dir "2" dir))))

(define (compute-changed-eggs missing . rest)
  (let* ((branch  (and (pair? rest) (car rest)))
         (changed (if branch (collect-changes branch) (collect-changes))))
    (let loop ((changed changed) (eggs '()))
      (if (null? changed)  (delete-duplicates eggs)
          (let* ((f1   (car changed))
                 (dir0 (pathname-directory f1))
                 (dir  (if (and branch dir0) (string-append "release/" branch "/" dir0) dir0))
                 )

            (if (and dir (not (string-match "release/\\d+" dir)))
                (let-values (((ftop rel ename) (egg-info dir)))
                  (pp `(,ftop ,rel ,ename))
                  ; shouldnt this be dir and not dir0 ?
                  (let ((prefix  (if branch dir (conc ftop "/")))
                        (efs     (read-egg-files ename ftop)))
                    (let-values (((fs others)  
                                  (partition (lambda (x) (string-prefix? prefix x)) (cdr changed))))
                      (cond ((and efs (should-autoupdate? ftop))
                             (let ((m (filter (complement file-exists?) (cdr efs))))
                               (cond ((or (null? m)
                                          (and (= 1 (length m))
                                               (string=? (conc ename ".html") (pathname-strip-directory (car m)))
                                               (let ((meta (with-input-from-file
                                                               (pathname-replace-extension (car m) "meta")
                                                             read)))
                                                 (or (assq 'doc-from-wiki meta)
                                                     (assq 'eggdoc meta) ) ) ) )
                                      (with-output
                                       (lambda ()
                                         (print "Changes for egg " ftop ":")
                                         (pp (cons f1 fs))
                                         (newline) ) )
                                      (loop others (alist-cons rel ename eggs)))
                                     (else
                                      (missing ftop m)
                                      (loop others eggs)))))
                            (else (loop others eggs))))) )
                (loop (cdr changed) eggs)))))) )

(define last-status 0)

(define (runcmd cmd)
  (let ((cmds (sprintf "~a >>~a 2>&1" cmd +log-file+)))
;    (with-output (cut print "running: " cmds))
    (set! last-status (system cmds))
    (zero? last-status)) )

(define (with-output thunk)
  (if *report*
      (thunk)
      (with-output-to-file +log-file+ thunk append:) ) )

(define (mailto addr subj file)
  (void))
;  (runcmd (sprintf "mail  -a \"From: mario@ucpel.tche.br\" -s \"chicken-eggref-post-commit ~a\" ~a <~a" 
;                  subj addr file)))

(define (partition-eggs-by-release eggs)
  (match eggs
    (() '())
    (((rel . eggname) . more)
     (let-values (((es others)
                   (partition (lambda (egg2) (equal? (car egg2) rel)) eggs) ) )
       (alist-cons 
        rel (map cdr es) 
        (partition-eggs-by-release others) ) ) ) ) )

(define (main args)
  (let* ((problems #f)
         (idle #f)
         (toprev (and-let* ((a (member "-revision" args))) (string->number (cadr a))))
         (branch (and-let* ((a (member "-branch" args))) (cadr a)))
         (wiki-prefix (and-let* ((p (and branch (>= (string->number branch) 3) 
                                         (make-pathname "eggref" (->string branch))))) p))
         )
    (delete-file* +log-file+)
    (with-output 
     (cut printf "=================================== ~a~%"
          (seconds->string (current-seconds))))
    (when (member "-report" args) (set! *report* #t))
    (handle-exceptions ex
        (with-output
         (lambda ()
           (print-error-message ex)
           (print-call-chain) 
           (set! problems #t) ) )
      (cond ((and (not *report*) (not (runcmd "svn revert wiki/* && svn up")))
             (with-output (cut print "Updating the repository failed."))
             (set! problems #t) )
            (else
             (set! *top-revision* 
               (or toprev 
                   (and (file-exists? +last-revision-file+)
                        (with-input-from-file +last-revision-file+ read))))
             (with-output (cut print "Previously latest revision is " *top-revision*))
             (let ((eggs (compute-changed-eggs
                           (lambda (egg files)
                             (with-output
                              (cut printf "Files are missing from ~a: ~s~%" egg files))
                             (set! problems #t))
                           branch
                           )))
               (print "after compute-changed-eggs: eggs = " eggs)
               (match-let (((user passwd) (read-file +credentials-file+)))
                 (with-output 
                  (lambda ()
                    (print "Changed eggs:")
                    (pp eggs)))
                 (with-output-to-file +changed-file+ 
                   (lambda ()
                     (for-each pp eggs)
                     (newline)))
                 (cond ((null? eggs)
                        (set! idle #t)
                        (with-output (cut print "Nothing to do.")))
                       ((not *report*)
                        (for-each
                         (match-lambda 
                           ((rel eggs ...)
                            (or (runcmd (sprintf "./eggref-post-commit ~a ~a ~a ~a ~a"
                                                 (if rel (conc "-rel " rel) "")
                                                 (if wiki-prefix (conc "-wiki-prefix " wiki-prefix) "")
                                                 user passwd
                                                 (string-intersperse eggs)))
                               (begin
                                 (with-output
                                  (cut print "eggref-post-commit failed with exit-status " last-status))
                                 (set! problems #t)))) )
                         (partition-eggs-by-release eggs)))))))))
    (unless *report*
      (cond (idle)
            (problems
             (for-each 
              (cut mailto <> "(problem)" +log-file+)
              (remove string-null? (read-lines +police-file+))) )
            (else
             (for-each 
              (cut mailto <> "(update)" +changed-file+)
              (remove string-null? (read-lines +recipients-file+))) ) )
      (when *top-revision*
        (with-output (cut printf "Setting top revision to ~a~%" *top-revision*))
        (with-output-to-file +last-revision-file+
          (cut pp *top-revision*)) )
    (with-output (cut print "(chicken-eggref-post-commit) Finished."))
    (if *report*
        (system (conc "cat " +log-file+))
        (system (sprintf "cat ~a >>~a" +log-file+ +cumulative-log-file+))))
    ))

(main (command-line-arguments))