#!/usr/bin/csi -s
(import
(chicken file)
(chicken format)
(chicken io)
(chicken pathname)
(chicken port)
(chicken process)
(chicken process-context)
(chicken string)
(clojurian syntax)
scss
lowdown
srfi-1 ;; list utils
srfi-13 ;; string utils
srfi-14 ;; charsets
sxml-transforms
symbol-utils ;; (unspecified-value)
utf8
)
(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"))
;; small utilities ---------------------------------
;; (bail [message [exit-status]])
;; end the program immediately.
;; if a message is provided, print it to the screen.
;; exit-status defaults to 1.
(define (bail . args)
(let-optionals args ((msg "") (status 1))
(unless (equal? "" msg) (print msg))
(exit status)))
;; decompose a path s into its constituent parts. returns values:
;;
;; root: "/" if it's an absolute path, "" if relative
;; directory-elements: a list of each directory from root, () if none
;; basename: the filename with extension removed like "readme" or ".bashrc"
;; extension: the file extension with the dot, like ".txt" or "" if none
;; relative-root: the relative path from the given path to the root
;; e.g foo/bar/baz.html -> ../../
;;
;; this is intended to provide default values that make for easier reassembly
;; into filenames.
;;
;; typical use:
;; (->> source-file
;; (pathparts)
;; (define-values (root elements basename extension relative-root)))
;;
(define (pathparts s)
(define-values (dirname basename extension)
(decompose-pathname s))
(define-values (origin root directory-elements)
(decompose-directory (or dirname "")))
;; discarding origin because idgaf about windows
(values (or root "")
(or directory-elements '())
basename
(if extension (string-append "." extension) "")
(->>
(or directory-elements '())
(map (constantly "../"))
(apply string-append))))
;; like (substring) but doesn't break if start and end are too big/small
(define (substring* s start end)
(substring s (max start 0) (min end (string-length s))))
;; main code ---------------------------------
(define mycss
(with-output-to-string
(lambda ()
(write-css
'(css
(body
(margin 0 auto)
(max-width 700px))
(((pre) (code))
(background-color "#ffd9df"))
(pre
(overflow scroll)
(padding 15px 20px)
(white-space pre))
(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))
(footer
(font-size small)
(text-align right))
((= id file-path)
;; change this to your liking
))))))
(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")))
(issues-present?
(find (lambda (x) (string-prefix? "ISSUES/" x)) source-files-list)))
(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 ,mycss))
(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"))
,(when issues-present?
`(a (@ href ,relative-root "ISSUES.html") "issues"))
(a (@ href ,relative-root "commits.html") "commits")
(a (@ href ,relative-root "contributors.html") "contributors")))
(hr)
,body-sxml
(hr)
(footer (p "Generated by " (a (@ href "https://git.m455.casa/repo2html/") "repo2html")))))))
(define (slugify _ inner)
(->
inner
(pre-post-order*
`((*text* .
,(lambda (_ str)
(->
str
(string-downcase)
(string-translate "/,:;\"[]{}()=+")
(string-translate " _." "---"))))
,@alist-conv-rules*))
(flatten)
((flip map) ->string)
(string-intersperse "")
(substring* 0 40)))
(define (enumerate-tag tag inner)
`(,tag (@ (id ,tag "-" ,(slugify tag inner))) ,inner))
(define (in-git-directory?)
(not (eof-object? (call-with-input-pipe "git rev-parse --git-dir" read-line))))
(define (git-file-is-text? path)
(not (equal?
"-\t-\t"
(call-with-input-pipe
(string-append "git diff 4b825dc642cb6eb9a060e54bf8d69288fbee4904 --numstat HEAD -- " path)
(lambda (port) (read-line port 4))))))
(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 (source->sxml source-file) ;; src/main.scm
(define-values (_ _ basename extension _)
(pathparts source-file))
(define (image-link)
`(p (img (@ src ,basename ,extension))))
(define (plaintext)
`(pre ,(git-file->string source-file)))
(define (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 (filelist->sxml source-files-list)
`((h1 "Files")
((ul
,(map
(lambda (source-file)
`(li (a (@ href ,source-file ".html") ,source-file)))
source-files-list)))))
(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 (issueslist->sxml source-files-list)
`((h1 "Issues")
((ul
,(filter-map
(lambda (source-file)
(and
(string-prefix? "ISSUES/" source-file)
`(li (a (@ href ,source-file ".html")
,(->
source-file
((flip format) "git show HEAD:~a")
(call-with-input-pipe read-line)
(string-trim (string->char-set "# ")))))))
source-files-list)))))
(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 "/")))
(template-wrap->sxml (make-sxml-template-wrapper repository-name source-files-list)))
(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 ()
(display "<!DOCTYPE html>\n")
(SXML->HTML
(pre-post-order*
(template-wrap->sxml filename sxml)
`(;; assign all headings an id so you can link to them
(h1 . ,enumerate-tag)
(h2 . ,enumerate-tag)
(h3 . ,enumerate-tag)
(h4 . ,enumerate-tag)
(h5 . ,enumerate-tag)
;; this copied from lowdown html-serialization-rules* because it
;; is for some reason not exported??
(*COMMENT* . ,(lambda (_ str) (list #\< "!--" str "--" #\>)))
;; ignore #<unspecified> in tree
(*text* . ,(lambda (_ str) (if (unspecified? str) "" str)))
,@alist-conv-rules*))))))
(create-directory html-repo-path #t)
;; special files
(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")
(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.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))))
(when (file-exists? (make-pathname html-repo-path "ISSUES"))
(write-with-template "ISSUES.html" (issueslist->sxml source-files-list)))))
(define (main args)
(let-optionals args ((html-repo-path ""))
(when (equal? html-repo-path "")
(bail "please specify a destination directory for html files"))
(unless (in-git-directory?)
(bail "woops this isn't a git directory"))
(generate-html-files html-repo-path)))
(main (command-line-arguments))