git-cli/credentials.rkt

#lang racket/base

(require crypto
         crypto/all
         net/base64
         racket/file
         racket/string
         simple-ini)

(provide git-credentials-store
         git-credentials-unlock-store
         current-git-credentials-store
         current-git-credentials-unlock-store
         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!)

(define git-credentials-store 'racket-git)
(define git-credentials-unlock-store 'racket-git-unlock)

;; Parameters make the storage location overridable for tests or embedded use,
;; while the public default remains the normal Racket preference stores.
(define current-git-credentials-store (make-parameter git-credentials-store))
(define current-git-credentials-unlock-store (make-parameter git-credentials-unlock-store))

(define settings-section 'settings)
(define unlock-section 'unlock)
(define kdf-iterations 200000)
(define cipher '(aes gcm))
(define check-text #"racket-git credential store")

(define-syntax-rule (with-git-crypto body ...)
  (parameterize ([crypto-factories all-factories])
    body ...))

(define (b64-encode bytes)
  (bytes->string/utf-8 (base64-encode bytes #"")))

(define (b64-decode string)
  (base64-decode (string->bytes/utf-8 string)))

(define (store-read name)
  (file->ini name))

(define (store-write name ini)
  (make-directory* (find-system-path 'pref-dir))
  (ini->file ini name #:private? #t)
  (void))

(define (store-set! name section key value)
  (define ini (store-read name))
  (ini-set! ini section key value)
  (store-write name ini))

(define (store-get name section key [default #f])
  (ini-get (store-read name) section key default))

(define (derive-key password salt)
  (with-git-crypto
    (pbkdf2-hmac 'sha256
                 (string->bytes/utf-8 password)
                 salt
                 #:iterations kdf-iterations
                 #:key-size 32)))

(define (encrypt-value key plaintext aad)
  (with-git-crypto
    (define iv (generate-cipher-iv cipher))
    (define encrypted
      (encrypt cipher key iv (string->bytes/utf-8 plaintext)
               #:aad (string->bytes/utf-8 aad)))
    (string-append (b64-encode iv) ":" (b64-encode encrypted))))

(define (decrypt-value key encoded aad)
  (with-git-crypto
    (define parts (string-split encoded ":"))
    (unless (= (length parts) 2)
      (error 'git-credentials "invalid encrypted credential data"))
    (bytes->string/utf-8
     (decrypt cipher key
              (b64-decode (car parts))
              (b64-decode (cadr parts))
              #:aad (string->bytes/utf-8 aad)))))

(define (credential-key remote)
  (define url-match
    (regexp-match #px"^[A-Za-z][A-Za-z0-9+.-]*://(?:[^/@]+@)?([^/:]+)" remote))
  (define ssh-match
    (regexp-match #px"^[^@]+@([^:]+):" remote))
  (string-downcase
   (cond
     [url-match (cadr url-match)]
     [ssh-match (cadr ssh-match)]
     [else remote])))

(define (string->hex string)
  (apply string-append
         (for/list ([b (in-bytes (string->bytes/utf-8 string))])
           (let ([h (number->string b 16)])
             (if (= (string-length h) 1) (string-append "0" h) h)))))

(define (credential-section remote)
  ;; simple-ini deliberately accepts a conservative section-name syntax.
  ;; Hex keeps arbitrary host names reversible and section-safe.
  (string->symbol (string-append "credential."
                                 (string->hex (credential-key remote)))))

(define (git-credentials-init! password #:unlock-for [seconds 86400])
  (unless (and (string? password) (positive? (string-length password)))
    (raise-argument-error 'git-credentials-init! "non-empty string?" password))
  (define existing-salt (store-get (current-git-credentials-store) settings-section 'salt #f))
  (when existing-salt
    (error 'git-credentials-init! "credential store is already initialized"))
  (define salt (with-git-crypto (crypto-random-bytes 16)))
  (define key (derive-key password salt))
  (define ini (store-read (current-git-credentials-store)))
  (ini-set! ini settings-section 'version 1)
  (ini-set! ini settings-section 'kdf "pbkdf2-hmac-sha256")
  (ini-set! ini settings-section 'iterations kdf-iterations)
  (ini-set! ini settings-section 'salt (b64-encode salt))
  (ini-set! ini settings-section 'check
            (encrypt-value key (bytes->string/utf-8 check-text) "check"))
  (store-write (current-git-credentials-store) ini)
  (cache-unlock-key! key seconds)
  (void))

(define (cache-unlock-key! key seconds)
  (unless (and (real? seconds) (> seconds 0))
    (raise-argument-error 'git-credentials-unlock! "positive real?" seconds))
  (define ini (store-read (current-git-credentials-unlock-store)))
  (ini-set! ini unlock-section 'key (b64-encode key))
  (ini-set! ini unlock-section 'expires (+ (current-seconds) seconds))
  (store-write (current-git-credentials-unlock-store) ini)
  (void))

(define (git-credentials-unlock! password #:for [seconds 86400])
  (define salt-text (store-get (current-git-credentials-store) settings-section 'salt #f))
  (define check (store-get (current-git-credentials-store) settings-section 'check #f))
  (unless (and salt-text check)
    (error 'git-credentials-unlock! "credential store is not initialized"))
  (define key (derive-key password (b64-decode salt-text)))
  (with-handlers ([exn:fail?
                   (lambda (_)
                     (error 'git-credentials-unlock! "invalid password"))])
    (unless (string=? (decrypt-value key check "check")
                      (bytes->string/utf-8 check-text))
      (error 'git-credentials-unlock! "invalid password")))
  (cache-unlock-key! key seconds)
  (void))

(define (git-credentials-lock!)
  (define ini (store-read (current-git-credentials-unlock-store)))
  (ini-set! ini unlock-section 'key "")
  (ini-set! ini unlock-section 'expires 0)
  (store-write (current-git-credentials-unlock-store) ini)
  (void))

(define (git-credentials-unlock-expires)
  (define expires (store-get (current-git-credentials-unlock-store) unlock-section 'expires 0))
  (if (number? expires) expires 0))

(define (git-credentials-unlocked?)
  (define key (store-get (current-git-credentials-unlock-store) unlock-section 'key ""))
  (define expires (git-credentials-unlock-expires))
  (cond
    [(and (string? key)
          (not (string=? key ""))
          (> expires (current-seconds)))
     #t]
    [else
     (when (and (number? expires) (positive? expires))
       (git-credentials-lock!))
     #f]))

(define (current-key who)
  (unless (git-credentials-unlocked?)
    (error who "credential store 'racket-git is locked"))
  (b64-decode
   (store-get (current-git-credentials-unlock-store) unlock-section 'key "")))

(define (git-credentials-set! remote username token)
  (unless (string? remote)
    (raise-argument-error 'git-credentials-set! "string?" remote))
  (unless (string? username)
    (raise-argument-error 'git-credentials-set! "string?" username))
  (unless (string? token)
    (raise-argument-error 'git-credentials-set! "string?" token))
  (define key (current-key 'git-credentials-set!))
  (define section (credential-section remote))
  (define ini (store-read (current-git-credentials-store)))
  (ini-set! ini section 'username username)
  (ini-set! ini section 'token
            (encrypt-value key token (string-append (credential-key remote) ":" username)))
  (store-write (current-git-credentials-store) ini)
  (void))

(define (git-credentials-configured? remote)
  (define section (credential-section remote))
  (define username (store-get (current-git-credentials-store) section 'username #f))
  (define encrypted (store-get (current-git-credentials-store) section 'token #f))
  (and (string? username) (not (string=? username ""))
       (string? encrypted) (not (string=? encrypted ""))))

(define (git-credentials-ref remote)
  (define section (credential-section remote))
  (define username (store-get (current-git-credentials-store) section 'username #f))
  (define encrypted (store-get (current-git-credentials-store) section 'token #f))
  (cond
    [(and (string? username) (not (string=? username ""))
          (string? encrypted) (not (string=? encrypted "")))
     (define key (current-key 'git-credentials-ref))
     (cons username
           (decrypt-value key encrypted (string-append (credential-key remote) ":" username)))]
    [else #f]))

(define (git-credentials-remove! remote)
  ;; simple-ini has no section-delete primitive.  Clearing both values keeps
  ;; the file format simple and makes git-credentials-ref return #f.
  (define section (credential-section remote))
  (define ini (store-read (current-git-credentials-store)))
  (ini-set! ini section 'username "")
  (ini-set! ini section 'token "")
  (store-write (current-git-credentials-store) ini)
  (void))