More working commands

README.md

@@ -11,7 +11,8 @@ A small command-line-like Git module for Racket, implemented directly on top of
 (git 'add "main.rkt" "info.rkt")
 (git 'commit "Implement raco support")
 (git 'tag "v0.2")
-(git 'checkout "main")
+(git 'branch-current)
+(git 'switch "main")
 
 ;; Display-oriented variant:
 (dgit 'status)
@@ -20,7 +21,7 @@ A small command-line-like Git module for Racket, implemented directly on top of
 `git` is an ordinary procedure; command names are symbols. `dgit` performs the
 same operation, displays a compact human-readable result, and returns that result.
 
-The same operations are available as normal procedures such as `git-status`, `git-add`, `git-commit`, `git-tag`, and `git-checkout`.
+The same operations are available as normal procedures such as `git-status`, `git-add`, `git-commit`, `git-tag`, `git-current-branch`, `git-switch`, and `git-checkout`.
 
 ## HTTPS credentials
 
@@ -90,7 +91,7 @@ operations use them automatically:
 ## Supported Git operations
 
 Version 0.2 supports repository discovery, init, clone, status, add, config,
-commit, branch, checkout, lightweight tags, log, remotes, fetch,
+commit, branch, branch-current, switch, checkout, lightweight tags, log, remotes, fetch,
 fast-forward-only pull, push, tag push, network transfer progress, and HTTPS username/token credentials.
 
 SSH credentials, merge/rebase pull, annotated tags, and submodules are not yet
@@ -101,3 +102,17 @@ Install from the package directory with:
 ```sh
 raco pkg install .
 ```
+
+
+## Recover a detached HEAD commit
+
+```racket
+(git 'branch-current) ; #f
+(git 'branch-create "rescue-readme")
+(git 'switch "main")
+(git 'merge "rescue-readme")
+(git 'status)
+(dgit 'log 5)
+(git 'push)
+(git 'branch '-d "rescue-readme")
+```

info.rkt

@@ -2,7 +2,7 @@
 
 (define collection "git")
 (define pkg-desc "Command-line-like Git operations for Racket, implemented with libgit2")
-(define version "0.2.8")
+(define version "0.2.10")
 (define pkg-authors '("Hans Dijkema"))
 (define license 'MIT)
 

main.rkt

@@ -27,11 +27,14 @@
          git-commit
          git-head
          git-current-branch
+         git-switch
          git-branches
+         git-branch-create
          git-branch
          git-branch-delete
          git-checkout
          git-checkout-new
+         git-merge
          git-tags
          git-tag
          git-tag-delete
@@ -66,6 +69,7 @@
 (define GIT-CREDTYPE-USERNAME #x0020)
 (define GIT-PASSTHROUGH -30)
 (define GIT-CHECKOUT-OPTIONS-VERSION 1)
+(define GIT-MERGE-OPTIONS-VERSION 1)
 
 (define (git-credential-callback out url username-from-url allowed-types _payload)
   ;; Never let a Racket exception escape through a C callback.  In particular,
@@ -550,18 +554,23 @@
    #"")
   (sort branches string<?))
 
-(define (create-branch name)
+(define (git-branch-create name [start-point "HEAD"])
   (define repo (open-repository))
-  (define commit (head-commit repo))
+  (define object
-  (unless commit
+    (with-handlers ([exn:fail?
-    (error 'git-branch "cannot create a branch before the first commit"))
+                     (lambda (_)
+                       (error 'git-branch-create
+                              "cannot resolve start point: ~a"
+                              start-point))])
+      (git_revparse_single repo (format "~a^{commit}" start-point))))
+  (define commit (git_commit_lookup repo (git_object_id object)))
   (git_branch_create repo name commit #f)
   name)
 
 (define git-branch
   (case-lambda
     [() (git-branches)]
-    [(name) (create-branch name)]))
+    [(name) (git-branch-create name)]))
 
 (define (git-branch-delete name)
   (define repo (open-repository))
@@ -578,6 +587,12 @@
   (git_checkout_options_init options GIT-CHECKOUT-OPTIONS-VERSION)
   options)
 
+(define (make-merge-options)
+  (define options
+    (cast (malloc _git_merge_opts 'atomic) _pointer _git_merge_opts-pointer))
+  (git_merge_options_init options GIT-MERGE-OPTIONS-VERSION)
+  options)
+
 (define (git-checkout name)
   (define repo (open-repository))
   (define options (make-safe-checkout-options))
@@ -595,10 +610,65 @@
      (git_repository_set_head_detached repo (git_object_id object))])
   (git-head))
 
+(define (git-switch name)
+  (unless (member name (git-branches))
+    (error 'git-switch "no such local branch: ~a" name))
+  (git-checkout name))
+
 (define (git-checkout-new name)
   (git-branch name)
   (git-checkout name))
 
+(define (git-merge name [message #f])
+  (define repo (open-repository))
+  (define branch (git-current-branch))
+  (unless branch
+    (error 'git-merge "merge requires an attached local branch"))
+  (define ours (head-commit repo))
+  (unless ours
+    (error 'git-merge "cannot merge into a repository without commits"))
+  (define target-object
+    (with-handlers ([exn:fail?
+                     (lambda (_)
+                       (error 'git-merge "cannot resolve merge target: ~a" name))])
+      (git_revparse_single repo (format "~a^{commit}" name))))
+  (define theirs (git_commit_lookup repo (git_object_id target-object)))
+  (define ours-id (git_commit_id ours))
+  (define theirs-id (git_commit_id theirs))
+  (cond
+    ;; The target is already contained in HEAD.
+    [(or (git_oid_equal ours-id theirs-id)
+         (git_graph_descendant_of repo ours-id theirs-id))
+     #f]
+    ;; HEAD is an ancestor of the target: do a real fast-forward, including
+    ;; index and worktree, and keep HEAD attached to the current branch.
+    [(git_graph_descendant_of repo theirs-id ours-id)
+     (git_checkout_tree repo target-object (make-safe-checkout-options))
+     (define local-ref
+       (git_reference_lookup repo (string-append branch-prefix branch)))
+     (git_reference_set_target
+      local-ref theirs-id (format "merge ~a: fast-forward" name))
+     (git_oid_fmt theirs-id)]
+    [else
+     ;; Build the merge in an in-memory index first. Conflicts therefore leave
+     ;; HEAD, the worktree, and the repository index untouched.
+     (define merge-index (git_merge_commits repo ours theirs (make-merge-options)))
+     (when (git_index_has_conflicts merge-index)
+       (error 'git-merge "merge conflicts while merging ~a" name))
+     (define tree-id (blank-oid))
+     (git_index_write_tree_to tree-id merge-index repo)
+     (define tree (git_tree_lookup repo tree-id))
+     ;; Safe checkout refuses to overwrite uncommitted worktree changes.
+     (git_checkout_tree repo (cast tree _git_tree _git_object)
+                        (make-safe-checkout-options))
+     (define signature (git_signature_default repo))
+     (define commit-id (blank-oid))
+     (git_commit_create_v
+      commit-id repo "HEAD" signature signature #f
+      (or message (format "Merge branch '~a'" name))
+      tree 2 ours theirs)
+     (git_oid_fmt commit-id)]))
+
 (define (git-tags)
   (define tags null)
   (git_tag_foreach
@@ -833,10 +903,17 @@
     [(add) (apply git-add args)]
     [(config) (apply git-config args)]
     [(commit) (apply git-commit args)]
+    [(branch-current)
+     (unless (null? args)
+       (error 'git "branch-current takes no arguments"))
+     (git-current-branch)]
     [(branch)
      (match args
        [(list '-d name) (git-branch-delete name)]
        [_ (apply git-branch args)])]
+    [(branch-create) (apply git-branch-create args)]
+    [(switch) (apply git-switch args)]
+    [(merge) (apply git-merge args)]
     [(checkout)
      (match args
        [(list '-b name) (git-checkout-new name)]

scribblings/git.scrbl

@@ -73,22 +73,45 @@ Calls @racket[git], displays its result in a compact human-readable form, and re
 
 @section{Branches, checkout, and tags}
 
-@defproc[(git-current-branch) (or/c string? #f)]{Returns the current local branch name, or @racket[#f] for detached HEAD.}
+@defproc[(git-current-branch) (or/c string? #f)]{Returns the current local branch name, or @racket[#f] for detached HEAD. The command form is @racket[(git 'branch-current)].}
 
 @defproc*[([(git-branch) (listof string?)]
            [(git-branch [name string?]) string?])]{Lists local branches, or creates @racket[name] at HEAD.}
 
-@defproc[(git-branch-delete [name string?]) void?]{Deletes a local branch.}
+@defproc[(git-branch-create [name string?] [start-point string? "HEAD"]) string?]{Creates a local branch named @racket[name] at @racket[start-point] and returns @racket[name]. The default start point is the current HEAD, including detached HEAD. The command forms are @racket[(git 'branch-create name)] and @racket[(git 'branch-create name start-point)].}
+
+@defproc[(git-branch-delete [name string?]) void?]{Deletes a local branch. The command form is @racket[(git 'branch '-d name)].}
+
+@defproc[(git-switch [name string?]) (or/c string? #f)]{Switches to an existing local branch and attaches HEAD to that branch. The command form is @racket[(git 'switch name)]. An unknown local branch raises an exception.}
 
 @defproc[(git-checkout [name string?]) (or/c string? #f)]{Checks out a local branch, tag, or commit. A tag or commit produces detached HEAD.}
 
 @defproc[(git-checkout-new [name string?]) string?]{Creates and checks out a new branch.}
 
+@defproc[(git-merge [name string?] [message (or/c string? #f) #f]) (or/c string? #f)]{Merges @racket[name] into the currently attached local branch. An up-to-date merge returns @racket[#f]. A fast-forward returns the new HEAD OID. A clean non-fast-forward merge creates a two-parent merge commit and returns its OID. If @racket[message] is @racket[#f], the merge commit message is @tt{Merge branch 'name'}. Conflicting merges raise an exception before changing HEAD or the worktree. The command forms are @racket[(git 'merge name)] and @racket[(git 'merge name message)].}
+
 @defproc*[([(git-tag) (listof string?)]
            [(git-tag [name string?]) string?])]{Lists tags, or creates a lightweight tag at HEAD and returns its OID.}
 
 @defproc[(git-tag-delete [name string?]) void?]{Deletes a tag.}
 
+@subsection{Recovering a commit made with detached HEAD}
+
+A commit made while HEAD is detached is not attached to a local branch. The following sequence gives the commit a temporary branch name, switches back to @tt{main}, merges the rescued commit, verifies the result, pushes it, and removes the temporary branch:
+
+@racketblock[
+(git 'branch-current) ; => #f
+(git 'branch-create "rescue-readme")
+(git 'switch "main")
+(git 'merge "rescue-readme")
+(git 'status)
+(dgit 'log 5)
+(git 'push)
+(git 'branch '-d "rescue-readme")
+]
+
+The @racket[(dgit 'log 5)] form is the compact Racket equivalent of using a short command-line log for verification: it displays the abbreviated commit OID and summary for the five newest commits.
+
 @section{Log}
 
 @defstruct*[git-log-entry ([id string?] [summary string?] [time integer?])]{Describes one commit returned by @racket[git-log].}
@@ -126,8 +149,12 @@ The following command-like forms are supported directly:
 (git 'add "file.rkt")
 (git 'config "user.name" "Name")
 (git 'commit "message")
+(git 'branch-current)
 (git 'branch)
 (git 'branch "feature")
+(git 'branch-create "rescue" "HEAD")
+(git 'switch "feature")
+(git 'merge "rescue")
 (git 'branch '-d "feature")
 (git 'checkout "main")
 (git 'checkout '-b "feature")

tests/basic.rkt

@@ -14,6 +14,7 @@
       (git 'init)
       (check-true (git-repository?))
       (check-equal? (git-current-branch) "master")
+      (check-equal? (git 'branch-current) "master")
       (check-true (git-clean?))
 
       (git 'config "user.name" "Racket Git Test")
@@ -83,7 +84,8 @@
       (git 'commit "work change")
       (check-equal? (file->string (build-path "sub" "hello.txt")) "work\n")
 
-      (git 'checkout "master")
+      (check-equal? (git 'branch-current) "work")
+      (git 'switch "master")
       (check-equal? (file->string (build-path "sub" "hello.txt")) "changed\n")
       (check-equal? (git-current-branch) "master")
       (check-not-false (member "work" (git 'branch)))
@@ -92,7 +94,7 @@
       (call-with-output-file (build-path "sub" "hello.txt")
         #:exists 'truncate/replace
         (lambda (out) (displayln "dirty" out)))
-      (check-exn exn:fail? (lambda () (git 'checkout "work")))
+      (check-exn exn:fail? (lambda () (git 'switch "work")))
       (check-equal? (git-current-branch) "master")
       (check-equal? (file->string (build-path "sub" "hello.txt")) "dirty\n")
       (call-with-output-file (build-path "sub" "hello.txt")
@@ -107,7 +109,10 @@
       (check-equal? (git 'tag) '("v0.1"))
       (git 'checkout "v0.1")
       (check-false (git-current-branch))
-      (git 'checkout "master")
+      (check-false (git 'branch-current))
+      (check-exn exn:fail? (lambda () (git 'switch "missing")))
+      (git 'switch "master")
+      (check-equal? (git 'branch-current) "master")
       (git 'tag '-d "v0.1")
       (check-equal? (git 'tag) '())
 

tests/branch-merge.rkt

@@ -0,0 +1,66 @@
+#lang racket/base
+
+(require rackunit
+         racket/file
+         git)
+
+(define tmp (make-temporary-file "racket-git-branch-merge-test~a" 'directory))
+
+(define (write-file path text)
+  (call-with-output-file path
+    #:exists 'truncate/replace
+    (lambda (out) (display text out))))
+
+(dynamic-wind
+  void
+  (lambda ()
+    (parameterize ([current-directory tmp])
+      (git 'init)
+      (git 'config "user.name" "Racket Git Test")
+      (git 'config "user.email" "racket-git-test@example.invalid")
+
+      (write-file "README.md" "base\n")
+      (git 'add "README.md")
+      (define base (git 'commit "base"))
+
+      ;; Reproduce the recovery case: create a commit while HEAD is detached,
+      ;; give that commit a branch name, switch back, and merge it.
+      (git 'checkout base)
+      (check-false (git 'branch-current))
+      (write-file "README.md" "base\nrescued\n")
+      (git 'add "README.md")
+      (define rescued (git 'commit "detached README change"))
+      (check-false (git 'branch-current))
+
+      (check-equal? (git 'branch-create "rescue-readme") "rescue-readme")
+      (check-not-false (member "rescue-readme" (git 'branch)))
+      (git 'switch "master")
+      (check-equal? (git 'branch-current) "master")
+      (check-equal? (git 'merge "rescue-readme") rescued)
+      (check-equal? (git-head) rescued)
+      (check-equal? (file->string "README.md") "base\nrescued\n")
+      (check-false (git 'merge "rescue-readme"))
+      (git 'branch '-d "rescue-readme")
+      (check-false (member "rescue-readme" (git 'branch)))
+
+      ;; Also exercise a real two-parent, conflict-free merge.
+      (git 'branch-create "feature")
+      (git 'switch "feature")
+      (write-file "feature.txt" "feature\n")
+      (git 'add "feature.txt")
+      (git 'commit "feature change")
+
+      (git 'switch "master")
+      (write-file "master.txt" "master\n")
+      (git 'add "master.txt")
+      (git 'commit "master change")
+      (define merge-id (git 'merge "feature"))
+      (check-equal? (string-length merge-id) 40)
+      (check-equal? (file->string "feature.txt") "feature\n")
+      (check-equal? (file->string "master.txt") "master\n")
+      (check-true (git-clean?))
+      (check-equal? (git 'branch-current) "master")
+      (check-true (>= (length (git 'log 10)) 5))
+      (git 'branch '-d "feature")))
+  (lambda ()
+    (delete-directory/files tmp)))