#lang racket/base

(require ffi/unsafe
         racket/list
         racket/match
         racket/path
         racket/string
         "credentials.rkt"
         libgit2)

(provide git
         dgit
         git-repository?
         git-root
         git-init
         git-clone
         (struct-out git-status-entry)
         git-status
         git-status-lines
         git-clean?
         git-diff
         git-add
         git-config
         git-config-get
         git-config-set
         git-commit
         git-head
         git-current-branch
         git-branches
         git-branch
         git-branch-delete
         git-checkout
         git-checkout-new
         git-tags
         git-tag
         git-tag-delete
         (struct-out git-log-entry)
         git-log
         git-log-lines
         git-remotes
         git-remote-add
         git-remote-url
         git-fetch
         git-pull
         git-push
         git-push-tag
         git-credentials-init!
         git-credentials-unlock!
         git-credentials-lock!
         git-credentials-unlocked?
         git-credentials-unlock-expires
         git-credentials-set!
         git-credentials-ref
         git-credentials-configured?
         git-credentials-remove!)

(struct git-status-entry (path code flags) #:transparent)
(struct git-log-entry (id summary time) #:transparent)

(define zero-oid-string (make-string GIT_OID_HEXSZ #\0))
(define branch-prefix "refs/heads/")
(define tag-prefix "refs/tags/")

(define GIT-CREDTYPE-USERPASS-PLAINTEXT #x0001)
(define GIT-CREDTYPE-USERNAME #x0020)
(define GIT-PASSTHROUGH -30)

(define (git-credential-callback out url username-from-url allowed-types _payload)
  ;; Never let a Racket exception escape through a C callback.  In particular,
  ;; a locked credential store used to throw here, which can destabilize the
  ;; enclosing Racket/DrRacket process.
  (with-handlers ([exn:fail? (lambda (_) GIT-PASSTHROUGH)])
    (define saved (git-credentials-ref url))
    (cond
      [(not saved) GIT-PASSTHROUGH]
      [else
       (define username
         (if (and username-from-url (not (string=? username-from-url "")))
             username-from-url
             (car saved)))
       (define token (cdr saved))
       (cond
         [(not (zero? (bitwise-and allowed-types GIT-CREDTYPE-USERPASS-PLAINTEXT)))
          (ptr-set! out _git_credential
                    (git_credential_userpass_plaintext_new username token))
          0]
         [(not (zero? (bitwise-and allowed-types GIT-CREDTYPE-USERNAME)))
          ;; This credential is only used as an intermediate username response.
          ;; libgit2 owns the credential after the callback returns.
          (ptr-set! out _git_credential
                    (git_credential_username_new username))
          0]
         [else GIT-PASSTHROUGH])])))

(define (set-credential-callback! callbacks)
  (set-git_remote_callbacks-credentials! callbacks git-credential-callback)
  callbacks)

(define (make-fetch-options)
  (define options
    (cast (malloc _git_fetch_opts 'atomic) _pointer _git_fetch_opts-pointer))
  (git_fetch_options_init options GIT_FETCH_OPTS_VERSION)
  (set-credential-callback! (git_fetch_opts-callbacks options))
  options)

(define (make-push-options)
  (define options
    (cast (malloc _git_push_opts 'atomic) _pointer _git_push_opts-pointer))
  (git_push_options_init options GIT_PUSH_OPTS_VERSION)
  (set-credential-callback! (git_push_opts-callbacks options))
  options)

(define (make-clone-options)
  (define options
    (cast (malloc _git_clone_opts 'atomic) _pointer _git_clone_opts-pointer))
  (git_clone_options_init options GIT_CLONE_OPTS_VERSION)
  (set-credential-callback!
   (git_fetch_opts-callbacks (git_clone_opts-fetch_opts options)))
  options)

(define (blank-oid)
  (git_oid_fromstr zero-oid-string))

(define (repository-path [start (current-directory)])
  (or (git_repository_discover start)
      (error 'git "not inside a Git repository: ~a" start)))

(define (open-repository [start (current-directory)])
  (git_repository_open (repository-path start)))

(define (git-repository? [path (current-directory)])
  (and (git_repository_discover path) #t))

(define (git-root [path (current-directory)])
  (define repo (open-repository path))
  (define root
    (if (git_repository_is_bare repo)
        (git_repository_path repo)
        (git_repository_workdir repo)))
  (simplify-path (string->path root)))

(define (git-init [path (current-directory)] #:bare? [bare? #f])
  (git_repository_init path #:bare? bare?)
  (git-root path))

(define (default-clone-directory url)
  (define cleaned (regexp-replace #rx"/+$" url ""))
  (define parts
    (filter (lambda (s) (not (string=? s "")))
            (regexp-split #rx"[/\\\\:]" cleaned)))
  (unless (pair? parts)
    (error 'git-clone "cannot derive a directory name from ~a" url))
  (regexp-replace #rx"[.]git$" (last parts) ""))

(define git-clone
  (case-lambda
    [(url)
     (git-clone url (default-clone-directory url))]
    [(url path)
     (git_clone url
                (path->string (if (path? path) path (string->path path)))
                (make-clone-options))
     (git-root path)]))

(define (normalize-status-flags flags)
  (cond
    [(list? flags) flags]
    [(symbol? flags)
     (if (eq? flags 'GIT_STATUS_CURRENT) null (list flags))]
    [else null]))

(define (has-status? flags flag)
  (and (memq flag flags) #t))

(define (index-status-char flags)
  (cond
    [(has-status? flags 'GIT_STATUS_INDEX_NEW) #\A]
    [(has-status? flags 'GIT_STATUS_INDEX_MODIFIED) #\M]
    [(has-status? flags 'GIT_STATUS_INDEX_DELETED) #\D]
    [(has-status? flags 'GIT_STATUS_INDEX_RENAMED) #\R]
    [(has-status? flags 'GIT_STATUS_INDEX_TYPECHANGE) #\T]
    [else #\space]))

(define (worktree-status-char flags)
  (cond
    [(has-status? flags 'GIT_STATUS_WT_MODIFIED) #\M]
    [(has-status? flags 'GIT_STATUS_WT_DELETED) #\D]
    [(has-status? flags 'GIT_STATUS_WT_RENAMED) #\R]
    [(has-status? flags 'GIT_STATUS_WT_TYPECHANGE) #\T]
    [(has-status? flags 'GIT_STATUS_WT_UNREADABLE) #\?]
    [else #\space]))

(define (status-code flags)
  (cond
    [(has-status? flags 'GIT_STATUS_CONFLICTED) "UU"]
    [(has-status? flags 'GIT_STATUS_IGNORED) "!!"]
    [(has-status? flags 'GIT_STATUS_WT_NEW) "??"]
    [else
     (string (index-status-char flags)
             (worktree-status-char flags))]))

(define (git-status)
  (define repo (open-repository))
  (define result null)
  (git_status_foreach
   repo
   (lambda (path raw-flags _payload)
     (define flags (normalize-status-flags raw-flags))
     ;; Match normal `git status`: ignored files are not shown unless
     ;; explicitly requested.  git_status_foreach uses libgit2's defaults,
     ;; which may include them.
     (unless (has-status? flags 'GIT_STATUS_IGNORED)
       (set! result
             (cons (git-status-entry path (status-code flags) flags)
                   result)))
     0)
   #"")
  (sort result
        (lambda (a b)
          (string<? (git-status-entry-path a)
                    (git-status-entry-path b)))))

(define (git-status-lines [entries (git-status)])
  (for/list ([entry (in-list entries)])
    (format "~a ~a"
            (git-status-entry-code entry)
            (git-status-entry-path entry))))

(define (git-clean?)
  (null? (git-status)))

(define (make-diff-options)
  (define options
    (cast (malloc _git_diff_opts 'atomic) _pointer _git_diff_opts-pointer))
  (git_diff_options_init options GIT_DIFF_OPTS_VERSION)
  options)

(define (diff->string diff)
  (define bs (git_diff_to_buf diff 'GIT_DIFF_FORMAT_PATCH))
  (if bs (bytes->string/utf-8 bs #\uFFFD) ""))

(define (git-diff . args)
  (define repo (open-repository))
  (define options (make-diff-options))
  (define index (git_repository_index repo))
  (define diff
    (match args
      ['()
       ;; Same basic comparison as `git diff`: index versus worktree.
       (git_diff_index_to_workdir repo index options)]
      [(list '--cached)
       ;; Same basic comparison as `git diff --cached`: HEAD tree versus index.
       (define parent (head-commit repo))
       (unless parent
         (error 'git-diff "--cached requires an existing HEAD commit"))
       (define tree (git_commit_tree parent))
       (git_diff_tree_to_index repo tree index options)]
      [_ (error 'git-diff "invalid arguments: ~e" args)]))
  (diff->string diff))

(define (git-path-string path)
  (regexp-replace* #rx"\\\\" (path->string path) "/"))

(define (relative-pathspec workdir path)
  (define p0 (if (path? path) path (string->path path)))
  ;; A relative path supplied by the caller is relative to the caller's
  ;; current directory, not automatically to the repository root.
  (define p (path->complete-path p0 (current-directory)))
  (define rel (find-relative-path workdir p))
  (define s (git-path-string rel))
  (when (or (string=? s "..")
            (string-prefix? s "../"))
    (error 'git-add "path is outside the repository: ~a" path))
  s)

(define (index-accept _path _matched-pathspec _payload)
  0)

(define (git-add . paths)
  (define repo (open-repository))
  (define workdir (string->path (git_repository_workdir repo)))
  (define index (git_repository_index repo))
  (define pathspecs
    (make-git_strarray
     (for/list ([path (in-list paths)])
       (relative-pathspec workdir path))))
  ;; update-all stages changes and removals of already tracked files;
  ;; add-all adds new files and updates existing files while respecting ignores.
  (git_index_update_all index pathspecs index-accept #"")
  (git_index_add_all index pathspecs 'GIT_INDEX_ADD_DEFAULT index-accept #"")
  (git_index_write index)
  (void))

(define (git-config-get key)
  (define repo (open-repository))
  (define config (git_repository_config repo))
  ;; git_config_get_string is incorrectly declared as an allocating wrapper
  ;; in the current Racket libgit2 package.  The entry API has the correct
  ;; ownership model and works on normal repository config objects.
  (define entry (git_config_get_entry config key))
  (git_config_entry-value entry))

(define (git-config-set key value)
  (define repo (open-repository))
  (define config (git_repository_config repo))
  (git_config_set_string config key value)
  value)

(define git-config
  (case-lambda
    [(key) (git-config-get key)]
    [(key value) (git-config-set key value)]))

(define (head-commit repo)
  (cond
    [(git_repository_is_empty repo) #f]
    [(git_repository_head_unborn repo) #f]
    [else
     (define head (git_repository_head repo))
     (git_commit_lookup repo (git_reference_target head))]))

(define (git-head)
  (define repo (open-repository))
  (define commit (head-commit repo))
  (and commit (git_oid_fmt (git_commit_id commit))))

(define (git-commit message)
  (define repo (open-repository))
  (define index (git_repository_index repo))
  (when (git_index_has_conflicts index)
    (error 'git-commit "the index contains unresolved conflicts"))

  (define tree-id (blank-oid))
  (git_index_write_tree tree-id index)
  (define tree (git_tree_lookup repo tree-id))
  (define parent (head-commit repo))

  (cond
    [(and (not parent) (zero? (git_index_entrycount index)))
     (error 'git-commit "nothing staged to commit")]
    [(and parent (git_oid_equal tree-id (git_commit_tree_id parent)))
     (error 'git-commit "nothing staged to commit")])

  (define signature (git_signature_default repo))
  (define commit-id (blank-oid))
  (if parent
      (git_commit_create_v commit-id repo "HEAD"
                           signature signature #f message tree
                           1 parent)
      (git_commit_create_v commit-id repo "HEAD"
                           signature signature #f message tree
                           0))
  (git_oid_fmt commit-id))

(define (git-current-branch)
  (define repo (open-repository))
  (cond
    [(git_repository_head_detached repo) #f]
    [(git_repository_head_unborn repo)
     (define head (git_reference_lookup repo "HEAD"))
     (define target (git_reference_symbolic_target head))
     (and target
          (string-prefix? target branch-prefix)
          (substring target (string-length branch-prefix)))]
    [else
     (git_reference_shorthand (git_repository_head repo))]))

(define (git-branches)
  (define repo (open-repository))
  (define branches null)
  (git_reference_foreach_name
   repo
   (lambda (name _payload)
     (when (string-prefix? name branch-prefix)
       (set! branches
             (cons (substring name (string-length branch-prefix)) branches)))
     0)
   #"")
  (sort branches string<?))

(define (create-branch name)
  (define repo (open-repository))
  (define commit (head-commit repo))
  (unless commit
    (error 'git-branch "cannot create a branch before the first commit"))
  (git_branch_create repo name commit #f)
  name)

(define git-branch
  (case-lambda
    [() (git-branches)]
    [(name) (create-branch name)]))

(define (git-branch-delete name)
  (define repo (open-repository))
  (define ref (git_branch_lookup repo name 'GIT_BRANCH_LOCAL))
  (git_branch_delete ref)
  (void))

(define (git-checkout name)
  (define repo (open-repository))
  (cond
    [(member name (git-branches))
     (define refname (string-append branch-prefix name))
     (define object (git_revparse_single repo (string-append refname "^{commit}")))
     ;; Checkout first: with default safe checkout, a dirty worktree aborts
     ;; before HEAD is changed.
     (git_checkout_tree repo object #f)
     (git_repository_set_head repo refname)]
    [else
     (define object (git_revparse_single repo (string-append name "^{commit}")))
     (git_checkout_tree repo object #f)
     (git_repository_set_head_detached repo (git_object_id object))])
  (git-head))

(define (git-checkout-new name)
  (git-branch name)
  (git-checkout name))

(define (git-tags)
  (define tags null)
  (git_tag_foreach
   (open-repository)
   (lambda (name _oid _payload)
     (set! tags
           (cons (if (string-prefix? name tag-prefix)
                     (substring name (string-length tag-prefix))
                     name)
                 tags))
     0)
   #"")
  (sort tags string<?))

(define (create-tag name)
  (define repo (open-repository))
  (unless (head-commit repo)
    (error 'git-tag "cannot tag a repository without commits"))
  (define target (git_revparse_single repo "HEAD^{commit}"))
  (define tag-id (blank-oid))
  (git_tag_create_lightweight tag-id repo name target #f)
  (git_oid_fmt tag-id))

(define git-tag
  (case-lambda
    [() (git-tags)]
    [(name) (create-tag name)]))

(define (git-tag-delete name)
  (git_tag_delete (open-repository) name)
  (void))

(define (git-log [max-count 20])
  (unless (exact-nonnegative-integer? max-count)
    (raise-argument-error 'git-log "exact-nonnegative-integer?" max-count))
  (define repo (open-repository))
  (cond
    [(not (head-commit repo)) null]
    [else
     (define walk (git_revwalk_new repo))
     (git_revwalk_sorting walk '(GIT_SORT_TOPOLOGICAL GIT_SORT_TIME))
     (git_revwalk_push_head walk)
     (let loop ([left max-count] [result null])
       (cond
         [(zero? left) (reverse result)]
         [else
          (define oid (git_revwalk_next walk))
          (if oid
              (let ([commit (git_commit_lookup repo oid)])
                (loop (sub1 left)
                      (cons (git-log-entry (git_oid_fmt oid)
                                           (or (git_commit_summary commit) "")
                                           (git_commit_time commit))
                            result)))
              (reverse result))]))]))

(define (git-log-lines [entries (git-log)])
  (for/list ([entry (in-list entries)])
    (format "~a ~a"
            (substring (git-log-entry-id entry) 0 7)
            (git-log-entry-summary entry))))

(define (git-remotes)
  ;; git_remote_list is affected by the same git_strarray wrapper problem as
  ;; git_tag_list in the current Racket bindings.  Remote URLs are stored in
  ;; repository config, so enumerate those entries instead.
  (define repo (open-repository))
  (define config (git_repository_config repo))
  (define remotes null)
  (git_config_foreach
   config
   (lambda (entry _payload)
     (define key (git_config_entry-name entry))
     (define m (regexp-match #rx"^remote[.](.+)[.]url$" key))
     (when m
       (set! remotes (cons (cadr m) remotes)))
     0)
   #"")
  (sort (remove-duplicates remotes) string<?))

(define (git-remote-add name url)
  (git_remote_create (open-repository) name url)
  name)

(define (git-remote-url [name "origin"])
  (define remote (git_remote_lookup (open-repository) name))
  (git_remote_url remote))

(define (http-remote? url)
  (and (string? url) (regexp-match? #px"^https?://" url)))

(define (check-remote-credentials who remote-name)
  (define url (git-remote-url remote-name))
  (when (and (http-remote? url)
             (git-credentials-configured? url)
             (not (git-credentials-unlocked?)))
    (error who
           "credential store 'racket-git is locked for remote ~a; use (git 'credentials 'unlock <password>)"
           remote-name))
  url)

(define (git-fetch [name "origin"])
  (check-remote-credentials 'git-fetch name)
  (define repo (open-repository))
  (define remote (git_remote_lookup repo name))
  (git_remote_fetch remote #f (make-fetch-options) (format "fetch ~a" name))
  (void))

(define (git-pull [remote-name "origin"])
  (define branch (git-current-branch))
  (unless branch
    (error 'git-pull "pull requires an attached local branch"))

  (git-fetch remote-name)

  (define repo (open-repository))
  (define local-ref-name (string-append branch-prefix branch))
  (define local-ref (git_reference_lookup repo local-ref-name))
  (define local-id (git_reference_target local-ref))
  (define remote-spec
    (format "refs/remotes/~a/~a^{commit}" remote-name branch))
  (define remote-object (git_revparse_single repo remote-spec))
  (define remote-id (git_object_id remote-object))

  (cond
    [(git_oid_equal local-id remote-id) #f]
    [(git_graph_descendant_of repo remote-id local-id)
     ;; Update the worktree safely before moving the branch reference.
     (git_checkout_tree repo remote-object #f)
     (git_reference_set_target
      local-ref remote-id (format "pull: fast-forward from ~a" remote-name))
     (git_oid_fmt remote-id)]
    [else
     (error 'git-pull
            "non-fast-forward pull is not supported; merge or rebase explicitly")]))

(define (temporary-remote-name)
  (format "racket-git-push-~a-~a"
          (inexact->exact (floor (current-inexact-milliseconds)))
          (random 1000000000)))

(define (push-refspec remote-name refspec)
  (define url (check-remote-credentials 'git-push remote-name))
  (when (and (http-remote? url)
             (not (git-credentials-configured? url)))
    (error 'git-push
           "no HTTPS credentials are stored for ~a; use (git 'credentials 'set <url> <username> <token>)"
           url))
  (define repo (open-repository))
  (define options (make-push-options))
  ;; The public Racket binding for git_remote_push cannot currently marshal a
  ;; non-null git_strarray correctly.  Its null form is public and supported:
  ;; libgit2 then uses the remote's configured push refspecs.  Use a temporary
  ;; remote so the user's real remote configuration is never modified.
  (define temp-name (temporary-remote-name))
  (dynamic-wind
    (lambda ()
      (git_remote_create repo temp-name url)
      (define config (git_repository_config repo))
      (git_config_set_string config
                             (format "remote.~a.push" temp-name)
                             refspec))
    (lambda ()
      (define remote (git_remote_lookup repo temp-name))
      (git_remote_push remote #f options))
    (lambda ()
      (define config (git_repository_config repo))
      (for ([suffix (in-list '("url" "fetch" "push"))])
        (with-handlers ([exn:fail? void])
          (git_config_delete_entry
           config
           (format "remote.~a.~a" temp-name suffix))))))
  (void))

(define git-push
  (case-lambda
    [()
     (define branch (git-current-branch))
     (unless branch
       (error 'git-push "push requires an attached local branch"))
     (git-push "origin" branch)]
    [(remote-name)
     (define branch (git-current-branch))
     (unless branch
       (error 'git-push "push requires an attached local branch"))
     (git-push remote-name branch)]
    [(remote-name branch)
     (push-refspec
      remote-name
      (format "refs/heads/~a:refs/heads/~a" branch branch))]))

(define git-push-tag
  (case-lambda
    [(tag) (git-push-tag tag "origin")]
    [(tag remote-name)
     (push-refspec
      remote-name
      (format "refs/tags/~a:refs/tags/~a" tag tag))]))

(define (git command . args)
  (unless (symbol? command)
    (raise-argument-error 'git "symbol?" command))
  (case command
    [(init) (apply git-init args)]
    [(clone) (apply git-clone args)]
    [(status) (apply git-status args)]
    [(diff) (apply git-diff args)]
    [(add) (apply git-add args)]
    [(config) (apply git-config args)]
    [(commit) (apply git-commit args)]
    [(branch)
     (match args
       [(list '-d name) (git-branch-delete name)]
       [_ (apply git-branch args)])]
    [(checkout)
     (match args
       [(list '-b name) (git-checkout-new name)]
       [_ (apply git-checkout args)])]
    [(tag)
     (match args
       [(list '-d name) (git-tag-delete name)]
       [_ (apply git-tag args)])]
    [(log) (apply git-log args)]
    [(remote)
     (match args
       ['() (git-remotes)]
       [(list 'add name url) (git-remote-add name url)]
       [(list 'get-url name) (git-remote-url name)]
       [_ (error 'git "invalid remote arguments: ~e" args)])]
    [(fetch) (apply git-fetch args)]
    [(pull) (apply git-pull args)]
    [(push) (apply git-push args)]
    [(push-tag) (apply git-push-tag args)]
    [(credentials)
     (match args
       [(list 'init password) (git-credentials-init! password)]
       [(list 'unlock password) (git-credentials-unlock! password)]
       [(list 'unlock password seconds)
        (git-credentials-unlock! password #:for seconds)]
       [(list 'lock) (git-credentials-lock!)]
       [(list 'unlocked?) (git-credentials-unlocked?)]
       [(list 'set remote username token)
        (git-credentials-set! remote username token)]
       [(list 'configured? remote) (git-credentials-configured? remote)]
       [(list 'remove remote) (git-credentials-remove! remote)]
       [_ (error 'git "invalid credentials arguments: ~e" args)])]
    [else (error 'git "unknown command: ~a" command)]))

(define (status-description entry)
  (define flags (git-status-entry-flags entry))
  (cond
    [(has-status? flags 'GIT_STATUS_CONFLICTED) "Conflicted"]
    [(has-status? flags 'GIT_STATUS_WT_NEW) "New"]
    [(or (has-status? flags 'GIT_STATUS_INDEX_RENAMED)
         (has-status? flags 'GIT_STATUS_WT_RENAMED)) "Renamed"]
    [(or (has-status? flags 'GIT_STATUS_INDEX_DELETED)
         (has-status? flags 'GIT_STATUS_WT_DELETED)) "Deleted"]
    [(has-status? flags 'GIT_STATUS_INDEX_NEW) "Added"]
    [(or (has-status? flags 'GIT_STATUS_INDEX_TYPECHANGE)
         (has-status? flags 'GIT_STATUS_WT_TYPECHANGE)) "Type changed"]
    [(or (has-status? flags 'GIT_STATUS_INDEX_MODIFIED)
         (has-status? flags 'GIT_STATUS_WT_MODIFIED)) "Modified"]
    [(has-status? flags 'GIT_STATUS_WT_UNREADABLE) "Unreadable"]
    [else (git-status-entry-code entry)]))

(define (pad-right value width)
  (define text (format "~a" value))
  (string-append text (make-string (max 0 (- width (string-length text))) #\space)))

(define (display-git-result command result [out (current-output-port)])
  (cond
    [(eq? command 'status)
     (for ([entry (in-list result)])
       (fprintf out "~a - ~a\n"
                (pad-right (status-description entry) 12)
                (git-status-entry-path entry)))]
    [(eq? command 'diff)
     (display result out)]
    [(eq? command 'log)
     (for ([entry (in-list result)])
       (fprintf out "~a ~a\n"
                (substring (git-log-entry-id entry) 0 7)
                (git-log-entry-summary entry)))]
    [(list? result)
     (for ([item (in-list result)])
       (displayln item out))]
    [(void? result) (void)]
    [else (displayln result out)]))

(define (dgit command . args)
  (define result (apply git command args))
  (display-git-result command result)
  result)