diff --git a/main.scm b/main.scm index e8b16e8..4ba54dd 100755 --- a/main.scm +++ b/main.scm @@ -19,7 +19,23 @@ (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 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 @@ -59,9 +75,9 @@ hr {

#{repository-name}

clone url: #{CLONE-URL}/#{repository-name}

string-block @@ -89,36 +105,40 @@ 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 (image-link) + (format #t "

" (make-pathname "" source-filename source-extension))) + (define (plaintext) + (display "
")
+    (display-escaped-html (git-file->string source-file))
+    (display "
")) (format #t "

~a

" 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 
     ((md markdown)
      (handle-exceptions exn
          (begin
-            (display "Error parsing " (current-error-port))
-            (display source-file (current-error-port))
-            (display "\n" (current-error-port))
-            (display "
There was an error parsing this file as Markdown.
")
-            (display "
")
-            (display-escaped-html (git-file->string source-file))
-            (display "
"))
-        (markdown->html (git-file->string source-file))))
+           (display "Error parsing " (current-error-port))
+           (display source-file (current-error-port))
+           (display "\n" (current-error-port))
+           (display "
There was an error parsing this file as Markdown.
")
+           (plaintext))
+       (markdown->html (git-file->string source-file))))
     ((jpg jpeg png gif webp webm apng avif svgz ico)
-     (format #t "
" (pathname-strip-directory source-file)))
+     (image-link))
     ((svg)
-     (format #t "
" (pathname-strip-directory source-file))
-     (display "
")
-     (display-escaped-html (git-file->string source-file))
-     (display "
"))
+     (image-link) (plaintext))
     ((gz pack idx)
      (display "
(Binary file)
"))
-    ((txt no-extension)
-     (display "
")
-     (display-escaped-html (git-file->string source-file))
-     (display "
"))
     (else
-     (display "
")
-     (display-escaped-html (git-file->string source-file))
-     (display "
"))))
+     (plaintext))))
 
 (define (display-files-html source-files-list)
   (display "