repo2html/main.scm

#!/usr/bin/csi -s

(import utf8
        lowdown
        (chicken string)
        (chicken port)
        (chicken io)
        (chicken process)
        (chicken process-context)
        (chicken format)
        (chicken pathname)
        (chicken file)
        sxml-transforms
        (clojurian syntax)
        srfi-1  ;; list utils
        srfi-13 ;; string utils
        srfi-14 ;; charsets
        )

(define CLONE-URL     (or (get-environment-variable "REPO2HTML_CLONE_URL") "git://git.example.com"))
(define TITLE         (or (get-environment-variable "REPO2HTML_TITLE") "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"))

;; 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 . 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) "")
          (->>
           (or directory-elements '())
           (map (constantly "../"))
           (apply string-append))))

;; main code ---------------------------------

(define css "
  body {
    margin: 0 auto;
    max-width: 700px;
  }
  pre, code {
    background-color: #ffd9df;
  }
  pre {
    padding: 15px 20px;
    white-space: pre;
    overflow: scroll;
  }
  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 {
    text-align: right;
    font-size: small;
  }
  #file-path {
    /* change this to your liking */
  }")

(define (make-sxml-template-wrapper repository-name source-files-list)
  (let ((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-present?
         (find (lambda (x) (string-prefix? "ISSUES/" x)) source-files-list)))

    (lambda (source-file body-sxml)
      (define-values (_ _ _ _ relative-root) (pathparts source-file))
      `(html (@ lang en)
        (head
         (title ,TITLE)
         (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 ,DESCRIPTION)))
         (style ,css))
        (body
         (h1 ,H1)
         (h2 ,repository-name)
         (p "clone url:" ,CLONE-URL "/" ,repository-name)
         (nav
          ,(if readme-file
             `(a (@ href ,relative-root "index.html") "about") "")
          (a (@ href ,relative-root "files.html") "files")
          ,(if license-file
             `(a (@ href ,relative-root ,license-file ".html") "license") "")
          ,(if issues-present?
             `(a (@ href ,relative-root "ISSUES.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")))))))

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

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

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

(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 "/")))
         (template-wrap->sxml (make-sxml-template-wrapper repository-name source-files-list)))

    (define (write-with-template filename sxml)
      (let ((destination-directory (pathname-directory filename)))
        (when destination-directory
          (create-directory (make-pathname html-repo-path destination-directory) #t)))
      (with-output-to-file (make-pathname html-repo-path filename)
        (lambda ()
          (display "<!DOCTYPE html>\n")
          (SXML->HTML (template-wrap->sxml filename sxml)))))

    (create-directory html-repo-path #t)
    ;; special files
    (write-with-template "files.html" (filelist->sxml source-files-list))
    (write-with-template "contributors.html" (contributors->sxml))
    (write-with-template "commits.html" (commits->sxml))
    ;; htmlified repo contents
    (for-each
     (lambda (source-file)
       (write-with-template
        (string-append source-file ".html")
        (source->sxml source-file))
       (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 README.md, README, or README.txt exists, copy that to index.html.
    ;; otherwise copy files.html to index.html.
    (->>
     '("README.md.html" "README.html" "README.txt.html" "files.html")
     (map (lambda (x) (make-pathname html-repo-path x)))
     (find file-exists?)
     ((lambda (x) (copy-file x (make-pathname html-repo-path "index.html") #t))))

    (when (file-exists? (make-pathname html-repo-path "ISSUES"))
      (write-with-template "ISSUES.html" (issueslist->sxml source-files-list)))))

(define (main args)
  (let-optionals args ((html-repo-path ""))

    (when (equal? 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)))

(main (command-line-arguments))