diff options
Diffstat (limited to 'app')
| -rw-r--r-- | app/Backend.hs | 149 |
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 = |