Skip to content

Commit

Permalink
API for emitting diff output
Browse files Browse the repository at this point in the history 
It can be useful for eggs that use diff output for other purposes
(e.g., salmonella-feeds).
  • Loading branch information
@mario-goulart
mario-goulart committed Nov 13, 2014
1 parent e9a909b commit 3c9699b
Showing 1 changed file with 137 additions and 117 deletions.
254 changes: 137 additions & 117 deletions salmonella-diff.scm
View file
Expand Up @@ -20,8 +20,10 @@
new/missing-egg-test-message

;; procedures
diff->sxml
diff->html
)
sxml-diff->html
)

(import chicken scheme)
(use extras srfi-1 srfi-13 posix files data-structures ports)
Expand Down Expand Up @@ -189,136 +191,154 @@

(define (render-new/missing-eggs new/missing-eggs log out-dir missing? report-uri1 report-uri2)
;; Write html files for installation and test outputs
(unless missing?
(for-each
(lambda (n/m)
(let* ((egg (new/missing-egg-egg n/m))
(test-status (new/missing-egg-test-status n/m))
(test-message (new/missing-egg-test-message n/m))
(install-status (new/missing-egg-install-status n/m))
(install-message (new/missing-egg-install-message n/m)))
(write-action-report! egg 'install log 2 out-dir)
(write-action-report! egg 'test log 2 out-dir)))
new/missing-eggs))
(let ((link-mode? (and report-uri1 #t)))
(unless (or missing? link-mode?)
(for-each
(lambda (n/m)
(let* ((egg (new/missing-egg-egg n/m))
(test-status (new/missing-egg-test-status n/m))
(test-message (new/missing-egg-test-message n/m))
(install-status (new/missing-egg-install-status n/m))
(install-message (new/missing-egg-install-message n/m)))
(write-action-report! egg 'install log 2 out-dir)
(write-action-report! egg 'test log 2 out-dir)))
new/missing-eggs))

(zebra-table
(if missing?
'("Egg")
'("Egg" "Install status" "Test status"))
(map (lambda (n/m)
(let ((egg (new/missing-egg-egg n/m))
(test-status (new/missing-egg-test-status n/m))
(install-status (new/missing-egg-install-status n/m)))
(if missing?
(list (new/missing-egg-egg n/m))
(list (new/missing-egg-egg n/m)
`(,(link-egg-install
egg
2
link-text: (if (and install-status
(zero? install-status))
"ok"
(sprintf "fail (status=~a)"
install-status))
report-uri: report-uri2))
(if (or (not test-status) (eq? test-status -1))
"No test"
`(,(link-egg-test
egg
test-status
2
link-text: (if (zero? test-status)
"ok"
(sprintf "fail (status=~a)"
test-status))
report-uri: report-uri2)))))))
new/missing-eggs))))

(zebra-table (if missing?
'("Egg")
'("Egg" "Install status" "Test status"))
(map (lambda (n/m)
(let ((egg (new/missing-egg-egg n/m))
(test-status (new/missing-egg-test-status n/m))
(install-status (new/missing-egg-install-status n/m)))
(if missing?
(list (new/missing-egg-egg n/m))
(list (new/missing-egg-egg n/m)
`(,(link-egg-install
egg
2
link-text: (if (and install-status
(zero? install-status))
"ok"
(sprintf "fail (status=~a)"
install-status))
report-uri: report-uri2))
(if (or (not test-status) (eq? test-status -1))
"No test"
`(,(link-egg-test
egg
test-status
2
link-text: (if (zero? test-status)
"ok"
(sprintf "fail (status=~a)"
test-status))
report-uri: report-uri2)))))))
new/missing-eggs)))
(define (render-test-status status)
(cond ((not status) "")
((eq? status -1) "No test")
(else status)))

(define (diff->html log-file-1 log-file-2 out-dir #!key label1 label2 report-uri1 report-uri2)
(define (diff->sxml log-file-1 log-file-2 out-dir #!key label1 label2 report-uri1 report-uri2)
;; Return SXML code representing the diff between log-file-1 and
;; log-file-2. If report-uri1 is #f ("link mode"), will write HTML
;; pages for installation and test reports under out-dir.
(let* ((log1 (read-log-file log-file-1))
(log2 (read-log-file log-file-2))
(diff (salmonella-diff log1 log2))
(diffs (car diff))
(new/missing-eggs (cadr diff))
;; Link mode indicates salmonella-diff will just link to
;; reports' pages -- it will not write HTML pages for install
;; an tests
;; reports' pages -- it will not write HTML pages for
;; installation and test reports
(link-mode? (and report-uri1 #t)))
(sxml-diff->html
(page-template
`((h1 "Salmonella diff")
(h2 "Log files")
(table
(tr (td 1) (td ,(or label1 log-file-1)))
(tr (td 2) (td ,(or label2 log-file-2))))
,(render-summary log1 log2)
(h2 "Differences detailed")
,(if (null? diffs)
'(p "No differences")
(zebra-table
'("Egg" "Phase" "Status 1" "Status 2" "Output 1" "Output 2")
(map (lambda (d)
(let ((egg (diff-egg d))
(action (diff-action d)))
(when (and (memq action '(install test))
(not link-mode?))
(write-action-report! egg action log1 1 out-dir)
(write-action-report! egg action log2 2 out-dir))
(case action
((install)
(list egg
"Installation"
(diff-status-1 d)
(diff-status-2 d)
(link-egg-install egg 1 report-uri: report-uri1)
(link-egg-install egg 2 report-uri: report-uri2)))
((test)
(let ((status-1 (diff-status-1 d))
(status-2 (diff-status-2 d)))
(list egg
"Test"
(if (eq? status-1 -1) "No test" status-1)
(if (eq? status-2 -1) "No test" status-2)
(link-egg-test egg status-1 1 report-uri: report-uri1)
(link-egg-test egg status-2 2 report-uri: report-uri1))))
((version)
(list egg
"Version check"
(diff-status-1 d)
(diff-status-2 d)
""
"")))))
diffs)))
,(let ((new-eggs (filter (lambda (n/m)
(eq? 'new (new/missing-egg-status n/m)))
new/missing-eggs))
(missing-eggs (filter (lambda (n/m)
(eq? 'missing (new/missing-egg-status n/m)))
new/missing-eggs)))
(cond ((and (null? new-eggs) (null? missing-eggs))
'())
((null? new-eggs)
`((h2 (@ (id "missing-eggs")) "Missing eggs")
,(render-new/missing-eggs missing-eggs log1 out-dir #t report-uri1 report-uri2)))
(else
`((h2 (@ (id "new-eggs")) "New eggs")
,(render-new/missing-eggs new-eggs log2 out-dir #f report-uri1 report-uri2)))))
`((h1 "Salmonella diff")
(h2 "Log files")
(table
(tr (td 1) (td ,(or label1 log-file-1)))
(tr (td 2) (td ,(or label2 log-file-2))))
,(render-summary log1 log2)
(h2 "Differences detailed")
,(if (null? diffs)
'(p "No differences")
(zebra-table
'("Egg" "Phase" "Status 1" "Status 2" "Output 1" "Output 2")
(map (lambda (d)
(let ((egg (diff-egg d))
(action (diff-action d)))
(when (and (memq action '(install test))
(not link-mode?))
(write-action-report! egg action log1 1 out-dir)
(write-action-report! egg action log2 2 out-dir))
(case action
((install)
(list egg
"Installation"
(diff-status-1 d)
(diff-status-2 d)
(link-egg-install egg 1 report-uri: report-uri1)
(link-egg-install egg 2 report-uri: report-uri2)))
((test)
(let ((status-1 (diff-status-1 d))
(status-2 (diff-status-2 d)))
(list egg
"Test"
(render-test-status status-1)
(render-test-status status-2)
(link-egg-test egg status-1 1 report-uri: report-uri1)
(link-egg-test egg status-2 2 report-uri: report-uri2))))
((version)
(list egg
"Version check"
(diff-status-1 d)
(diff-status-2 d)
""
"")))))
diffs)))
,(let ((new-eggs (filter (lambda (n/m)
(eq? 'new (new/missing-egg-status n/m)))
new/missing-eggs))
(missing-eggs (filter (lambda (n/m)
(eq? 'missing (new/missing-egg-status n/m)))
new/missing-eggs)))
(cond ((and (null? new-eggs) (null? missing-eggs))
'())
((null? new-eggs)
`((h2 (@ (id "missing-eggs")) "Missing eggs")
,(render-new/missing-eggs missing-eggs log1 out-dir #t report-uri1 report-uri2)))
(else
`((h2 (@ (id "new-eggs")) "New eggs")
,(render-new/missing-eggs new-eggs log2 out-dir #f report-uri1 report-uri2)))))

(h2 (@ (id "environment-information")) "Environments information")
(h3 (@ (id "env1")) "Environment 1")
(pre ,(salmonella-info log1))
(h3 (@ (id "env2")) "Environment 2")
(pre ,(salmonella-info log2)))))

(h2 (@ (id "environment-information")) "Environments information")
(h3 (@ (id "env1")) "Environment 1")
(pre ,(salmonella-info log1))
(h3 (@ (id "env2")) "Environment 2")
(pre ,(salmonella-info log2)))
title: "Salmonella diff")
(make-pathname out-dir "index.html"))))
(define (diff->html log-file-1 log-file-2 out-dir #!key label1 label2 report-uri1 report-uri2)
(let ((content (page-template
(diff->sxml log-file-1 log-file-2 out-dir
label1: label1
label2: label2
report-uri1: report-uri1
report-uri2: report-uri2)
title: "Salmonella diff")))
(sxml-diff->html content (make-pathname out-dir "index.html"))))


;;; SXML utils
(define (sxml-diff->html sxml output-file)
(with-output-to-file output-file
(lambda ()
(let* ((rules `((literal *preorder* . ,(lambda (t b) b))
. ,universal-conversion-rules*)))
(SRV:send-reply (pre-post-order* sxml rules))))))
(define (->html)
(let* ((rules `((literal *preorder* . ,(lambda (t b) b))
. ,universal-conversion-rules*)))
(SRV:send-reply (pre-post-order* sxml rules))))
(if output-file
(with-output-to-file output-file ->html)
(with-output-to-string ->html)))

(define (page-template content #!key title)
`((literal
Expand Down

0 comments on commit 3c9699b

Please sign in to comment.