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