#!/usr/bin/csi -s

(import
  (chicken file)
  (chicken format)
  (chicken io)
  (chicken pathname)
  (chicken port)
  (chicken process)
  (chicken process-context)
  (chicken string)
  (clojurian syntax)
  scss
  lowdown
  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 . 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))))

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

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

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

(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 ,(string-append 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 ,DESCRIPTION)))
         (style ,mycss))
        (body
         (h1 ,H1)
         (h2 ,repository-name)
         (p "clone url:" ,CLONE-URL "/" ,repository-name)
         (nav
          ,(when readme-file
             `(a (@ href ,relative-root "index.html") "about"))
          (a (@ href ,relative-root "files.html") "files")
          ,(when license-file
             `(a (@ href ,relative-root ,license-file ".html") "license"))
          ,(when 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 (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 (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
           (pre-post-order*
            (template-wrap->sxml filename sxml)
            `(;; 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*))))))

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