github
/
repo2html
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

move git-calling procedures to a separate module

This commit is contained in:
pho4cexa 2023-02-05 00:12:13 -08:00
parent c943210189
commit 54a2a0f26d
3 changed files with 108 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Makefile
View File

@ -1,6 +1,6 @@
DEPS = utf8 lowdown sxml-transforms clojurian symbol-utils scss srfi-1 srfi-13 srfi-14 ersatz
SRC = main.scm
LOCAL_MODULES = utils
LOCAL_MODULES = utils utils-git
DIR_INSTALL ?= /usr/local/bin
DIR_BUILD = .
BIN = repo2html
@ -23,7 +23,7 @@ compile: $(DIR_BUILD)/$(BIN)
@echo "Finished compiling a static binary in $(DIR_BUILD)/$(BIN)!"
foo: utils.import.scm utils.o
repo2html: utils.import.scm utils.o
repo2html: utils.import.scm utils.o utils-git.import.scm utils-git.o
dependencies:
chicken-install $(DEPS)

133
repo2html.scm
View File

@ -2,13 +2,13 @@
(import
(chicken file)
(chicken format)
(chicken io)
(chicken format) ;; format
(chicken io) ;; read-line
(chicken pathname)
(chicken port)
(chicken process)
(chicken process) ;; call-with-input-pipe
(chicken process-context)
(chicken string)
(chicken string) ;; string-intersperse
(clojurian syntax)
ersatz
lowdown
@ -20,6 +20,7 @@
symbol-utils ;; (unspecified-value)
utf8
utils
utils-git
)
;; auto-apply ids to headings ---------------------------------
@ -104,56 +105,7 @@
(*text* . ,(lambda (_t i) (if (unspecified? i) "" i)))
,@alist-conv-rules*))
;; reading in data from git commands ---------------------------------
(define (in-git-directory?)
(not (eof-object? (call-with-input-pipe "git rev-parse --git-dir" read-line))))
;; a weird hack to detect whether git considers a blob to be a binary or a text
;; file. works by requesting the numstat diff between it and the empty tree.
;; binary files give not a line count but '-' placeholders.
(define (git-file-is-text? source-file)
(not (equal?
"-\t-\t"
(call-with-input-pipe
(string-append "git diff 4b825dc642cb6eb9a060e54bf8d69288fbee4904 --numstat HEAD -- " (qs source-file))
(cute read-line <> 4)))))
(define (git-repository->paths-list)
(call-with-input-pipe "git ls-tree -r --name-only HEAD" read-lines))
(define (lines->numbered-lines lines)
`(table
(@ (id "file-contents"))
,@(map (lambda (number line)
`(tr (@ ((class "line")
(id ,number)))
(td (@ (class "line-number"))
(a (@ (href "#" ,number)) ,number))
(td (@ (class "line-contents"))
(code ,line))))
(map number->string (iota (length lines) 1))
lines)))
(define (git-file->string source-file mode)
(let ((handle-lines (lambda (lines)
(if (equal? mode 'plaintext)
(string-intersperse lines "\n")
(lines->numbered-lines lines)))))
(->
source-file
(qs)
((flip format) "git show HEAD:~a")
(call-with-input-pipe read-lines)
handle-lines)))
;; the result of asking git for some configuration; #f if no result.
(define (git-config->string key)
(let [(result (call-with-input-pipe (string-append "git config " key) read-line))]
(if (eof-object? result) #f result)))
;; environment always takes precedent over git-config
;; environment always takes precedence over git-config
(define (config key)
(or
(get-environment-variable (string-append "REPO2HTML_" (string-upcase key)))
@ -161,15 +113,32 @@
;; sxml generators for constructed pages ---------------------------------
(define (lines->string xs) (string-intersperse xs "\n"))
(define (lines->numbered-sxml lines)
`(table
(@ (id "file-contents"))
,@(map (lambda (number line)
`(tr (@ ((class "line")
(id ,number)))
(td (@ (class "line-number"))
(a (@ (href "#" ,number)) ,number))
(td (@ (class "line-contents"))
(code ,line))))
(map number->string (iota (length lines) 1))
lines)))
(define (source->sxml source-file) ;; src/main.scm
(define-values (_ _ basename extension _)
(pathparts source-file))
(define (image-link)
`(p (img (@ (src (,(string-append basename extension)))))))
(define (plaintext)
`(pre ,(git-file->string source-file 'plaintext)))
(define (numbered-lines)
(git-file->string source-file 'table))
`(pre ,(git-file->lines source-file)))
(define (numbered-sxml)
(-> source-file
git-file->lines
lines->numbered-sxml))
(define (binary)
'(p "(Binary file)"))
(case (string->symbol extension)
@ -179,17 +148,20 @@
(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 'plaintext))))
((.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)
(numbered-lines)
(binary)))))
(-> source-file
git-file->lines
lines->string
markdown->sxml))
((.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)
(numbered-sxml)
(binary))))))
(define (filelist->sxml source-files-list relative-root)
`((h1 "Files")
@ -202,13 +174,10 @@
(define (commits->sxml)
`((h1 "Commits")
(table
(tr
,@(map (lambda x `(th ,x)) '("Date" "Ref" "Log" "Author")))
(tr ,@(map (lambda x `(th ,x)) '("Date" "Ref" "Log" "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)))))
(lambda (commit) `(tr ,@(map (lambda x `(td ,x)) commit)))
(git-commits)))))
(define (contributors->sxml)
`((h1 "Contributors")
@ -218,7 +187,8 @@
(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)))))
(git-contributors)))))
(define (issueslist->sxml source-files-list)
`((h1 "Issues")
@ -229,11 +199,10 @@
(string-prefix? "ISSUES/" source-file)
`(li (a (@ (href ,source-file))
,(->
(string-append "HEAD:" source-file)
(qs)
((flip format) "git show ~a")
(call-with-input-pipe read-line)
((lambda (x) (if (eof-object? x) (pathname-strip-directory source-file) x)))
source-file
git-file->lines
((lambda (x) (if (eof-object? x) (list (pathname-strip-directory source-file)) x)))
car
(string-trim (string->char-set "# ")))))))
source-files-list)))))
@ -343,9 +312,7 @@
;; if it's an image, also write it verbatim to output directory
(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"
(qs source-file)
(make-pathname html-path (qs source-file)))))))
(git-copy source-file (make-pathname html-path source-file)))))
source-files-list)
;; if README.md, README, or README.txt exists, regenerate it as index.html.
;; otherwise regenerate files.html as index.html.

56
utils-git.scm Normal file
View File

@ -0,0 +1,56 @@
;; functions that interact with the git executable
(module utils-git *
(import
(chicken base)
(chicken format) ;; format
(chicken io) ;; read-line
(chicken process) ;; call-with-input-pipe
(chicken string) ;; string-intersperse
(clojurian syntax)
scheme
)
(define lines-from-git-command (cute call-with-input-pipe <> read-lines))
(define (in-git-directory?)
(not (eof-object? (call-with-input-pipe "git rev-parse --git-dir" read-line))))
;; a weird hack to detect whether git considers a blob to be a binary or a text
;; file. works by requesting the numstat diff between it and the empty tree.
;; binary files give not a line count but '-' placeholders.
(define (git-file-is-text? source-file)
(not (equal?
"-\t-\t"
(call-with-input-pipe
(string-append "git diff 4b825dc642cb6eb9a060e54bf8d69288fbee4904 --numstat HEAD -- " (qs source-file))
(cute read-line <> 4)))))
(define (git-repository->paths-list)
(lines-from-git-command "git ls-tree -r --name-only HEAD"))
(define (git-file->lines source-file)
(->
source-file
(qs)
((flip format) "git show HEAD:~a")
(lines-from-git-command)))
;; the result of asking git for some configuration; #f if no result.
(define (git-config->string key)
(let [(result (call-with-input-pipe (string-append "git config " key) read-line))]
(if (eof-object? result) #f result)))
(define (git-commits)
;; date ref title author, tab-separated.
(map (cute string-split <> "\t")
(lines-from-git-command "git log --format=format:%as%x09%h%x09%s%x09%aN HEAD")))
(define (git-contributors)
(lines-from-git-command "git shortlog -ns HEAD"))
;; copy a file verbatim from the repo @HEAD to some path
(define (git-copy src dst)
(system (format "git show HEAD:~a > ~a" (qs src) (qs dst))))
)