chore: Git -> Backend

1 files changed, 162 insertions, 0 deletions

diff --git a/app/Backend.hs b/app/Backend.hs
new file mode 100644
index 0000000..b07eca6
--- /dev/null
+++ b/app/Backend.hs
@@ -0,0 +1,162 @@
+module Backend
+  ( module Backend.CommitHash,
+    getCommitHashes,
+    getRootDir,
+    getFilesOf,
+    getChangedFilesOf,
+    Commit (..),
+    Author (..),
+    getCommitOf,
+    readTextFileOfText,
+    readTextFileOfBS,
+    resolveRef,
+    getCommitsBetween,
+    diffOf,
+  )
+where
+
+import Backend.CommitHash
+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.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 Exception qualified as E
+import GHC.Generics (Generic)
+import Patch qualified as A
+import Process (proc, sh, sh_)
+import Text.Printf (printf)
+
+getCommitHashes :: Maybe CommitHash -> Maybe CommitHash -> IO [CommitHash]
+getCommitHashes maybeBottomCommit Nothing =
+  getCommitHashes maybeBottomCommit (Just WorkingTree)
+getCommitHashes (Just WorkingTree) (Just WorkingTree) =
+  pure [WorkingTree]
+getCommitHashes (Just WorkingTree) (Just (Commit _)) =
+  pure []
+getCommitHashes Nothing (Just WorkingTree) =
+  (WorkingTree :) . map Commit . T.lines
+    <$> sh (proc "git log --format=%%H HEAD")
+getCommitHashes (Just (Commit bottomHash)) (Just WorkingTree) =
+  (WorkingTree :) . map Commit . T.lines
+    <$> sh (proc "git log --format=%%H %..HEAD" bottomHash)
+getCommitHashes Nothing (Just (Commit topHash)) =
+  map Commit . T.lines
+    <$> sh (proc "git log --format=%%H %" topHash)
+getCommitHashes (Just (Commit bottomHash)) (Just (Commit topHash)) =
+  map Commit . T.lines
+    <$> sh (proc "git log --format=%%H %..%" bottomHash topHash)
+
+getRootDir :: IO FilePath
+getRootDir =
+  T.unpack . stripTrailingNL
+    <$> sh (proc "git rev-parse --show-toplevel")
+  where
+    stripTrailingNL s = fromMaybe s $ T.stripSuffix "\n" s
+
+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)
+
+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)
+
+data Commit = Commit'
+  { commitHash :: CommitHash,
+    date :: UTCTime,
+    author :: Author
+  }
+  deriving (Show, Generic, Binary, Eq)
+
+data Author = Author
+  { name :: T.Text,
+    email :: T.Text
+  }
+  deriving (Show, Generic, Binary, Eq)
+
+getCommitOf :: CommitHash -> IO Commit
+getCommitOf commitHash@WorkingTree = do
+  date <- getCurrentTime
+  authorName <- sh "git config user.name"
+  authorEmail <- sh "git config user.email"
+  pure
+    Commit'
+      { author = Author authorName authorEmail,
+        ..
+      }
+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
+
+readTextFileOfText :: CommitHash -> FilePath -> IO LT.Text
+readTextFileOfText = readTextFileOf LT.readFile LT.decodeUtf8
+
+readTextFileOfBS :: CommitHash -> FilePath -> IO LB.ByteString
+readTextFileOfBS = readTextFileOf LB.readFile id
+
+readTextFileOf :: (FilePath -> IO a) -> (LB.ByteString -> a) -> CommitHash -> FilePath -> IO a
+readTextFileOf readFile _ WorkingTree filePath =
+  catch
+    (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)))
+
+resolveRef :: T.Text -> IO CommitHash
+resolveRef =
+  fmap (Commit . T.strip . T.decodeUtf8 . LB.toStrict)
+    . sh
+    . proc "git rev-parse %"
+
+-- | `getCommitsBetween prevCommit commit` returns the commits from `prevCommit` to `commit`. The result excludes `prevCommit`, but includes `commit`.
+--
+-- If `prevCommit` is  not an ancestor of `commit`, this functions throws `NoAncestor commit prevCommit`.
+getCommitsBetween :: CommitHash -> CommitHash -> IO [CommitHash]
+getCommitsBetween WorkingTree commit@(Commit _) =
+  throwIO (E.NoAncestor WorkingTree commit)
+getCommitsBetween WorkingTree WorkingTree = pure [WorkingTree]
+getCommitsBetween prevCommit WorkingTree =
+  fmap (++ [WorkingTree]) . getCommitsBetween prevCommit
+    =<< resolveRef "HEAD"
+getCommitsBetween prevCommit@(Commit prevHash) commit@(Commit hash) = do
+  catch
+    (sh_ (proc "git merge-base --is-ancestor % %" prevHash hash))
+    (\(_ :: E.ProcessException) -> throwIO (E.NoAncestor commit prevCommit))
+  map (Commit . T.strip) . T.lines . T.decodeUtf8 . LB.toStrict
+    <$> sh (proc "git log --format=%%H %..%" prevHash hash)
+
+diffOf :: CommitHash -> CommitHash -> IO A.Patch
+diffOf prevHash hash =
+  A.parse . T.decodeUtf8 . LB.toStrict
+    <$> sh (proc "git diff % %" (toTextUnsafe prevHash) (toTextUnsafe hash))