repo2html/main.scm

#!/usr/bin/csi -s

(import
  (chicken file)
  (chicken format)
  (chicken io)
  (chicken pathname)
  (chicken port)
  (chicken process)
  (chicken process-context)
  (chicken string)
  (clojurian syntax)
  ersatz
  lowdown
  scss
  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") "git.example.com"))
(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 #!optional msg (status 1))
  (when 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))))

;; merge alists a and b. values in b "win"
(define (alist-merge a b)
  (lset-union (lambda (x y) (eq? (car x) (car y))) a b))

;; auto-apply ids to headings ---------------------------------

(define (slugify _ inner)
  (->
   inner
   (pre-post-order*
    `((*text* .
       ,(lambda (_ str)
          (if (string? str)
              (->
               str
               (string-downcase)
               (string-translate "/,:;\"[]{}()=+")
               (string-translate " _." "---"))
              str)))
      ,@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 sxml-html-rules
  `(;; 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*))

;; vvv sxml template writer ------------------------------------------------
;;
;; if we decide to only use the ersatz templates, this whole chunk can be deleted!
;;
;; or we can keep it as a fall-back, or let the user choose which they prefer? idk

(define (make-template-writer-sxml #!optional vars)
  (let* ((source-files-list (alist-ref 'source_files_list vars)))

    (lambda (output-filename body-sxml #!optional newvars)
      (if-let (destination-directory (pathname-directory output-filename))
              (create-directory destination-directory #t)
              '())
      (let ((vars (alist-merge vars (or newvars '()))))
        (with-output-to-file output-filename
          (lambda ()
            (define-values (_ _ _ _ relative-root) (pathparts (or (alist-ref 'source_file vars) "")))
            (display "<!DOCTYPE html>\n")
            (SXML->HTML
             (pre-post-order*
              (my-sxml-template body-sxml vars)
              sxml-html-rules))))))))

(define (my-sxml-template body-sxml vars)
  (let (
        (clone-url-prefix       (alist-ref 'clone_url_prefix       vars))
        (forge-title            (alist-ref 'forge_title            vars))
        (h1                     (alist-ref 'h1                     vars))
        (issues-file            (alist-ref 'issues_file            vars))
        (license-file           (alist-ref 'license_file           vars))
        (readme-file            (alist-ref 'readme_file            vars))
        (relative-root          (alist-ref 'relative_root          vars))
        (repository-description (alist-ref 'repository_description vars))
        (repository-name        (alist-ref 'repository_name        vars))
        (source-file            (alist-ref 'source_file            vars))
        )
    `(html (@ lang en)
      (head
       (title ,(string-append forge-title " - " repository-name))
       (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 ,repository-description)))
       (style ,my-css))
      (body
       (h1 ,h1)
       (h2 ,repository-name)
       (p "clone url:" ,clone-url-prefix "/" ,repository-name)
       (nav
        ,(if readme-file
             `((a (@ href ,relative-root "index.html") "about")
               (a (@ href ,relative-root "files.html") "files"))
             `((a (@ href ,relative-root "index.html") "files")))
        ,(when license-file
           `(a (@ href ,relative-root ,license-file ".html") "license"))
        ,(when issues-file
           `(a (@ href ,relative-root ,issues-file ".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") " using sxml templates")))))

(define my-css
  (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
          ))))))

;; ^^^ sxml template writer ------------------------------------------------

;; reading in data from git commands

(define (in-git-directory?)
  (not (eof-object? (call-with-input-pipe "git rev-parse --git-dir" read-line))))

(define (git-file-is-text? source-file)
  (not (equal?
        "-\t-\t"
        (call-with-input-pipe
         (string-append "git diff 4b825dc642cb6eb9a060e54bf8d69288fbee4904 --numstat HEAD -- " source-file)
         (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 source-file)
  (->
   (format "git show HEAD:~a" source-file)
   (call-with-input-pipe read-lines)
   (string-intersperse "\n")))

;; sxml generators for constructed pages

(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)))))

;; used by ersatz writer
(define (alist->tvals vars)
  (map (lambda (pair)
         `(,(car pair) . ,(sexpr->tvalue (cdr pair)))) vars))

;; this version uses a jinja-style template via ersatz
(define (make-template-writer-ersatz templates-directory #!optional vars)
  (define template (statements-from-file (template-std-env search-path: (list templates-directory)) "default.html"))
  (lambda (output-filename body-sxml #!optional newvars)
    ;; create destination directory if needed
    (if-let (destination-directory (pathname-directory output-filename))
            (create-directory destination-directory #t)
            '())

    (let* (;; render the sxml to a html string that we can hand to the template
           (body-html
            (with-output-to-string
              (lambda ()
                (SXML->HTML (pre-post-order* body-sxml sxml-html-rules)))))
           ;; vars = global vars + file-specific vars + body k/v pair
           (vars
            (alist-cons
             'content body-html
             (alist-merge vars (or newvars '())))))

      (with-output-to-file output-filename
        (lambda ()
          (display (eval-statements template models: (alist->tvals vars))))))))

                                        ; main program ------------------------------------------------------------------------------

(define (generate-html-files html-repo-path templates-directory)
  (let* ((source-files-list   (git-repository->paths-list))
         (repository-name     (pathname-strip-directory (string-chomp html-repo-path "/")))
         (template-alist      `(;; variables provided to template at all times
                                (source_files_list      . ,source-files-list)
                                (clone_url_prefix       . ,CLONE-URL)
                                (forge_title            . ,TITLE)
                                (h1                     . ,H1)
                                (repository_description . ,DESCRIPTION)
                                (repository_name        . ,repository-name)
                                (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_file
                                 . ,(and (find (lambda (x) (string-prefix? "ISSUES/" x)) source-files-list) "ISSUES"))
                                ))
         (write-with-template
          ;; which template writer do you prefer to use? uncomment one of the next two lines.
          (if (equal? "sxml" templates-directory)
              (make-template-writer-sxml template-alist)
              (make-template-writer-ersatz templates-directory template-alist)
              )))

    (create-directory html-repo-path #t)
    ;; special files
    (write-with-template (make-pathname html-repo-path "files" "html") (filelist->sxml source-files-list))
    (write-with-template (make-pathname html-repo-path "contributors" "html") (contributors->sxml))
    (write-with-template (make-pathname html-repo-path "commits" "html") (commits->sxml))
    ;; htmlified repo contents
    (for-each
     (lambda (source-file)
       (->> source-file
            (pathparts)
            (define-values (root elements basename extension relative-root)))
       (write-with-template
        (make-pathname html-repo-path source-file "html")
        (source->sxml source-file)
        `(;; additional per-page variables provided to template
          (source_file   . ,source-file)
          (root          . ,root)
          (elements      . ,elements)
          (basename      . ,basename)
          (extension     . ,extension)
          (relative_root . ,relative-root)
          ))
       ;; if it's an image also copy 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"
                          source-file
                          (make-pathname html-repo-path source-file))))))
     source-files-list)
    ;; if (the output version of) README.md, README, or README.txt exists, copy
    ;; that to index.html. otherwise copy files.html to index.html.
    (->>
     '("README.md" "README" "README.txt" "files")
     (map (lambda (x) (make-pathname html-repo-path x "html")))
     (find file-exists?)
     ((lambda (x) (copy-file x (make-pathname html-repo-path "index" "html") #t))))
    ;; if the ISSUES directory got created, write out an index file for the
    ;; stuff in there.
    (when (file-exists? (make-pathname html-repo-path "ISSUES"))
      (write-with-template (make-pathname html-repo-path "ISSUES" "html") (issueslist->sxml source-files-list)))))

(define (main #!optional html-repo-path (templates-directory "sxml"))

  (unless 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 templates-directory))

(apply main (command-line-arguments))