(define-module (guix-qa-frontpage git-repository)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 exceptions)
  #:use-module (fibers scheduler)
  #:use-module (git)
  #:use-module (git rev-parse)
  #:use-module (git object)
  #:use-module (git oid)
  #:use-module (git structs)
  #:use-module (guix build utils)
  #:use-module ((guix build utils) #:select (with-directory-excursion))
  #:export (%git-repository-location

            ensure-repository-exists!
            update-repository!
            with-bare-git-repository
            with-git-worktree

            get-commit

            get-git-branch-head-committer-date
            get-git-merge-base))

(define %git-repository-location
  (make-parameter #f))

(define* (guix.git-excursion thunk #:optional dir)
  (when (current-scheduler)
    (error "guix.git-excursion can't be used from fibers"))

  (monitor
   (with-directory-excursion (or dir (%git-repository-location))
     (thunk))))

(define (ensure-repository-exists!)
  (unless (file-exists? (%git-repository-location))
    (when (current-scheduler)
      (error "guix.git-excursion can't be used from fibers"))
    (monitor
     (unless (file-exists? (%git-repository-location))
       (invoke "git" "init" "--bare"
               (%git-repository-location))

       (guix.git-excursion
        (lambda ()
          (invoke "git" "remote" "add" "origin"
                  "https://git.savannah.gnu.org/git/guix.git")
          (invoke "git" "remote" "add" "patches"
                  "git@git.guix-patches.cbaines.net:guix-patches")

          (invoke "git" "config" "user.name" "Guix Patches Tester")
          (invoke "git" "config" "user.email" "")))))))

(define (update-repository!)
  (with-bare-git-repository
   (lambda ()
     (invoke "git" "prune")
     (invoke "git" "fetch" "--prune" "origin")
     (invoke "git" "fetch" "--prune" "patches")
     (invoke "git" "fetch" "--force" "--tags" "patches"))))

(define (with-bare-git-repository thunk)
  (ensure-repository-exists!)

  (guix.git-excursion thunk))

(define* (with-git-worktree name commit thunk
                            #:key remove-after?)
  (with-bare-git-repository
   (lambda ()
     (invoke "git" "worktree" "add"
             (string-append "../" name)
             "-b" name
             commit)))

  (guix.git-excursion thunk name)

  (when remove-after?
    (with-bare-git-repository
     (lambda ()
       (system* "git" "worktree" "remove" "--force" name)
       (system* "git" "branch" "-D" name)))))

(define (get-commit ref)
  (ensure-repository-exists!)

  (with-exception-handler
      (lambda (exn)
        (if (and (exception-with-irritants? exn)
                 (let ((irritant (first (exception-irritants exn))))
                   (and (git-error? irritant)
                        (= (git-error-code irritant) -3))))
            #f
            (raise-exception exn)))
    (lambda ()
      (let ((repo (repository-open (%git-repository-location))))
        (oid->string (object-id (revparse-single repo ref)))))
    #:unwind? #t))

(define (get-git-branch-head-committer-date branch)
  (with-bare-git-repository
   (lambda ()
     (let ((pipe (open-pipe* OPEN_READ
                             "git" "show" "-s" "--format=%ci" branch "--")))
       (let loop ((line (read-line pipe))
                  (lines '()))
         (if (eof-object? line)
             (begin
               (close-pipe pipe)

               (if (null? lines)
                   #f
                   (string->date (first lines)
                                 "~Y-~m-~d ~H:~M:~S ~z")))
             (loop (read-line pipe)
                   (cons line lines))))))))

(define (get-git-merge-base a b)
  (with-bare-git-repository
   (lambda ()
     (let ((pipe (open-pipe* OPEN_READ
                             "git" "merge-base" a b)))
       (let loop ((line (read-line pipe))
                  (lines '()))
         (if (eof-object? line)
             (begin
               (close-pipe pipe)

               (if (null? lines)
                   #f
                   (first lines)))
             (loop (read-line pipe)
                   (cons line lines))))))))