1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
|
module Repo (
Repo(..), Commit(..),
CommitId, showCommitId,
TreeId, showTreeId,
openRepo,
listCommits,
checkoutAt,
readTreeId,
) where
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as BC
import Data.Text (Text)
import Data.Text qualified as T
import System.Directory
import System.Exit
import System.FilePath
import System.Process
data Repo
= GitRepo
{ gitDir :: FilePath
, gitLock :: MVar ()
}
data Commit = Commit
{ commitRepo :: Repo
, commitId :: CommitId
, commitDescription :: Text
}
newtype CommitId = CommitId ByteString
showCommitId :: CommitId -> String
showCommitId (CommitId cid) = BC.unpack cid
newtype TreeId = TreeId ByteString
showTreeId :: TreeId -> String
showTreeId (TreeId tid) = BC.unpack tid
openRepo :: FilePath -> IO (Maybe Repo)
openRepo path = do
findGitDir >>= \case
Just gitDir -> do
gitLock <- newMVar ()
return $ Just GitRepo {..}
Nothing -> do
return Nothing
where
tryGitDir gpath = readProcessWithExitCode "git" [ "rev-parse", "--resolve-git-dir", gpath ] "" >>= \case
( ExitSuccess, out, _ ) | dir : _ <- lines out -> return (Just dir)
_ -> return Nothing
findGitDir = do
tryGitDir path >>= \case
Just dir -> return (Just dir)
Nothing -> tryGitDir (path </> ".git") >>= \case
Just dir -> return (Just dir)
_ -> return Nothing
listCommits :: MonadIO m => Repo -> String -> m [ Commit ]
listCommits commitRepo range = liftIO $ do
out <- readProcess "git" [ "log", "--pretty=oneline", "--first-parent", "--reverse", range ] ""
forM (lines out) $ \line -> do
let ( cid, desc ) = fmap (drop 1) $ (span (/=' ')) line
commitId = CommitId (BC.pack cid)
commitDescription = T.pack desc
return Commit {..}
checkoutAt :: (MonadIO m, MonadFail m) => Commit -> FilePath -> m ()
checkoutAt Commit {..} dest = do
let GitRepo {..} = commitRepo
liftIO $ withMVar gitLock $ \_ -> do
"" <- readProcess "git" [ "clone", "--quiet", "--shared", "--no-checkout", gitDir, dest ] ""
"" <- readProcess "git" [ "-C", dest, "restore", "--worktree", "--source=" <> showCommitId commitId, "--", "." ] ""
removeDirectoryRecursive $ dest </> ".git"
readTreeId :: (MonadIO m, MonadFail m) => Commit -> m TreeId
readTreeId Commit {..} = do
let GitRepo {..} = commitRepo
liftIO $ withMVar gitLock $ \_ -> do
[ "tree", tid ] : _ <- map words . lines <$> readProcess "git" [ "--git-dir=" <> gitDir, "cat-file", "commit", showCommitId commitId ] ""
return $ TreeId $ BC.pack tid
|