Added credentials

main.rkt

@@ -6,10 +6,7 @@
          racket/path
          racket/string
          "credentials.rkt"
-         (except-in libgit2 git_remote_push)
-         (only-in libgit2/private/base
-                  define-libgit2
-                  _git_error_code/check))
+         libgit2)
 
 (provide git
          dgit
@@ -21,6 +18,7 @@
          git-status
          git-status-lines
          git-clean?
+         git-diff
          git-add
          git-config
          git-config-get
@@ -53,25 +51,12 @@
          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)
 
-;; The current Racket libgit2 package has an incorrect Scheme -> C
-;; conversion for git_strarray pointers.  Keep this tiny corrected binding
-;; local to this module for push refspecs.
-(define-cstruct _git_strarray/raw
-  ([strings _pointer]
-   [count _size]))
-
-(define-libgit2 git_remote_push/raw
-  (_fun _git_remote
-        _git_strarray/raw-pointer
-        _git_push_opts-pointer
-        -> (_git_error_code/check))
-  #:c-id git_remote_push)
-
 (define zero-oid-string (make-string GIT_OID_HEXSZ #\0))
 (define branch-prefix "refs/heads/")
 (define tag-prefix "refs/tags/")
@@ -81,25 +66,31 @@
 (define GIT-PASSTHROUGH -30)
 
 (define (git-credential-callback out url username-from-url allowed-types _payload)
-  (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)))
-        (ptr-set! out _git_credential
-                  (git_credential_username_new username))
-        0]
-       [else GIT-PASSTHROUGH])]))
+  ;; 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)
@@ -238,6 +229,35 @@
 (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) "/"))
 
@@ -323,14 +343,13 @@
 
   (define signature (git_signature_default repo))
   (define commit-id (blank-oid))
-  (define result
-    (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)))
-  (unless (zero? result)
-    (error 'git-commit "libgit2 git_commit_create_v failed with code ~a" result))
+  (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)
@@ -486,7 +505,21 @@
   (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))
@@ -520,16 +553,42 @@
      (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 remote (git_remote_lookup repo remote-name))
   (define options (make-push-options))
-  (define strings
-    (cast (list refspec) (_list i _string interior) _gcpointer))
-  (define refspecs (make-git_strarray/raw strings 1))
-  (git_remote_push/raw remote refspecs options)
-  ;; Keep the C string-pointer array alive through the foreign call.
-  (void strings)
+  ;; 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
@@ -564,6 +623,7 @@
     [(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)]
@@ -600,6 +660,7 @@
        [(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)]))
@@ -632,6 +693,8 @@
        (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"