184 lines
6.1 KiB
Scheme
184 lines
6.1 KiB
Scheme
;;
|
|
;; export-web-static.scm
|
|
;;
|
|
;; Generate private member info page.
|
|
;;
|
|
;; ISC License
|
|
;;
|
|
;; Copyright 2023 Brmlab, z.s.
|
|
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
;;
|
|
;; Permission to use, copy, modify, and/or distribute this software
|
|
;; for any purpose with or without fee is hereby granted, provided
|
|
;; that the above copyright notice and this permission notice appear
|
|
;; in all copies.
|
|
;;
|
|
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
|
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
|
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
|
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
|
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
;;
|
|
|
|
(declare (unit export-web-static))
|
|
|
|
(module
|
|
export-web-static
|
|
(
|
|
gen-html-members
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken format)
|
|
(chicken pathname)
|
|
(chicken string)
|
|
(chicken file)
|
|
brmember
|
|
util-dir
|
|
mbase
|
|
members-payments
|
|
cal-day
|
|
util-git
|
|
configuration
|
|
texts)
|
|
|
|
;; HTML entities
|
|
(define (sanitize-html str)
|
|
(string-translate*
|
|
str
|
|
'(("&" . "&") ("<" . "<") (">" . ">") ("\"" . """))))
|
|
|
|
;; Prints the HTML summary for given member to current-output-port
|
|
(define (print-html-member mr)
|
|
(let ((bhs (brmember-balance-history mr)))
|
|
(print "<!DOCTYPE html>")
|
|
(print "<html>")
|
|
(print "<head>")
|
|
(print "<meta charset=\"utf-8\">")
|
|
(print "<title>Brmlab Member: "
|
|
(brmember-nick mr)
|
|
"</title>")
|
|
(print "<style>")
|
|
(print "body{padding:0px;margin:0px}")
|
|
(print "h1{padding:0px;margin:0px;text-indent:16px}")
|
|
(print "h1:after{display:block;border-top:1px solid #8cacbb;border-bottom:1px solid #8cacbb;padding:10px;content:\"\";background:#dee7ec;height:16px;padding:0px}")
|
|
(print "tbody td{border-top:1px solid #8cacbb}")
|
|
(print "th+th,td+td{border-left:1px solid #8cacbb}")
|
|
(print "table{border-collapse:collapse;width:100%}")
|
|
(print ".r{text-align:right}")
|
|
(print ".gc{display:grid}")
|
|
(print ".gl{grid-column:1 / 2}")
|
|
(print ".gr{grid-column:1 / 2}")
|
|
(print "@media(min-width: 1200px){")
|
|
(print ".gc{grid-auto-columns:50%}")
|
|
(print ".gl{grid-column:1 / 2}")
|
|
(print ".gr{grid-column:2 / 3}")
|
|
(print "}")
|
|
(print ".bi{margin:32px;border:1px solid #8cacbb}")
|
|
(print "h2{margin:0px;padding:0px;text-indent:16px;border-bottom:1px solid #8cacbb}")
|
|
(print "h3{margin:0px;padding:0px;text-indent:16px;border-bottom:1px solid #8cacbb;border-top:1px solid #8cacbb}")
|
|
(print "pre{margin-left: 32px}")
|
|
(print "dl{margin-left: 32px;margin-right:32px;display:grid;grid-column-gap:0px}")
|
|
(print "dt{grid-column:1/2;text-align:right}")
|
|
(print "dd+dt,dd+dt+dd{border-top:1px solid #8cacbb}")
|
|
(print "dd{grid-column:2/3;font-weight:bold;margin:0px;padding-left:16px}")
|
|
(print "footer{background:#dee7ec;border-top:1px solid #8cacbb;padding:16px}")
|
|
(print "</style>")
|
|
(print "</head>")
|
|
(print "<body>")
|
|
(print "<h1>Brmlab Member: " (brmember-nick mr) "</h1>")
|
|
(print "<div class=\"gc\">")
|
|
(print "<div class=\"gl\">")
|
|
(print "<div class=\"bi\">")
|
|
;;(print "<h2>Basic Information</h2>")
|
|
(print "<dl>")
|
|
(print "<dt>Nickname/Username<br>(Přezdívka/Uživatelské jméno)</dt><dd>"
|
|
(brmember-nick mr) "</dd>")
|
|
(print "<dt>Member ID, Variable Symbol for Payments<br>(Členské číslo, variabilní symbol plateb)</dt><dd>"
|
|
(brmember-id mr) "</dd>")
|
|
(print "<dt>Balance in CZK<br>(Zůstatek v Kč)</dt><dd>" (caar (reverse bhs)) "</dd>")
|
|
(print "<dt>Account for Payments<br>(Účet pro platbu příspěvků)</dt><dd>2500079551/2010</dd>")
|
|
(print "</dl>")
|
|
(print "</div>")
|
|
(print "<div class=\"bi\">")
|
|
(print "<h2>Payments History</h2>")
|
|
(print "<table>")
|
|
(print "<thead><tr><th>Date</th><th>Type</th><th>Comment</th><th>Amount</th><th>Currency</th><th>Amount [CZK]</th><th>Balance</th></tr></thead>")
|
|
(print "<tbody>")
|
|
(for-each (lambda (hr)
|
|
(print "<tr><td>"
|
|
(cal-day->string (cadr hr))
|
|
"</td><td>"
|
|
(list-ref hr 6)
|
|
"</td><td>"
|
|
(list-ref hr 4)
|
|
"</td><td class=\"r\">"
|
|
(exact->inexact (list-ref hr 2))
|
|
"</td><td>"
|
|
(list-ref hr 3)
|
|
"</td><td class=\"r\">"
|
|
(exact->inexact (list-ref hr 5))
|
|
"</td><td class=\"r\">"
|
|
(exact->inexact (car hr))
|
|
"</td></tr>"
|
|
))
|
|
bhs)
|
|
(print "</tbody>")
|
|
(print "</table>")
|
|
(print "</div>")
|
|
(print "</div>")
|
|
(print "<div class=\"gr\">")
|
|
(print "<div class=\"bi\">")
|
|
(print "<h2>Member file</h2>")
|
|
(print "<pre>")
|
|
(print (sanitize-html
|
|
(string-intersperse (brmember-source mr) "\n")))
|
|
(print "</pre>")
|
|
(print "<h3>Changes History</h3>")
|
|
(print "<pre>")
|
|
(for-each (lambda (l)
|
|
(print (sanitize-html l)))
|
|
((git (*members-directory*) 'output)
|
|
'log '-p '--
|
|
(brmember-file-name mr)))
|
|
(print "</pre>")
|
|
(print "</div>")
|
|
(print "</div>")
|
|
(print "</div>")
|
|
(print "<footer>Generated by " banner-line "</footer>")
|
|
(print "</body>")
|
|
(print "</html>")))
|
|
|
|
;; Generates a single member in given directory
|
|
(define (gen-html-member mr dir)
|
|
(let ((fname (format "~A.html" (brmember-id mr))))
|
|
(with-output-to-file (make-pathname dir (format "~A.html" (brmember-nick mr)))
|
|
(lambda ()
|
|
(print-html-member mr)))))
|
|
|
|
;; Removes all generated files which do not belong to any member
|
|
(define (clean-members-files mb dir)
|
|
(let loop ((fns (directory dir)))
|
|
(when (not (null? fns))
|
|
(let* ((fn (car fns))
|
|
(utl (string-split fn "."))
|
|
(username (car utl))
|
|
(mr (find-member-by-nick mb username)))
|
|
(when (or (not mr)
|
|
(brmember-destroyed? mr))
|
|
(delete-file (make-pathname dir fn)))
|
|
(loop (cdr fns))))))
|
|
|
|
;; Generates all members in given directory
|
|
(define (gen-html-members mb dir)
|
|
(ensure-directory dir)
|
|
(with-mbase-progress%
|
|
mb dir mr
|
|
(gen-html-member mr dir))
|
|
(clean-members-files mb dir))
|
|
|
|
)
|