;;; SPDX-FileCopyrightText: 2025 Vasilij Schneidermann <mail@vasilij.de>
;;;
;;; SPDX-License-Identifier: GPL-3.0-or-later

(import scheme)
(import (chicken base))
(import (chicken file))
(import (chicken file posix))
(import (chicken format))
(import (chicken io))
(import (chicken irregex))
(import (chicken pathname))
(import (chicken port))
(import (chicken process-context))
(import (chicken sort))
(import (chicken string))
(import (srfi 1))
(import (srfi 69))
(import getopt-long)
(import (except html-parser sxml->html))
(import lowdown)
(import lowdown-org-table)
(import scsh-process)
(import sxml-transforms)
(import uri-common)

(enable-lowdown-org-tables!)

(define git-prefix (or (get-environment-variable "DEPP_PREFIX") "/srv/git"))
(define base-url "https://depp.brause.cc/")

(define (die #!rest args)
  (apply print args)
  (exit 1))

(define str string-append)

(define-record blob type size path target)
(define-record-printer (blob b out)
  (fprintf out "#<blob ~a ~a ~a ~a>"
           (blob-type b) (blob-size b) (blob-path b) (blob-target b)))

(define (blob-content path)
  (run/string (git --bare cat-file blob ,(str "HEAD:" path))))

(define (update-blob blob #!rest plist)
  (let ((blob (make-blob (blob-type blob) (blob-size blob)
                         (blob-path blob) (blob-target blob))))
    (let loop ((plist plist))
      (if (null? plist)
          blob
          (begin
            (case (car plist)
              ((#:type) (blob-type-set! blob (cadr plist)))
              ((#:size) (blob-size-set! blob (cadr plist)))
              ((#:path) (blob-path-set! blob (cadr plist)))
              ((#:target) (blob-target-set! blob (cadr plist)))
              (else (error "Unknown key" (car plist))))
            (loop (cddr plist)))))))

(define (string-starts-with? s prefix)
  (and (irregex-search `(: bol ,prefix) s) #t))

(define (string-ends-with? s suffix)
  (and (irregex-search `(: ,suffix eol) s) #t))

(define (irregex-split-once irx s)
  (let ((match (irregex-search irx s)))
    (if match
        (list (substring s 0 (irregex-match-start-index match))
              (substring s (irregex-match-end-index match)))
        (list s))))

(define (add-git-extension path)
  (if (string-ends-with? path ".git")
      path
      (str path ".git")))

(define (replace-git-extension path ext)
  (irregex-replace '(: ".git" eol) path ext))

(define post-receive-hook #<<DOC
#!/bin/sh

while read -r _ _ refname; do
    case $refname in
        refs/tags/*) tagschanged=1 ;;
        *) refschanged=1 ;;
    esac
done

if [ -n "$tagschanged" ]; then depp update-tarballs; fi
if [ -n "$refschanged" ]; then depp update-static-files; fi
DOC
)

(define (init-repo name)
  (let* ((repo-name (add-git-extension name))
         (repo-path (make-pathname git-prefix repo-name)))
    (when (not (zero? (run (git -C ,git-prefix init --bare ,repo-name))))
      (die "Failed initializing repository " repo-name " in " git-prefix))
    (when (not (zero? (run (git -C ,repo-path --bare update-server-info))))
      (die "Failed updating server info for " repo-name " in " repo-path))
    (let* ((hooks-dir (make-pathname repo-path "hooks"))
           (post-update-from (make-pathname hooks-dir "post-update.sample"))
           (post-update-to (make-pathname hooks-dir "post-update"))
           (post-receive-path (make-pathname hooks-dir "post-receive")))
      (rename-file post-update-from post-update-to 'clobber)
      (with-output-to-file post-receive-path
        (lambda ()
          (display post-receive-hook)))
      (set-file-permissions! post-receive-path #o755))))

(define (in-git-dir?)
  (file-exists? "HEAD"))

(define (ensure-in-git-dir!)
  (when (not (in-git-dir?))
    (die "Not in a bare git repository")))

(define (get-description)
  (ensure-in-git-dir!)
  (call-with-input-file "description" read-line))

(define (default-description? s)
  (string-starts-with? s "Unnamed repository; edit this file 'description'"))

(define (set-description description)
  (ensure-in-git-dir!)
  (call-with-output-file "description"
    (lambda (out)
      (display (string-chomp description) out)
      (newline out))))

(define (line->blob line)
  (let* ((parts (irregex-split-once "\t" line))
         (meta (car parts))
         (path (cadr parts))
         (parts (string-split meta " "))
         (mode (car parts))
         (size (string->number (last parts))))
    (case (string->number mode 8)
      ((#o040000) (make-blob 'directory size path #f))
      ((#o100644) (make-blob 'file size path #f))
      ((#o100755) (make-blob 'executable size path #f))
      ((#o120000) (let ((target (blob-content path)))
                    (make-blob 'symlink #f path target)))
      (else (error "Unknown Git mode" mode)))))

(define (blob-list path)
  (let* ((flags '(-lrz --full-tree))
         (output (run/string (git -C ,path --bare ls-tree ,@flags HEAD))))
    (map line->blob (string-split output "\x00"))))

(define (directory-split path)
  (if (zero? (string-length path))
      '()
      (receive (_ _ parts) (decompose-directory path)
        parts)))

(define (blob-tree blobs)
  (let ((listing (make-hash-table)))
    (define (inner prefix)
      (let ((dirs (make-hash-table))
            (files (make-hash-table)))
        (for-each
         (lambda (blob)
           (let* ((parts (directory-split (blob-path blob)))
                  (dir (butlast parts))
                  (file (last parts)))
             (if (null? dir)
                 (hash-table-set! files file (update-blob blob path: file))
                 (let ((blob (update-blob blob type: 'directory size: #f path: (car dir))))
                   (hash-table-set! dirs (car dir) blob)))))
         (filter-map
          (lambda (blob)
            (let ((path (blob-path blob)))
              (and (string-starts-with? path prefix)
                   (update-blob blob path: (substring path (string-length prefix))))))
          blobs))
        (let ((dirs (hash-table-values dirs))
              (files (hash-table-values files)))
          (hash-table-set! listing prefix (list dirs files))
          (for-each
           (lambda (blob)
             (inner (str prefix (blob-path blob) "/")))
           dirs))))
    (inner "")
    listing))

(define (blob-decoration blob)
  (case (blob-type blob)
    ((directory) "/")
    ((file) "")
    ((executable) "*")
    ((symlink) (str " -> " (blob-target blob)))))

(define (path-join p1 p2)
  (let loop ((path p1)
             (parts (directory-split p2)))
    (if (null? parts)
        path
        (loop (make-pathname path (car parts)) (cdr parts)))))

(define (hex-encode s)
  (define (pad-even s pad-char)
    (if (odd? (string-length s))
        (str (string pad-char) s)
        s))
  (define (hex-encode-char char)
    (cond
     ((char=? char #\\) "\\\\")
     ((or (char<? char #\x20) (char=? char #\x7f))
      (str "\\x" (pad-even (number->string (char->integer char) 16) #\0)))
     (else (string char))))
  (apply str (map hex-encode-char (string->list s))))

(define (comparator key comp) (lambda (a b) (comp (key a) (key b))))

(define (file-listing-sxml repo-name dir dirs files)
  (define (url target)
    (let* ((path (make-pathname (list repo-name dir) target))
           (parts (map uri-encode-string (directory-split path))))
      (str "/" (string-intersperse parts "/"))))
  (define (up)
    (let ((parent (string-intersperse (butlast (directory-split dir)) "/")))
      (str "/" (path-join repo-name parent))))
  (define (blob->sxml blob)
    `(tr (@ (class ,(symbol->string (blob-type blob))))
         (td (@ (class "size")) ,(or (blob-size blob) ""))
         (td (@ (class "path"))
             (a (@ (href ,(url (if (eqv? (blob-type blob) 'symlink)
                                   (blob-target blob)
                                   (blob-path blob)))))
                ,(hex-encode (blob-path blob)))
             ,(blob-decoration blob))))
  `(table
    (@ (class "files striped"))
    (thead
     (tr (th (@ (class "size")) "Size") (th (@ (class "path")) "Path")))
    (tbody
     ,@(if (equal? dir "") '() `((tr (td (@ (class "size")))
                                     (td (@ (class "path"))
                                         (a (@ (href ,(up))) "..")))))
     ,@(map blob->sxml (sort dirs (comparator blob-path string<?)))
     ,@(map blob->sxml (sort files (comparator blob-path string<?))))))

(define (detect-readme blobs)
  (find (lambda (blob)
          (let ((path (blob-path blob)))
            (or (member path '("README.md" "README.org"))
                (string-starts-with? path "README"))))
        (sort blobs (comparator blob-path string<?))))

(define (readme-type blob)
  (case (string->symbol (or (pathname-extension (blob-path blob)) "unknown"))
    ((md) 'markdown)
    ((org) 'org)
    (else 'plain)))

(define (sexp->string sexp)
  (with-output-to-string
    (lambda ()
      (write sexp))))

(define (with-temp-file proc)
  (let ((temp #f))
    (dynamic-wind
        (lambda () (set! temp (create-temporary-file)))
        (lambda () (proc temp))
        (lambda () (and temp (delete-file* temp))))))

(define (org->html source dest)
  (define htmlize-path
    (or (get-environment-variable "HTMLIZE_PATH")
        (error "Please set HTMLIZE_PATH to the location of htmlize.el")))
  (run (emacs --batch -Q --file ,source --script ,htmlize-path -l org
              --eval ,(sexp->string
                       `(org-export-to-file 'html ,dest nil nil nil t)))))

(define (org->sxml content)
  (with-temp-file
   (lambda (source)
     (call-with-output-file source
       (lambda (out)
         (display content out)))
     (with-temp-file
      (lambda (dest)
        (org->html source dest)
        (call-with-input-file dest html->sxml))))))

(define (convert-readme dir blob)
  (let* ((path (if (eqv? (blob-type blob) 'symlink)
                   (blob-content (make-pathname dir (blob-path blob)))
                   (blob-path blob)))
         (content (blob-content (make-pathname dir path))))
    (case (readme-type blob)
      ((markdown) (markdown->sxml content))
      ((org) (cdr (org->sxml content))) ; drop *TOP*
      ((plain) `((pre ,content)))
      (else (die "Unknown README type")))))

(define html-serialization-rules*
  `((*COMMENT* . ,(lambda (_ contents)
                    (list #\< "!--" contents "--" #\> #\newline)))
    (doctype-html . ,(lambda _ "<!DOCTYPE html>"))
    ,@universal-conversion-rules*))

(define (sxml->html sxml)
  (SRV:send-reply (pre-post-order* sxml html-serialization-rules*)))

(define (rename-directory source dest)
  (when (directory-exists? dest)
    (delete-directory dest #t))
  (when (not (zero? (run (mv ,source ,dest))))
    (die "Couldn't move directory " source " to " dest)))

(define (update-static-files)
  (ensure-in-git-dir!)
  (let* ((temp-dir (create-temporary-directory))
         (git-dir (current-directory))
         (web-dir (replace-git-extension git-dir ""))
         (repo-name (pathname-strip-directory web-dir))
         (git-name (pathname-strip-directory git-dir))
         (description (get-description))
         (title (if (default-description? description)
                    repo-name
                    (str repo-name ": " description)))
         (clone-cmd (str "git clone " base-url git-name)))
    (hash-table-for-each (blob-tree (blob-list "."))
      (lambda (dir value)
        (let* ((dirs (car value))
               (files (cadr value))
               (basedir (path-join temp-dir dir))
               (index-path (make-pathname basedir "README.html"))
               (readme (detect-readme files)))
          (create-directory basedir #t)
          (with-output-to-file index-path
            (lambda ()
              (sxml->html
               `((doctype-html)
                 (html
                  (@ (lang "en"))
                  (head
                   (meta (@ (charset "UTF-8")))
                   (meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))
                   (link (@ (href "/style.css") (rel "stylesheet") (type "text/css")))
                   (title ,title))
                  (body
                   (div
                    (@ (class "main"))
                    (header
                     (@ (class "projects"))
                     (a (@ (href "/"))
                        (h1 "Git hosting")))
                    (section
                     (@ (class "repo-meta"))
                     (h2 (a (@ (href ,(str "/" repo-name))) ,repo-name)
                         ,(if (default-description? description)
                              ""
                              (str ": " description))))
                    ,@(if (equal? dir "")
                          `((section
                             (@ (class "clone"))
                             (h2 "Clone")
                             (code ,clone-cmd)))
                          '())
                    (section
                     (@ (class "files"))
                     (h2 "Files")
                     ,(file-listing-sxml repo-name dir dirs files))
                    ,@(if readme
                          `((section
                             (@ (class "readme"))
                             (h2 ,(blob-path readme))
                             ,@(convert-readme dir readme)))
                          '()))))))))
          (for-each
           (lambda (blob)
             (let* ((file (blob-path blob))
                    (in-path (make-pathname dir file))
                    (out-path (make-pathname basedir file)))
               (when (not (equal? (blob-type blob) 'symlink))
                 (call-with-output-file out-path
                   (lambda (out)
                     (display (blob-content in-path) out))))))
           files))))
    (rename-directory temp-dir web-dir)))

(define (update-tarballs)
  (ensure-in-git-dir!)
  (let* ((temp-dir (create-temporary-directory))
         (git-dir (current-directory))
         (release-dir (replace-git-extension git-dir ".releases"))
         (name (replace-git-extension (pathname-strip-directory git-dir) "")))
    (for-each
     (lambda (tag)
       (let ((prefix-flag (str "--prefix=" name "-" tag "/"))
             (tarball (str name "-" tag ".tar.gz")))
         (run (git archive --format=tar.gz ,prefix-flag ,tag)
              (> ,(make-pathname temp-dir tarball)))))
     (run/strings (git --bare tag --list)))
    (rename-directory temp-dir release-dir)))

(define (with-current-directory dir proc)
  (let ((old-dir (current-directory)))
    (dynamic-wind
        (lambda () (change-directory dir))
        proc
        (lambda () (change-directory old-dir)))))

(define (for-each-git-directory proc)
  (for-each
   (lambda (dir)
     (when (string-ends-with? dir ".git")
       (with-current-directory (make-pathname git-prefix dir) proc)))
   (directory git-prefix)))

(define (show-description type)
  (let* ((git-dir (current-directory))
         (description (get-description))
         (default? (default-description? description)))
    (case type
      ((set) (when (not default?) (print git-dir ": " description)))
      ((unset) (when default? (print git-dir)))
      (else (error "Unknown type")))))

(define (show-set-descriptions)
  (for-each-git-directory (lambda () (show-description 'set))))

(define (show-missing-descriptions)
  (for-each-git-directory (lambda () (show-description 'unset))))

(define (update-all-static-files)
  (for-each-git-directory update-static-files))

(define (update-all-tarballs)
  (for-each-git-directory update-tarballs))

(define (usage-hint)
  (define prog "depp")
  (print "usage:")
  (print " " prog " init <name>")
  (print " " prog " get-description")
  (print " " prog " set-description <new-description>")
  (print " " prog " show-set-descriptions")
  (print " " prog " show-missing-descriptions")
  (print " " prog " update-static-files")
  (print " " prog " update-all-static-files")
  (print " " prog " update-tarballs")
  (print " " prog " update-all-tarballs"))

(define options
  '((chdir
     (value (required DIR))
     (single-char #\C))))

(define (main)
  (define (required-arg args)
    (if (= (length args) 1) (car args) (die "Missing required argument")))
  (let* ((opts (getopt-long (command-line-arguments) options))
         (dir (alist-ref 'chdir opts))
         (rest (alist-ref '@ opts)))
    (when (null? rest)
      (usage-hint)
      (exit 1))
    (when dir
      (change-directory dir))
    (let ((command (string->symbol (car rest)))
          (args (cdr rest)))
      (case command
        ((help) (usage-hint))
        ((init) (init-repo (required-arg args)))
        ((get-description) (display (get-description)))
        ((set-description) (set-description (required-arg args)))
        ((show-set-descriptions) (show-set-descriptions))
        ((show-missing-descriptions) (show-missing-descriptions))
        ((update-static-files) (update-static-files))
        ((update-all-static-files) (update-all-static-files))
        ((update-tarballs) (update-tarballs))
        ((update-all-tarballs) (update-all-tarballs))
        (else (die "Invalid command given " command))))))

(main)