what if we went all-in on sxml?
what would that look like? (it would look like this) - rewrote the template in sxml - deleted (first-if) as srfi-1's (find) is the same - made the template function into a factory, which might go faster? - rewrote all the special-page-generator functions to emit sxml
This commit is contained in:
pho4cexa
m455
parent
a916af24aa
commit
d59f70c7ca
1 changed files with 127 additions and 150 deletions
277
main.scm
277
main.scm
|
|
@ -12,6 +12,7 @@
|
|||
(chicken file)
|
||||
sxml-transforms
|
||||
(clojurian syntax)
|
||||
srfi-1
|
||||
)
|
||||
|
||||
(define CLONE-URL (or (get-environment-variable "REPO2HTML_CLONE_URL") "git://git.example.com"))
|
||||
|
|
@ -21,13 +22,6 @@
|
|||
|
||||
;; small utilities ---------------------------------
|
||||
|
||||
;; return the first x in xs for which (pred? member) is true,
|
||||
;; or #f if no such member is found.
|
||||
(define (first-if pred? xs)
|
||||
(cond ((null? xs) #f)
|
||||
((pred? (car xs)) (car xs))
|
||||
(else (first-if pred? (cdr xs)))))
|
||||
|
||||
;; (bail [message [exit-status]])
|
||||
;; end the program immediately.
|
||||
;; if a message is provided, print it to the screen.
|
||||
|
|
@ -71,76 +65,65 @@
|
|||
|
||||
;; main code ---------------------------------
|
||||
|
||||
(define (populate-html-template repository-name source-files-list source-file display-body-thunk)
|
||||
(define-values (_ _ _ _ relative-root) (pathparts source-file))
|
||||
(define css "
|
||||
body {
|
||||
margin: 0 auto;
|
||||
max-width: 700px;
|
||||
}
|
||||
pre, code {
|
||||
background-color: #ffd9df;
|
||||
}
|
||||
pre {
|
||||
padding: 15px 20px;
|
||||
white-space: pre;
|
||||
overflow: scroll;
|
||||
}
|
||||
a { color: blue; }
|
||||
nav a { margin-right: 10px; }
|
||||
hr {
|
||||
border:0;
|
||||
border-bottom: 1px solid black;
|
||||
margin-top: 16px;
|
||||
}
|
||||
td {
|
||||
padding: 0em .5em;
|
||||
vertical-align: top;
|
||||
}
|
||||
#file-path {
|
||||
/* change this to your liking */
|
||||
}")
|
||||
|
||||
(display #<#string-block
|
||||
<!DOCTYPE html>
|
||||
<html lang="en">
|
||||
<head>
|
||||
<title>#{TITLE}</title>
|
||||
<meta charset="utf-8" />
|
||||
<meta name="viewport" content="width=device-width, initial-scale=1.0, user-scalable=yes" />
|
||||
<link rel="icon" href="data:,">
|
||||
<meta name="description" content="#{DESCRIPTION}"/>
|
||||
<style>
|
||||
body {
|
||||
margin: 0 auto;
|
||||
max-width: 700px;
|
||||
}
|
||||
pre, code {
|
||||
background-color: ##ffd9df;
|
||||
}
|
||||
pre {
|
||||
padding: 15px 20px;
|
||||
white-space: pre;
|
||||
overflow: scroll;
|
||||
}
|
||||
a { color: blue; }
|
||||
nav a { margin-right: 10px; }
|
||||
hr {
|
||||
border:0;
|
||||
border-bottom: 1px solid black;
|
||||
margin-top: 16px;
|
||||
}
|
||||
td {
|
||||
padding: 0em .5em;
|
||||
vertical-align: top;
|
||||
}
|
||||
##file-path {
|
||||
/* change this to your liking */
|
||||
}
|
||||
</style>
|
||||
</head>
|
||||
<body>
|
||||
<h1>#{H1}</h1>
|
||||
<h2>#{repository-name}</h2>
|
||||
<p>clone url: #{CLONE-URL}/#{repository-name}</p>
|
||||
<nav>
|
||||
#(if (or (member "README" source-files-list)
|
||||
(member "README.md" source-files-list)
|
||||
(member "README.txt" source-files-list))
|
||||
(string-append "<a href=\"" relative-root "index.html\">about</a>"))
|
||||
<a href="#{relative-root}files.html">files</a>
|
||||
#(cond ((member "LICENSE" source-files-list)
|
||||
(string-append "<a href=\"" relative-root "LICENSE.html\">license</a>"))
|
||||
((member "LICENSE.md" source-files-list)
|
||||
(string-append "<a href=\"" relative-root "LICENSE.md.html\">license</a>")))
|
||||
<a href="#{relative-root}commits.html">commits</a>
|
||||
<a href="#{relative-root}contributors.html">contributors</a>
|
||||
</nav>
|
||||
<hr>
|
||||
string-block
|
||||
)
|
||||
(display-body-thunk)
|
||||
(display #<#string-block
|
||||
</body>
|
||||
</html>
|
||||
string-block
|
||||
))
|
||||
|
||||
(define (display-escaped-html str)
|
||||
(SRV:send-reply (string->goodHTML str)))
|
||||
(define (make-sxml-template-wrapper repository-name source-files-list)
|
||||
(let ((readme-file
|
||||
(find (lambda (x) (member x source-files-list))
|
||||
'("README" "README.md" "README.txt")))
|
||||
(license-file
|
||||
(find (lambda (x) (member x source-files-list))
|
||||
'("LICENSE" "LICENSE.md" "LICENSE.txt"))))
|
||||
(lambda (source-file body-sxml)
|
||||
(define-values (_ _ _ _ relative-root) (pathparts source-file))
|
||||
`(html (@ lang en)
|
||||
(head
|
||||
(title ,TITLE)
|
||||
(meta (@ charset utf-8))
|
||||
(meta (@ (name viewport) (content "width=device-width, initial-scale-1.0, user-scalable=yes")))
|
||||
(link (@ (rel icon) (href "data:,")))
|
||||
(meta (@ (name description) (content ,DESCRIPTION)))
|
||||
(style ,css))
|
||||
(body
|
||||
(h1 ,H1)
|
||||
(h2 ,repository-name)
|
||||
(p "clone url:" ,CLONE-URL "/" ,repository-name)
|
||||
(nav
|
||||
,(when readme-file
|
||||
`(a (@ href ,relative-root "index.html") "about"))
|
||||
(a (@ href ,relative-root "files.html") "files")
|
||||
,(when license-file
|
||||
`(a (@ href ,relative-root ,license-file ".html") "license"))
|
||||
(a (@ href ,relative-root "commits.html") "commits")
|
||||
(a (@ href ,relative-root "contributors.html") "contributors")))
|
||||
(hr)
|
||||
,body-sxml))))
|
||||
|
||||
(define (in-git-directory?)
|
||||
(not (eof-object? (call-with-input-pipe "git rev-parse --git-dir" read-line))))
|
||||
|
|
@ -161,107 +144,101 @@ string-block
|
|||
(call-with-input-pipe read-lines)
|
||||
(string-intersperse "\n")))
|
||||
|
||||
(define (display-source-html source-file) ;; src/main.scm
|
||||
(define-values (_ _ basename extension _) (pathparts source-file))
|
||||
(define (source->sxml source-file) ;; src/main.scm
|
||||
(define-values (_ _ basename extension _)
|
||||
(pathparts source-file))
|
||||
(define (image-link)
|
||||
(format #t "<p><img src=\"~a~a\" /></p>" basename extension))
|
||||
`(p (img (@ src ,basename ,extension))))
|
||||
(define (plaintext)
|
||||
(display "<pre>")
|
||||
(display-escaped-html (git-file->string source-file))
|
||||
(display "</pre>"))
|
||||
`(pre ,(git-file->string source-file)))
|
||||
(define (binary)
|
||||
(display "<p>(Binary file)</p>"))
|
||||
(format #t "<p id=\"file-path\">~a</p>" source-file)
|
||||
(case (string->symbol extension)
|
||||
((.md .markdown)
|
||||
(handle-exceptions exn
|
||||
(begin
|
||||
(display "Error parsing " (current-error-port))
|
||||
(display source-file (current-error-port))
|
||||
(display "\n" (current-error-port))
|
||||
(display "<p><b>There was an error parsing this file as Markdown.</b></p>")
|
||||
(plaintext))
|
||||
(markdown->html (git-file->string source-file))))
|
||||
((.jpg .jpeg .png .gif .webp .webm .apng .avif .svgz .ico)
|
||||
(image-link))
|
||||
((.svg)
|
||||
(image-link) (plaintext))
|
||||
((.gz .pack .idx)
|
||||
(binary))
|
||||
(else
|
||||
(if (git-file-is-text? source-file)
|
||||
(plaintext)
|
||||
(binary)))))
|
||||
'(p "(Binary file)"))
|
||||
`((p (@ id "file-path") ,source-file)
|
||||
,(case (string->symbol extension)
|
||||
((.md .markdown)
|
||||
(handle-exceptions exn
|
||||
(begin
|
||||
(format (current-error-port) "Error parsing ~a\n" source-file)
|
||||
`((p (b "There was an error parsing this file as Markdown."))
|
||||
,(plaintext)))
|
||||
(markdown->sxml (git-file->string source-file))))
|
||||
((.jpg .jpeg .png .gif .webp .webm .apng .avif .svgz .ico)
|
||||
(image-link))
|
||||
((.svg)
|
||||
(list (image-link) (plaintext)))
|
||||
((.gz .pack .idx)
|
||||
(binary))
|
||||
(else
|
||||
(if (git-file-is-text? source-file)
|
||||
(plaintext)
|
||||
(binary))))))
|
||||
|
||||
(define (display-files-html source-files-list)
|
||||
(display "<ul>\n")
|
||||
(for-each
|
||||
(lambda (source-file)
|
||||
(format #t "<li><a href=\"~a.html\">~a</a></li>\n" source-file source-file))
|
||||
source-files-list)
|
||||
(display "</ul>\n"))
|
||||
|
||||
(define (display-commits-html)
|
||||
(SXML->HTML
|
||||
`((h1 "Commits")
|
||||
(table
|
||||
(tr (th "Date") (th "Ref") (th "Log") (th "Author"))
|
||||
(define (filelist->sxml source-files-list)
|
||||
`((h1 "Files")
|
||||
((ul
|
||||
,(map
|
||||
(lambda (line)
|
||||
(let-values (((date ref title author) (apply values (string-split line "\t"))))
|
||||
`(tr (td ,date) (td ,ref) (td ,title) (td ,author))))
|
||||
(call-with-input-pipe
|
||||
"git log --format=format:%as%x09%h%x09%s%x09%aN HEAD"
|
||||
read-lines))))))
|
||||
(lambda (source-file)
|
||||
`(li (a (@ href ,source-file ".html") ,source-file)))
|
||||
source-files-list)))))
|
||||
|
||||
(define (display-contributors-html)
|
||||
(SXML->HTML
|
||||
`((h1 "Contributors")
|
||||
(table
|
||||
(tr (th "Author") (th "Commits"))
|
||||
,(map
|
||||
(lambda (line)
|
||||
(let-values (((commits author) (apply values (string-split line "\t"))))
|
||||
`(tr (td ,author) (td ,commits))))
|
||||
(call-with-input-pipe "git shortlog -ns HEAD" read-lines))))))
|
||||
(define (commits->sxml)
|
||||
`((h1 "Commits")
|
||||
(table
|
||||
(tr (th "Date") (th "Ref") (th "Log") (th "Author"))
|
||||
,(map
|
||||
(lambda (line)
|
||||
(let-values (((date ref title author) (apply values (string-split line "\t"))))
|
||||
`(tr (td ,date) (td ,ref) (td ,title) (td ,author))))
|
||||
(call-with-input-pipe "git log --format=format:%as%x09%h%x09%s%x09%aN HEAD" read-lines)))))
|
||||
|
||||
(define (contributors->sxml)
|
||||
`((h1 "Contributors")
|
||||
(table
|
||||
(tr (th "Author") (th "Commits"))
|
||||
,(map
|
||||
(lambda (line)
|
||||
(let-values (((commits author) (apply values (string-split line "\t"))))
|
||||
`(tr (td ,author) (td ,commits))))
|
||||
(call-with-input-pipe "git shortlog -ns HEAD" read-lines)))))
|
||||
|
||||
(define (generate-html-files html-repo-path)
|
||||
(let ((source-files-list (git-repository->paths-list))
|
||||
(repository-name (pathname-strip-directory (string-chomp html-repo-path "/"))))
|
||||
(let* ((source-files-list (git-repository->paths-list))
|
||||
(repository-name (pathname-strip-directory (string-chomp html-repo-path "/")))
|
||||
(template-wrap->sxml (make-sxml-template-wrapper repository-name source-files-list)))
|
||||
|
||||
(define (write-with-template filename display-body-thunk)
|
||||
(define (write-with-template filename sxml)
|
||||
(let ((destination-directory (pathname-directory filename)))
|
||||
(when destination-directory
|
||||
(create-directory (make-pathname html-repo-path destination-directory) #t)))
|
||||
(with-output-to-file (make-pathname html-repo-path filename)
|
||||
(lambda () (populate-html-template repository-name source-files-list filename display-body-thunk))))
|
||||
(lambda ()
|
||||
(display "<!DOCTYPE html>\n")
|
||||
(SXML->HTML (template-wrap->sxml filename sxml)))))
|
||||
|
||||
(create-directory html-repo-path #t)
|
||||
;; special files
|
||||
(write-with-template "files.html" (lambda () (display-files-html source-files-list)))
|
||||
(write-with-template "contributors.html" display-contributors-html)
|
||||
(write-with-template "commits.html" display-commits-html)
|
||||
(write-with-template "files.html" (filelist->sxml source-files-list))
|
||||
(write-with-template "contributors.html" (contributors->sxml))
|
||||
(write-with-template "commits.html" (commits->sxml))
|
||||
;; htmlified repo contents
|
||||
(for-each
|
||||
(lambda (source-file)
|
||||
(write-with-template
|
||||
(string-append source-file ".html")
|
||||
(lambda () (display-source-html source-file)))
|
||||
(source->sxml source-file))
|
||||
(case (string->symbol (or (pathname-extension source-file) ""))
|
||||
((jpg jpeg png gif webp webm svg apng avif svgz ico)
|
||||
(system (format "git show HEAD:~a > ~a"
|
||||
source-file
|
||||
(make-pathname html-repo-path source-file))))))
|
||||
source-files-list)
|
||||
;; if README exists copy it to index.html. otherwise copy files.html to
|
||||
;; index.html.
|
||||
(copy-file
|
||||
(first-if
|
||||
file-exists?
|
||||
(map (lambda (x) (make-pathname html-repo-path x))
|
||||
'("README.md.html" "README.html" "README.txt.html" "files.html")))
|
||||
(make-pathname html-repo-path "index.html")
|
||||
#t)))
|
||||
;; if README.md, README, or README.txt exists, copy that to index.html.
|
||||
;; otherwise copy files.html to index.html.
|
||||
(->>
|
||||
'("README.md.html" "README.html" "README.txt.html" "files.html")
|
||||
(map (lambda (x) (make-pathname html-repo-path x)))
|
||||
(find file-exists?)
|
||||
((lambda (x) (copy-file x (make-pathname html-repo-path "index.html") #t))))))
|
||||
|
||||
(define (main args)
|
||||
(let-optionals args ((html-repo-path ""))
|
||||
|
|
|
|||
Loading…
Reference in a new issue