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

get relative nav links working

Browse source 
this could use some extra thinking and cleanup, got some copy-pasted
code in both populat-html-template and display-source-html. but it's
working in my clone of fa!
This commit is contained in:
pho4cexa 2022-12-08 14:54:26 -08:00 committed by m455
parent 363ed994f4
commit f6cd8f38a5
1 changed files with 47 additions and 27 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

64
main.scm
View file

@ -19,7 +19,23 @@
(define DESCRIPTION (or (get-environment-variable "REPO2HTML_DESCRIPTION") "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 H1 (or (get-environment-variable "REPO2HTML_H1") "git.example.com"))
(define (populate-html-template repository-name display-body-thunk) (define (populate-html-template repository-name 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
(->>
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)
))
(display #<#string-block (display #<#string-block
<!DOCTYPE html> <!DOCTYPE html>
<html lang="en"> <html lang="en">
@ -59,9 +75,9 @@ hr {
<h2>#{repository-name}</h2> <h2>#{repository-name}</h2>
<p>clone url: #{CLONE-URL}/#{repository-name}</p> <p>clone url: #{CLONE-URL}/#{repository-name}</p>
<nav> <nav>
<a href="/#{repository-name}/index.html">about</a> <a href="#{relative-root}index.html">about</a>
<a href="/#{repository-name}/files.html">files</a> <a href="#{relative-root}files.html">files</a>
<a href="/#{repository-name}/contributors.html">contributors</a> <a href="#{relative-root}contributors.html">contributors</a>
</nav> </nav>
<hr> <hr>
string-block string-block
@ -89,8 +105,23 @@ string-block
(string-intersperse "\n"))) (string-intersperse "\n")))
(define (display-source-html source-file) ;; src/main.scm (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 (image-link)
(format #t "<p><img src=\"~a\" /></p>" (make-pathname "" source-filename source-extension)))
(define (plaintext)
(display "<pre>")
(display-escaped-html (git-file->string source-file))
(display "</pre>"))
(format #t "<p id=\"file-path\">~a</p>" source-file) (format #t "<p id=\"file-path\">~a</p>" source-file)
(case (string->symbol (or (pathname-extension source-file) "no-extension")) (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) ((md markdown)
(handle-exceptions exn (handle-exceptions exn
(begin (begin
@ -98,27 +129,16 @@ string-block
(display source-file (current-error-port)) (display source-file (current-error-port))
(display "\n" (current-error-port)) (display "\n" (current-error-port))
(display "<p><b>There was an error parsing this file as Markdown.</b></p>") (display "<p><b>There was an error parsing this file as Markdown.</b></p>")
(display "<pre>") (plaintext))
(display-escaped-html (git-file->string source-file))
(display "</pre>"))
(markdown->html (git-file->string source-file)))) (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)
(format #t "<p><img src=\"~a\" /></p>" (pathname-strip-directory source-file))) (image-link))
((svg) ((svg)
(format #t "<p><img src=\"~a\" /></p>" (pathname-strip-directory source-file)) (image-link) (plaintext))
(display "<pre>")
(display-escaped-html (git-file->string source-file))
(display "</pre>"))
((gz pack idx) ((gz pack idx)
(display "<p>(Binary file)</p>")) (display "<p>(Binary file)</p>"))
((txt no-extension)
(display "<pre>")
(display-escaped-html (git-file->string source-file))
(display "</pre>"))
(else (else
(display "<pre>") (plaintext))))
(display-escaped-html (git-file->string source-file))
(display "</pre>"))))
(define (display-files-html source-files-list) (define (display-files-html source-files-list)
(display "<ul>\n") (display "<ul>\n")
@ -142,14 +162,14 @@ string-block
(define (generate-html-files html-repo-path) (define (generate-html-files html-repo-path)
(let ((source-files-list (git-repository->paths-list)) (let ((source-files-list (git-repository->paths-list))
(repository-name (pathname-strip-directory html-repo-path))) (repository-name (pathname-strip-directory (string-chomp html-repo-path "/"))))
(define (write-with-template filename display-body-thunk) (define (write-with-template filename display-body-thunk)
(let ((destination-directory (pathname-directory filename))) (let ((destination-directory (pathname-directory filename)))
(when destination-directory (when destination-directory
(create-directory (make-pathname html-repo-path destination-directory) #t))) (create-directory (make-pathname html-repo-path destination-directory) #t)))
(with-output-to-file (make-pathname html-repo-path filename) (with-output-to-file (make-pathname html-repo-path filename)
(lambda () (populate-html-template repository-name display-body-thunk)))) (lambda () (populate-html-template repository-name filename display-body-thunk))))
(create-directory html-repo-path #t) (create-directory html-repo-path #t)