;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>

;;;;

;;;; SPDX-License-Identifier: AGPL-3.0-or-later

;;;;

;;;; This program is free software: you can redistribute it and/or modify

;;;; it under the terms of the GNU Affero General Public License as published by

;;;; the Free Software Foundation, either version 3 of the License, or

;;;; (at your option) any later version.

;;;;

;;;; This program is distributed in the hope that it will be useful,

;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

;;;; GNU Affero General Public License for more details.

;;;;

;;;; You should have received a copy of the GNU Affero General Public License

;;;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;;;

(define-module (gitile repo)

  #:use-module (git)

  #:use-module (git types)

  #:use-module (srfi srfi-9)

  #:use-module (system foreign)

  #:export (get-branches

            get-tags

            get-files

            get-file-content

            get-commits

            get-commit

            get-description

            last-commit

            <file>

            make-file

            file?

            file-name

            file-type

            <mytag>

            make-mytag

            mytag-name

            mytag-message

            mytag-target))

(define tree-entry-type

  (let ((proc (libgit2->procedure int "git_tree_entry_type" '(*))))

    (lambda (entry)

      (proc (tree-entry->pointer entry)))))

(define tag-foreach

  (let ((proc (libgit2->procedure* "git_tag_foreach"

                                   `(* * *))))

    (lambda (repository callback)

      (let ((callback* (procedure->pointer int

                                           (lambda (name oid _)

                                             (callback

                                               (pointer->string name)

                                               (pointer->oid oid)))

                                           '(* * *))))

        (proc (repository->pointer repository) callback* %null-pointer)))))

(define (get-branches repo)

  (map (lambda (ref) (cons (reference-shorthand ref) (reference-name ref)))

       (filter reference-branch? (reference-fold cons '() repo))))

(define-record-type <mytag>

  (make-mytag name message target date)

  mytag?

  (name    mytag-name)

  (message mytag-message)

  (target  mytag-target)

  (date    mytag-date))

(define (get-tags repo)

  (let ((tags '()))

    (tag-foreach

      repo

      (lambda (name oid)

        (let* ((tag (false-if-exception (tag-lookup repo oid)))

               (oid (if tag (tag-target-id tag) oid))

               (commit (commit-lookup repo oid))

               (date (commit-time commit)))

          (set! tags

            (cons

              (make-mytag

                (cond

                  (tag (tag-name tag))

                  ((string-prefix? "refs/tags/" name)

                   (substring name (string-length "refs/tags/")))

                  (else name))

                (if tag (tag-message tag) "")

                (oid->string oid)

                date)

              tags)))

        0))

    (sort tags (lambda (t1 t2) (> (mytag-date t1) (mytag-date t2))))))

(define (search-reference repo name)

  (reference-fold (lambda (ref acc)

                    (if (equal? name (reference-shorthand ref))

                        (reference-name ref)

                        acc))

                  #f

                  repo))

(define (ref->oid repo ref)

  (define (ref->oid* repo ref)

    (let ((ref-name (or ref

                        (false-if-exception (reference-name (repository-head repo))))))

      (or (false-if-exception (string->oid ref-name))

          (false-if-exception (reference-name->oid repo ref-name))

          (false-if-exception (reference-name->oid repo (search-reference repo ref-name))))))

  (or (ref->oid* repo ref)

      (throw 'not-found

             `(content ((p "Ref not found in repository: " ,ref)))

             `(ref ,ref))))

(define-record-type <file>

  (make-file name type commit)

  file?

  (name   file-name)

  (type   file-type)

  (commit file-commit))

(define* (get-files repo #:key (path "") (ref #f))

  (let* ((oid (ref->oid repo ref))

         (commit (commit-lookup repo oid))

         (tree (commit-tree commit)))

    (let ((result '()))

      (tree-walk

        tree TREEWALK-PRE

        (lambda (root entry)

          (when (equal? root path)

            (set! result

              (cons (make-file (tree-entry-name entry)

                               (tree-entry-type entry)

                               (last-commit-for-file

                                 (string-append root (tree-entry-name entry))

                                 commit))

                    result)))

          0))

      result)))

(define (last-commit repo ref)

  (let ((oid (ref->oid repo ref)))

    (commit-lookup repo oid)))

(define* (get-file-content repo path #:key (ref #f))

  (let* ((oid (ref->oid repo ref))

         (commit (commit-lookup repo oid))

         (tree (commit-tree commit))

         (entry (false-if-exception (tree-entry-bypath tree path))))

    (if entry

        (let* ((entry-oid (tree-entry-id entry))

               (blob (blob-lookup repo entry-oid)))

          (blob-content blob))

        (throw 'not-found

               `(content ((p "path not found in repository for this commit: " ,path)))

               `(ref ,ref)))))

(define (last-commit-for-file path commit)

  (let* ((initial-tree (commit-tree commit))

         (initial-entry (false-if-exception (tree-entry-bypath initial-tree path))))

    (let loop ((commit commit))

      (let ((pcommit (false-if-exception (commit-parent commit))))

        (if pcommit

            (let* ((ptree (commit-tree pcommit))

                   (pentry (false-if-exception (tree-entry-bypath ptree path))))

              (if (or (and (not initial-entry) (not pentry))

                      (and initial-entry pentry

                           (equal? (tree-entry-id initial-entry)

                                   (tree-entry-id pentry))))

                  (loop pcommit)

                  commit))

            commit)))))

(define (get-commits repo ref)

  (let* ((oid (ref->oid repo ref))

         (commit (commit-lookup repo oid)))

    (let loop ((result (list commit)) (commit commit))

      (let ((pcommit (false-if-exception (commit-parent commit))))

        (if (and pcommit (< (length result) 20))

            (loop (cons pcommit result) pcommit)

            (cons (reverse result) pcommit))))))

(define (get-options config)

  (let ((out '()))

    (config-foreach

      config

      (lambda (entry)

        (set! out (cons (cons (config-entry-name entry)

                              (config-entry-value entry))

                        out))

        0))

    out))

(define (get-description repo)

  (let* ((config (repository-config repo))

         (options (get-options config)))

    (or (assoc-ref options "gitweb.description") "")))

(define (get-commit repo hash)

  (let* ((oid (ref->oid repo hash))

         (commit (false-if-exception (commit-lookup repo oid))))

    (or commit

        (throw 'not-found

               `(content ((p "Commit not found in this repository: " ,hash)))

               `(ref ,hash)))))