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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
module Repo (
Repo(..), Commit(..),
CommitId, showCommitId,
TreeId, showTreeId,
openRepo,
listCommits,
checkoutAt,
readTreeId,
readCommittedFile,
) 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.ByteString.Lazy qualified as BL
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
, commitTreeId :: MVar (Maybe TreeId)
}
newtype CommitId = CommitId ByteString
deriving (Eq, Ord)
showCommitId :: CommitId -> String
showCommitId (CommitId cid) = BC.unpack cid
newtype TreeId = TreeId ByteString
deriving (Eq, Ord)
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
commitTreeId <- newMVar Nothing
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 $ do
modifyMVar commitTreeId $ \case
Just tid -> do
return ( Just tid, tid )
Nothing -> do
withMVar gitLock $ \_ -> do
[ "tree", stid ] : _ <- map words . lines <$> readProcess "git" [ "--git-dir=" <> gitDir, "cat-file", "commit", showCommitId commitId ] ""
let tid = TreeId $ BC.pack stid
return ( Just tid, tid )
readCommittedFile :: Commit -> FilePath -> IO (Maybe BL.ByteString)
readCommittedFile Commit {..} path = do
let GitRepo {..} = commitRepo
liftIO $ withMVar gitLock $ \_ -> do
let cmd = (proc "git" [ "--git-dir=" <> gitDir, "cat-file", "blob", showCommitId commitId <> ":" <> path ])
{ std_in = NoStream
, std_out = CreatePipe
}
createProcess cmd >>= \( _, mbstdout, _, ph ) -> if
| Just stdout <- mbstdout -> do
content <- BL.hGetContents stdout
-- check if there will be some output:
case BL.uncons content of
Just (c, _) -> c `seq` return ()
Nothing -> return ()
getProcessExitCode ph >>= \case
Just code | code /= ExitSuccess ->
return Nothing
_ ->
return (Just content)
| otherwise -> error "createProcess must return stdout handle"
|