#!/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) ) (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")) (define (populate-html-template repository-name source-files-list 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 #{TITLE}

#{H1}

#{repository-name}

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

string-block ) (display-body-thunk) (display #<#string-block string-block )) (define (display-escaped-html str) (SRV:send-reply (string->goodHTML str))) (define (in-git-directory?) (not (eof-object? (call-with-input-pipe "git rev-parse --git-dir" read-line)))) (define (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 (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 "
")) (define (binary) (display "

(Binary file)

")) (format #t "

~a

" source-file) (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.
")
           (plaintext))
       (markdown->html (git-file->string source-file))))
    ((jpg jpeg png gif webp webm apng avif svgz ico)
     (image-link))
    ((svg)
     (image-link) (plaintext))
    ((gz pack idx)
     (binary))
    (else
     (if (is-text? source-file)
         (plaintext)
         (binary)))))

(define (display-files-html source-files-list)
  (display "\n"))

(define (display-contributors-html)
  (SXML->HTML
   `((h1 "Contributors")
     (ul ,(map
           (lambda (line)
             (let-values (((commits . author) (apply values (string-split line "\t"))))
               `(li ,author)))
           (call-with-input-pipe "git shortlog -ns HEAD" read-lines))))))

(define (first-if pred lst)
  (cond ((null? lst) #f)
        ((pred (car lst)) (car lst))
        (else (first-if pred (cdr lst)))))

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

    (define (write-with-template filename display-body-thunk)
      (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 () (populate-html-template repository-name source-files-list filename display-body-thunk))))

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

(define (bail . args)
  (let-optionals args ((status 1) (msg ""))
    (unless (equal? "" msg) (print msg))
    (exit status)))

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

    (when (equal? html-repo-path "")
      (bail 1 "please specify a destination directory for html files"))

    (unless (in-git-directory?)
      (bail 1 "woops this isn't a git directory"))

    (generate-html-files html-repo-path)))

(main (command-line-arguments))