feat: direct Git access

1 files changed, 115 insertions, 34 deletions

diff --git a/app/Backend.hs b/app/Backend.hs
index b07eca6..0a61ce3 100644
--- a/app/Backend.hs
+++ b/app/Backend.hs
@@ -1,6 +1,7 @@
 module Backend
   ( module Backend.CommitHash,
     getCommitHashes,
+    getParentCommitHashOf,
     getRootDir,
     getFilesOf,
     getChangedFilesOf,
@@ -20,17 +21,24 @@ import Control.Exception (IOException, catch, throwIO)
 import Data.Binary (Binary)
 import Data.Binary.Instances ()
 import Data.ByteString.Lazy qualified as LB
-import Data.Maybe (fromMaybe)
+import Data.ByteString.UTF8 qualified as B
+import Data.List (sort)
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Tagged
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as T
 import Data.Text.Lazy qualified as LT
 import Data.Text.Lazy.Encoding qualified as LT
 import Data.Text.Lazy.IO qualified as LT
 import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Time.LocalTime (zonedTimeToUTC)
 import Exception qualified as E
 import GHC.Generics (Generic)
+import Git qualified as Git
+import Git.Libgit2 (LgRepo, lgFactory)
 import Patch qualified as A
 import Process (proc, sh, sh_)
+import Safe (headMay)
 import Text.Printf (printf)
 
 getCommitHashes :: Maybe CommitHash -> Maybe CommitHash -> IO [CommitHash]
@@ -41,17 +49,27 @@ getCommitHashes (Just WorkingTree) (Just WorkingTree) =
 getCommitHashes (Just WorkingTree) (Just (Commit _)) =
   pure []
 getCommitHashes Nothing (Just WorkingTree) =
-  (WorkingTree :) . map Commit . T.lines
-    <$> sh (proc "git log --format=%%H HEAD")
+  (WorkingTree :) . map (Commit . Git.renderOid . untag) . reverse
+    <$> Git.withRepository lgFactory "." do
+      Just head <- Git.resolveReference "HEAD"
+      Git.listCommits Nothing (Tagged head)
 getCommitHashes (Just (Commit bottomHash)) (Just WorkingTree) =
-  (WorkingTree :) . map Commit . T.lines
-    <$> sh (proc "git log --format=%%H %..HEAD" bottomHash)
+  (WorkingTree :) . map (Commit . Git.renderOid . untag) . reverse
+    <$> Git.withRepository lgFactory "." do
+      Just headRef <- Git.resolveReference "HEAD"
+      bottomRef <- Git.parseOid bottomHash
+      Git.listCommits (Just (Tagged bottomRef)) (Tagged headRef)
 getCommitHashes Nothing (Just (Commit topHash)) =
-  map Commit . T.lines
-    <$> sh (proc "git log --format=%%H %" topHash)
+  (WorkingTree :) . map (Commit . Git.renderOid . untag) . reverse
+    <$> Git.withRepository lgFactory "." do
+      topRef <- Git.parseOid topHash
+      Git.listCommits Nothing (Tagged topRef)
 getCommitHashes (Just (Commit bottomHash)) (Just (Commit topHash)) =
-  map Commit . T.lines
-    <$> sh (proc "git log --format=%%H %..%" bottomHash topHash)
+  (WorkingTree :) . map (Commit . Git.renderOid . untag) . reverse
+    <$> Git.withRepository lgFactory "." do
+      topRef <- Git.parseOid topHash
+      bottomRef <- Git.parseOid bottomHash
+      Git.listCommits (Just (Tagged bottomRef)) (Tagged topRef)
 
 getRootDir :: IO FilePath
 getRootDir =
@@ -64,17 +82,74 @@ getFilesOf :: CommitHash -> IO [FilePath]
 getFilesOf WorkingTree =
   map T.unpack . T.lines
     <$> sh "git ls-files --cached --modified --others --exclude-standard --full-name"
-getFilesOf (Commit hash) =
-  map T.unpack . T.lines
-    <$> sh (proc "git ls-tree -r --name-only --full-name --full-tree %" hash)
+getFilesOf (Commit commit) =
+  map snd <$> getFilesWithOidOf commit
 
 getChangedFilesOf :: CommitHash -> IO [FilePath]
 getChangedFilesOf WorkingTree =
   map T.unpack . T.lines
     <$> sh "git ls-files --modified --others --exclude-standard --full-name"
-getChangedFilesOf (Commit hash) = do
-  map T.unpack . T.lines
-    <$> sh (proc "git diff-tree -r --name-only %" hash)
+getChangedFilesOf (Commit commit) = do
+  maybeParentCommit <- getParentCommitHashOf (Commit commit)
+  case maybeParentCommit of
+    Nothing -> getFilesOf (Commit commit)
+    Just parentCommit -> do
+      files <- getFilesWithOidOf commit
+      parentFiles <- getFilesWithOidOf parentCommit
+      let addedFiles =
+            map snd
+              . filter
+                ( \(_, filePath) ->
+                    all
+                      (\(_, filePath') -> filePath /= filePath')
+                      parentFiles
+                )
+              $ files
+          deletedFiles =
+            map snd
+              . filter
+                ( \(_, filePath) ->
+                    all
+                      (\(_, filePath') -> filePath /= filePath')
+                      files
+                )
+              $ parentFiles
+          changedFiles =
+            [ snd file
+              | file <- files,
+                parentFile <- parentFiles,
+                snd file == snd parentFile,
+                fst file /= fst parentFile
+            ]
+      pure $ sort $ addedFiles ++ deletedFiles ++ changedFiles
+
+getParentCommitHashOf :: CommitHash -> IO (Maybe T.Text)
+getParentCommitHashOf commitHash =
+  fmap Git.renderOid
+    <$> case commitHash of
+      WorkingTree -> Git.withRepository lgFactory "." do
+        Git.resolveReference "HEAD"
+      Commit hash -> Git.withRepository lgFactory "." do
+        hashRef <- Git.parseOid hash
+        commit <- Git.lookupCommit (Tagged hashRef)
+        pure (untag <$> (headMay (Git.commitParents commit)))
+
+getFilesWithOidOf :: T.Text -> IO [(Git.BlobOid LgRepo, FilePath)]
+getFilesWithOidOf hash = do
+  mapMaybe
+    ( \(filePath, treeEntry) ->
+        case treeEntry of
+          Git.BlobEntry {Git.blobEntryOid, Git.blobEntryKind = Git.PlainBlob} ->
+            Just (blobEntryOid, B.toString filePath)
+          _ ->
+            Nothing
+    )
+    <$> ( Git.withRepository lgFactory "." $ do
+            head <- Git.parseOid hash
+            commit <- Git.lookupCommit (Tagged head)
+            tree <- Git.lookupTree (Git.commitTree commit)
+            Git.listTreeEntries tree
+        )
 
 data Commit = Commit'
   { commitHash :: CommitHash,
@@ -100,22 +175,17 @@ getCommitOf commitHash@WorkingTree = do
         ..
       }
 getCommitOf commitHash@(Commit hash) = do
-  ( T.splitOn "\NUL" . head . T.lines
-      <$> sh
-        ( proc
-            "git show --quiet --format=%%ai%%x00%%ae%%x00%%an %"
-            hash
-        )
-    )
-    >>= \case
-      rawDate : authorEmail : authorName : _ ->
-        let date = read (T.unpack rawDate)
-         in pure
-              Commit'
-                { author = Author authorName authorEmail,
-                  ..
-                }
-      _ -> throwIO E.NoCommits
+  Git.withRepository lgFactory "." $ do
+    head <- Git.parseOid hash
+    commit <- Git.lookupCommit (Tagged head)
+    let authorName = Git.signatureName (Git.commitAuthor commit)
+        authorEmail = Git.signatureEmail (Git.commitAuthor commit)
+        date = zonedTimeToUTC (Git.signatureWhen (Git.commitAuthor commit))
+    pure
+      Commit'
+        { author = Author authorName authorEmail,
+          ..
+        }
 
 readTextFileOfText :: CommitHash -> FilePath -> IO LT.Text
 readTextFileOfText = readTextFileOf LT.readFile LT.decodeUtf8
@@ -129,9 +199,20 @@ readTextFileOf readFile _ WorkingTree filePath =
     (readFile filePath)
     (\(_ :: IOException) -> throwIO (E.CannotReadFile filePath))
 readTextFileOf _ decode (Commit hash) filePath =
-  catch
-    (decode <$> sh (proc "git show %:%" hash filePath))
-    (\(_ :: E.ProcessException) -> throwIO (E.CannotReadFile (printf "%s:%s" hash filePath)))
+  maybe
+    (throwIO (E.CannotReadFile (printf "%s:%s" hash filePath)))
+    (pure . decode)
+    =<< Git.withRepository lgFactory "." do
+      hashRef <- Git.parseOid hash
+      commit <- Git.lookupCommit (Tagged hashRef)
+      Git.commitTreeEntry commit (B.fromString filePath) >>= \case
+        Just
+          ( Git.BlobEntry
+              { Git.blobEntryOid,
+                Git.blobEntryKind = Git.PlainBlob
+              }
+            ) -> Just <$> Git.catBlobLazy blobEntryOid
+        _ -> pure Nothing
 
 resolveRef :: T.Text -> IO CommitHash
 resolveRef =