7dbf2fb3fc
- Image paths: Images worked on the README.md, but as soon as you tried to view the images in the files tree, and the images were in a subdirectory, the full path was added after the directory name. For example, an image at <git-repo-root>/images/screenshot.gif, would be generated in the file tree with the following link: <git-repo-root>images/images/screenshot.gif because it doesn't know that the link to the source file is actually also linking to the images directory, because I generate directories for all links, as if you were actually traversing them. This means we are able to strip the directory from the file path completely, because our links already go to the desired directory, to get images to show up in the source file view - Unknown file type issues: I changed the else statement to render the unknown filetype, because it cause the source of, for example, main.scm to just say "(Unknown file type)". Maybe we can revise this in the future to see when we want to use Unknown filetypes! Thoughts: I think I'm going to try to see if prepending a slash at the front of image paths will create an absolute path, so we dont have to get into messy relative paths haha.
187 lines
5.8 KiB
Scheme
Executable file
187 lines
5.8 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 repo-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>#{repo-name}</h2>
|
|
<p>clone url: #{CLONE-URL}/#{repo-name}</p>
|
|
<nav>
|
|
<a href="/#{repo-name}/index.html">about</a>
|
|
<a href="/#{repo-name}/files.html">files</a>
|
|
<a href="/#{repo-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>" source-file))
|
|
((svg)
|
|
(format #t "<p><img src=\"/~a\" /></p>" 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))
|