07e73e4083
This works, because when you click a link to view a file source, the link takes you into the directory where the image is, because directories are recursively made in the web server directory to mimic the structure of the git repository, and so files with the same name don't conflict, because they'll be in a different directory.
187 lines
5.9 KiB
Scheme
Executable file
187 lines
5.9 KiB
Scheme
Executable file
#!/usr/bin/csi -s
|
|
|
|
(import utf8
|
|
lowdown
|
|
(chicken string)
|
|
(chicken port)
|
|
(chicken io)
|
|
(chicken process)
|
|
(chicken process-context)
|
|
(chicken format)
|
|
(chicken pathname)
|
|
(chicken file)
|
|
sxml-transforms
|
|
(clojurian syntax)
|
|
)
|
|
|
|
(define CLONE-URL (or (get-environment-variable "REPO2HTML_CLONE_URL") "git://git.example.com"))
|
|
(define TITLE (or (get-environment-variable "REPO2HTML_TITLE") "my git repositories"))
|
|
(define DESCRIPTION (or (get-environment-variable "REPO2HTML_DESCRIPTION") "my git repositories"))
|
|
(define H1 (or (get-environment-variable "REPO2HTML_H1") "git.example.com"))
|
|
|
|
(define (populate-html-template repository-name display-body-thunk)
|
|
(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;
|
|
}
|
|
##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>
|
|
<a href="/#{repository-name}/index.html">about</a>
|
|
<a href="/#{repository-name}/files.html">files</a>
|
|
<a href="/#{repository-name}/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 (in-git-directory?)
|
|
(not (eof-object? (call-with-input-pipe "git rev-parse --git-dir" read-line))))
|
|
|
|
(define (git-repository->paths-list)
|
|
(call-with-input-pipe "git ls-tree -r --name-only HEAD" read-lines))
|
|
|
|
(define (git-file->string path)
|
|
(->
|
|
(format "git show HEAD:~a" path)
|
|
(call-with-input-pipe read-lines)
|
|
(string-intersperse "\n")))
|
|
|
|
(define (display-source-html source-file) ;; src/main.scm
|
|
(format #t "<p id=\"file-path\">~a</p>" source-file)
|
|
(case (string->symbol (or (pathname-extension source-file) "no-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>")
|
|
(display "<pre>")
|
|
(display-escaped-html (git-file->string source-file))
|
|
(display "</pre>"))
|
|
(markdown->html (git-file->string source-file))))
|
|
((jpg jpeg png gif webp webm apng avif svgz ico)
|
|
(format #t "<p><img src=\"~a\" /></p>" (pathname-strip-directory repository-name) source-file))
|
|
((svg)
|
|
(format #t "<p><img src=\"~a\" /></p>" (pathname-strip-directory repository-name) source-file)
|
|
(display "<pre>")
|
|
(display-escaped-html (git-file->string source-file))
|
|
(display "</pre>"))
|
|
((gz pack idx)
|
|
(display "<p>(Binary file)</p>"))
|
|
((txt no-extension)
|
|
(display "<pre>")
|
|
(display-escaped-html (git-file->string source-file))
|
|
(display "</pre>"))
|
|
(else
|
|
(display "<pre>")
|
|
(display-escaped-html (git-file->string source-file))
|
|
(display "</pre>"))))
|
|
|
|
(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-readme-html)
|
|
(markdown->html (git-file->string "README.md")))
|
|
|
|
(define (display-contributors-html)
|
|
(SXML->HTML
|
|
`((h1 "Contributors")
|
|
(ul ,(map
|
|
(lambda (line)
|
|
(let-values (((commits . author) (apply values (string-split line "\t"))))
|
|
`(li ,author)))
|
|
(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 html-repo-path)))
|
|
|
|
(define (write-with-template filename display-body-thunk)
|
|
(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 display-body-thunk))))
|
|
|
|
(create-directory html-repo-path #t)
|
|
|
|
(write-with-template "index.html" (lambda () (display-readme-html)))
|
|
(write-with-template "files.html" (lambda () (display-files-html source-files-list)))
|
|
(write-with-template "contributors.html" (lambda () (display-contributors-html)))
|
|
(for-each
|
|
(lambda (source-file)
|
|
(write-with-template
|
|
(string-append source-file ".html")
|
|
(lambda () (display-source-html 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)))
|
|
|
|
(define (bail . args)
|
|
(let-optionals args ((status 1) (msg ""))
|
|
(unless (equal? "" msg) (print msg))
|
|
(exit status)))
|
|
|
|
(define (main args)
|
|
(let-optionals args ((html-repo-path ""))
|
|
|
|
(when (equal? html-repo-path "")
|
|
(bail 1 "please specify a destination directory for html files"))
|
|
|
|
(unless (in-git-directory?)
|
|
(bail 1 "woops this isn't a git directory"))
|
|
|
|
(generate-html-files html-repo-path)))
|
|
|
|
(main (command-line-arguments))
|