#lang racket/base

(require racket/string
         net/url
         "git-provider.rkt"
         "utils.rkt")

(provide exn:fail:git-auth?
         exn:fail:git-auth-command
         exn:fail:git-auth-args
         exn:fail:git-auth-exit-code
         exn:fail:git-auth-output
         authentication-failure?
         raise-git-auth-error
         default-git-authentication-handler
         reject-git-authentication
         current-git-authentication-handler)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Authentication exception
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(struct exn:fail:git-auth exn:fail
  (command args exit-code output)
  #:transparent)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Read the first value of a Git configuration key.
; pre    : key is a Git configuration key.
; post   : Git config has been queried without displaying its output.
; result : The configured value, or #f when the key is absent.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (git-config-value key)
  (let-values (((exit-code output)
                (run-git (list 'config '--get key))))
    (if (= exit-code 0)
        (let ((stdout
               (map cadr
                    (filter (λ (entry) (eq? (car entry) 'stdout))
                            output))))
          (if (null? stdout) #f (car stdout)))
        #f)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Determine the remote name used by the current branch.
; pre    : The current directory is a Git working tree.
; post   : Git branch/config have only been queried.
; result : The configured remote name, or "origin" as fallback.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (git-current-remote)
  (let-values (((exit-code output)
                (run-git '(branch --show-current))))
    (if (= exit-code 0)
        (let ((stdout
               (map cadr
                    (filter (λ (entry) (eq? (car entry) 'stdout))
                            output))))
          (if (null? stdout)
              "origin"
              (let ((remote
                     (git-config-value
                      (format "branch.~a.remote" (car stdout)))))
                (if remote remote "origin"))))
        "origin")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Determine the remote URL relevant to the failed Git command.
; pre    : cmd and args belong to a failed authenticated Git command.
; post   : Git config has only been queried.
; result : An HTTP(S) remote URL, or #f when it cannot be determined.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (git-authentication-url cmd args)
  (let* ((remote (git-current-remote))
         (url (git-config-value (format "remote.~a.url" remote))))
    (if url
        url
        (git-config-value "remote.origin.url"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Convert an HTTP(S) remote URL to Git credential input.
; pre    : value is a URL string.
; post   : value has only been parsed.
; result : protocol, host and optional username, or #f values for unsupported URLs.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (url->credential-parts value)
  (with-handlers ((exn:fail? (λ (e) (values #f #f #f))))
    (let* ((u (string->url value))
           (protocol (url-scheme u))
           (host (url-host u))
           (user (url-user u)))
      (if (and (member protocol '("http" "https"))
               (string? host)
               (not (string=? host "")))
          (values protocol host user)
          (values #f #f #f)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Build Git credential protocol input.
; pre    : protocol and host are strings; username and password may be #f.
; post   : Arguments have only been formatted.
; result : A credential protocol string terminated by a blank line.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (credential-input protocol host username password)
  (string-append
   (format "protocol=~a\n" protocol)
   (format "host=~a\n" host)
   (if username (format "username=~a\n" username) "")
   (if password (format "password=~a\n" password) "")
   "\n"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Ask Git's configured credential helper for credentials.
; pre    : protocol and host identify the failed HTTP(S) remote.
; post   : The helper may have prompted or updated its own credential state.
; result : #t when git credential fill succeeded, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (git-credential-fill protocol host username)
  (let-values (((exit-code output)
                (run-git '(credential fill)
                         #:input (credential-input protocol host username #f))))
    (= exit-code 0)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Offer credentials to Git's configured credential helper.
; pre    : protocol, host, username and password describe a credential.
; post   : Git credential approve has been invoked.
; result : #t when Git accepted the approve operation, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (git-credential-approve protocol host username password)
  (let-values (((exit-code output)
                (run-git '(credential approve)
                         #:input (credential-input protocol host username password))))
    (= exit-code 0)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Reject credentials for an HTTP(S) remote through Git.
; pre    : protocol and host identify the credential; username may be #f.
; post   : Git credential reject has been invoked.
; result : #t when Git accepted the reject operation, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (git-credential-reject protocol host username)
  (let-values (((exit-code output)
                (run-git '(credential reject)
                         #:input (credential-input protocol host username #f))))
    (= exit-code 0)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Ensure a non-persistent credential helper exists for this repository.
; pre    : The current directory is inside a Git working tree.
; post   : credential.helper=cache is configured locally when no helper existed.
; result : #t when a helper exists or was configured, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (ensure-credential-helper)
  (let ((helper (git-config-value "credential.helper")))
    (if helper
        #t
        (let-values (((exit-code output)
                      (run-git '(config --local credential.helper cache))))
          (= exit-code 0)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Ask the user for credentials and approve them through Git.
; pre    : protocol and host identify an HTTP(S) remote.
; post   : Supplied credentials have been offered to Git's helper.
; result : #t when credentials were approved, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (ask-and-approve-credential protocol host username)
  (let* ((username*
          (if username
              username
              (input-prompt
               (format "Username for ~a: " host)
               #:loop-until
               (λ (value)
                 (cond
                   ((eof-object? value)
                    (error 'git-authentication "Input cancelled"))
                   ((string=? (string-trim value) "")
                    #f)
                   (else
                    (string-trim value)))))))
         (password
          (input-prompt
           (format "Password/token for ~a: " host)
           #:loop-until
           (λ (value)
             (cond
               ((eof-object? value)
                (error 'git-authentication "Input cancelled"))
               ((string=? value "")
                #f)
               (else
                value))))))
    (and (ensure-credential-helper)
         (git-credential-approve protocol host username* password))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Authentication handling
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Recognize output that indicates Git authentication failed.
; pre    : exit-code and output belong to a completed Git command.
; post   : output has only been inspected.
; result : #t when a known authentication failure is present, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define auth-recognizer
  #px"(authentication failed|failed to authenticate|could not read (username|password)|access denied|terminal prompts disabled|requested url returned error: (401|403))")

(define (authentication-failure? exit-code output)
  (and (not (= exit-code 0))
       (ormap
        (λ (entry)
          (let ((line (string-downcase (format "~a" (cadr entry)))))
            (regexp-match? auth-recognizer line)))
        output)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Raise a Git authentication exception containing the failed invocation.
; pre    : cmd, args, exit-code and output describe a failed Git command.
; post   : An exn:fail:git-auth exception has been raised.
; result : No normal return value.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (raise-git-auth-error cmd args exit-code output)
  (let ((msg (format "git ~a: authentication failed" cmd)))
    (raise
     (exn:fail:git-auth msg
                        (current-continuation-marks)
                        cmd
                        args
                        exit-code
                        output))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Reject the credential associated with a failed Git command.
; pre    : cmd and args identify a failed authenticated Git invocation.
; post   : Git's credential helper has been asked to forget the credential.
; result : #t when a credential could be identified and rejected, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (reject-git-authentication cmd args)
  (let ((url (git-authentication-url cmd args)))
    (if (not url)
        #f
        (let-values (((protocol host username)
                      (url->credential-parts url)))
          (if protocol
              (git-credential-reject protocol host username)
              #f)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Resolve an authentication failure using Git first, then input-prompt.
; pre    : cmd, args and e describe one failed Git invocation.
; post   : Git's helper has been tried; a missing helper may be configured locally.
; result : #t when retrying the original command is meaningful, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (default-git-authentication-handler cmd args e)
  (let ((url (git-authentication-url cmd args)))
    (if (not url)
        #f
        (let-values (((protocol host username)
                      (url->credential-parts url)))
          (if (not protocol)
              #f
              (let ((helper (git-config-value "credential.helper")))
                (when helper
                  (git-credential-reject protocol host username))
                (if (and helper
                         (git-credential-fill protocol host username))
                    #t
                    (ask-and-approve-credential
                     protocol host username))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Supply the callback that can resolve an authentication failure.
; pre    : The callback accepts command, arguments and an exn:fail:git-auth value.
; post   : The callback is used by command proxies before one authentication retry.
; result : A parameter containing the current authentication callback.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define current-git-authentication-handler
  (make-parameter default-git-authentication-handler))