deduplicate, reorganize some utility functions, inline docs
This commit is contained in:
pho4cexa
m455
parent
75b7406508
commit
ab241899d4
1 changed files with 66 additions and 46 deletions
110
main.scm
110
main.scm
|
|
@ -19,22 +19,60 @@
|
|||
(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 source-files-list source-file display-body-thunk)
|
||||
(define-values (source-directory source-filename source-extension)
|
||||
(decompose-pathname source-file))
|
||||
(define-values (base-origin base-directory directory-elements)
|
||||
(if source-directory
|
||||
(decompose-directory source-directory)
|
||||
(values #f #f '())))
|
||||
(define relative-root
|
||||
;; 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.
|
||||
;; 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) "")
|
||||
(->>
|
||||
directory-elements
|
||||
(map (lambda (_) "../"))
|
||||
;; why is there no inverse function for decompose-directory in pathname?
|
||||
;; idgas about portability but a portable program would refer to the
|
||||
;; current platform's directory-separator here.
|
||||
(apply string-append)
|
||||
))
|
||||
(or directory-elements '())
|
||||
(map (constantly "../"))
|
||||
(apply string-append))))
|
||||
|
||||
;; main code ---------------------------------
|
||||
|
||||
(define (populate-html-template repository-name source-files-list source-file display-body-thunk)
|
||||
(define-values (_ _ _ _ relative-root) (pathparts source-file))
|
||||
|
||||
(display #<#string-block
|
||||
<!DOCTYPE html>
|
||||
|
|
@ -107,7 +145,7 @@ string-block
|
|||
(define (in-git-directory?)
|
||||
(not (eof-object? (call-with-input-pipe "git rev-parse --git-dir" read-line))))
|
||||
|
||||
(define (is-text? path)
|
||||
(define (git-file-is-text? path)
|
||||
(not (equal?
|
||||
"-\t-\t"
|
||||
(call-with-input-pipe
|
||||
|
|
@ -124,15 +162,9 @@ string-block
|
|||
(string-intersperse "\n")))
|
||||
|
||||
(define (display-source-html source-file) ;; src/main.scm
|
||||
(define-values (source-directory source-filename source-extension)
|
||||
(decompose-pathname source-file))
|
||||
(define-values (base-origin base-directory directory-elements)
|
||||
(if source-directory
|
||||
(decompose-directory source-directory)
|
||||
(values #f #f '())))
|
||||
|
||||
(define-values (_ _ basename extension _) (pathparts source-file))
|
||||
(define (image-link)
|
||||
(format #t "<p><img src=\"~a\" /></p>" (make-pathname "" source-filename source-extension)))
|
||||
(format #t "<p><img src=\"~a~a\" /></p>" basename extension))
|
||||
(define (plaintext)
|
||||
(display "<pre>")
|
||||
(display-escaped-html (git-file->string source-file))
|
||||
|
|
@ -140,10 +172,8 @@ string-block
|
|||
(define (binary)
|
||||
(display "<p>(Binary file)</p>"))
|
||||
(format #t "<p id=\"file-path\">~a</p>" source-file)
|
||||
(case (string->symbol (or source-extension source-filename))
|
||||
;; markdown files get rendered in-place, unless there's an error, in which
|
||||
;; case escaped plaintext inside a <pre>
|
||||
((md markdown)
|
||||
(case (string->symbol extension)
|
||||
((.md .markdown)
|
||||
(handle-exceptions exn
|
||||
(begin
|
||||
(display "Error parsing " (current-error-port))
|
||||
|
|
@ -152,14 +182,14 @@ string-block
|
|||
(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)
|
||||
((.jpg .jpeg .png .gif .webp .webm .apng .avif .svgz .ico)
|
||||
(image-link))
|
||||
((svg)
|
||||
((.svg)
|
||||
(image-link) (plaintext))
|
||||
((gz pack idx)
|
||||
((.gz .pack .idx)
|
||||
(binary))
|
||||
(else
|
||||
(if (is-text? source-file)
|
||||
(if (git-file-is-text? source-file)
|
||||
(plaintext)
|
||||
(binary)))))
|
||||
|
||||
|
|
@ -191,15 +221,10 @@ string-block
|
|||
(tr (th "Author") (th "Commits"))
|
||||
,(map
|
||||
(lambda (line)
|
||||
(let-values (((commits . author) (apply values (string-split line "\t"))))
|
||||
(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 (first-if pred lst)
|
||||
(cond ((null? lst) #f)
|
||||
((pred (car lst)) (car lst))
|
||||
(else (first-if pred (cdr lst)))))
|
||||
|
||||
(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 "/"))))
|
||||
|
|
@ -238,19 +263,14 @@ string-block
|
|||
(make-pathname html-repo-path "index.html")
|
||||
#t)))
|
||||
|
||||
(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"))
|
||||
(bail "please specify a destination directory for html files"))
|
||||
|
||||
(unless (in-git-directory?)
|
||||
(bail 1 "woops this isn't a git directory"))
|
||||
(bail "woops this isn't a git directory"))
|
||||
|
||||
(generate-html-files html-repo-path)))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue