Initial import

credentials.rkt

@@ -0,0 +1,222 @@
+#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-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-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))