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
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
|
module Store.Store
( StoreM,
withStore,
withCommit,
listFiles,
readFile,
writeFile,
deleteFile,
commit,
)
where
import Bindings.Libgit2 qualified as B
import Control.Arrow (first)
import Control.Exception (Exception, finally, throw)
import Control.Monad (when)
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, throwM)
import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT)
import Control.Monad.State (MonadState, StateT, evalStateT, get, modify)
import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO)
import Control.Monad.Trans.Resource (MonadResource, runResourceT)
import Data.Aeson qualified as J
import Data.ByteString qualified as B
import Data.ByteString.Lazy qualified as LB
import Data.ByteString.UTF8 qualified as B
import Data.List (isPrefixOf, sort)
import Data.Tagged (Tagged (Tagged), untag)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Time (getCurrentTimeZone, utcToZonedTime)
import Data.Time.Clock (getCurrentTime)
import Foreign
import Git qualified as G
import Git.Libgit2 qualified as GB
import System.FilePath (makeRelative, normalise, (</>))
import Text.Printf (printf)
import Prelude hiding (readFile, writeFile)
newtype StoreT m a = StoreT
{ runStoreT :: StateT State (ReaderT Env m) a
}
deriving
( Applicative,
Functor,
Monad,
MonadReader Env,
MonadState State,
MonadCatch,
MonadThrow,
MonadIO,
MonadMask,
MonadResource
)
data Env = Env
{ repo :: GB.LgRepo,
ref :: G.RefName
}
data State = State
{ cid :: G.CommitOid GB.LgRepo,
tid :: G.TreeOid GB.LgRepo
}
instance MonadTrans StoreT where
lift = StoreT . lift . lift
type StoreM = StoreT IO
withStore :: FilePath -> G.RefName -> StoreM a -> IO a
withStore repoPath ref action = do
repo <- G.openRepository GB.lgFactory G.defaultRepositoryOptions {G.repoPath}
(cid, tid) <- G.runRepository GB.lgFactory repo do
Just cid <- fmap Tagged <$> G.resolveReference ref
tid <- (.commitTree) <$> G.lookupCommit cid
pure (cid, tid)
runReaderT
(evalStateT (runStoreT action) (State {cid, tid}))
(Env {repo, ref})
`finally` G.runRepository GB.lgFactory repo G.closeRepository
withCommit :: G.CommitOid GB.LgRepo -> StoreM a -> StoreM a
withCommit cid action = do
Env {repo, ref} <- ask
liftIO do
tid <- G.runRepository GB.lgFactory repo do
(.commitTree) <$> G.lookupCommit cid
runReaderT
(evalStateT (runStoreT action) (State {cid, tid}))
(Env {repo, ref})
listFiles :: FilePath -> StoreM [FilePath]
listFiles (normalise . ("/" </>) -> fp) = do
State {tid} <- get
map (makeRelative fp)
. filter (fp `isPrefixOf`)
. map ("/" </>)
<$> listTree tid
where
listTree :: G.TreeOid GB.LgRepo -> StoreM [FilePath]
listTree tid = do
Env {repo} <- ask
fmap sort . lift $ G.runRepository GB.lgFactory repo $ do
listTree' repo tid
listTree' repo tid =
fmap concat
. mapM
( \(fp, e) ->
case e of
G.BlobEntry _ _ -> pure [fp]
G.CommitEntry _ -> error "XXX commit entry"
G.TreeEntry tid' -> pure []
)
. map (first B.toString)
=<< G.listTreeEntries
=<< G.lookupTree tid
data DoesNotExist = DoesNotExist String FilePath
deriving (Show)
instance Exception DoesNotExist
data InappropriateType = InappropriateType String FilePath
deriving (Show)
instance Exception InappropriateType
data DecodeException = DecodeException String
deriving (Show)
instance Exception DecodeException
class Readable a where
readFile :: FilePath -> StoreM a
instance Readable T.Text where
readFile = readFile' G.catBlobUtf8
instance Readable B.ByteString where
readFile = readFile' G.catBlob
instance Readable LB.ByteString where
readFile = readFile' G.catBlobLazy
instance Readable J.Value where
readFile = fmap (either (throw . DecodeException) id . J.eitherDecode) . readFile
readFile' ::
(G.BlobOid GB.LgRepo -> ReaderT GB.LgRepo IO a) ->
FilePath ->
StoreM a
readFile' cat (makeRelative "/" -> fp) = do
State {tid} <- get
Env {repo} <- ask
lift $ G.runRepository GB.lgFactory repo do
tree <- G.lookupTree tid
maybe
(throwM (DoesNotExist "readFile" fp))
( \e ->
case e of
G.BlobEntry bid _ -> cat bid
G.CommitEntry _ -> error "XXX commit entry"
G.TreeEntry _ -> throwM (InappropriateType "readFile" fp)
)
=<< G.treeEntry tree (B.fromString fp)
writeFile :: FilePath -> LB.ByteString -> StoreM ()
writeFile (B.fromString . makeRelative "/" -> fp) v = do
State {tid} <- get
Env {repo} <- ask
tid' <- lift $ G.runRepository GB.lgFactory repo do
bid <- G.createBlobUtf8 (T.decodeUtf8 (LB.toStrict v))
G.mutateTreeOid tid do
G.putBlob fp bid
modify $ \s -> s {tid = tid'}
deleteFile :: FilePath -> StoreM ()
deleteFile (B.fromString . makeRelative "/" -> fp) = do
State {tid} <- get
Env {repo} <- ask
tid' <- lift $ G.runRepository GB.lgFactory repo do
G.mutateTreeOid tid do
G.dropEntry fp
G.currentTreeOid
modify $ \s -> s {tid = tid'}
commit :: StoreM ()
commit = do
State {cid, tid} <- get
Env {repo, ref} <- ask
now <- lift (utcToZonedTime <$> getCurrentTimeZone <*> getCurrentTime)
let sig = G.Signature "author" "email" now
cid' <-
lift $ runResourceT $ G.runRepository GB.lgFactory repo do
cid' <-
G.commitOid
<$> G.createCommit [cid] tid sig sig "auto-commit" (Just ref)
cidHead <- G.resolveReference "HEAD"
cidRef <- G.resolveReference ref
when (cidRef == cidHead) $ reset cid'
pure cid'
modify $ \s -> s {cid = cid'}
reset :: (MonadIO m) => GB.CommitOid -> ReaderT GB.LgRepo m ()
reset cid = do
repo <- GB.getRepository
liftIO $ withForeignPtr (GB.repoObj repo) $ \repoPtr -> do
withForeignPtr (GB.getOid (untag cid)) $ \oidPtr -> do
alloca $ \cidPtr' -> do
exitCode <- B.c'git_object_lookup cidPtr' repoPtr oidPtr B.c'GIT_OBJ_COMMIT
when (exitCode /= 0) do
error (printf "unknown commit %s (%d)" (show cid) (fromIntegral exitCode :: Int))
cidPtr <- peek cidPtr'
exitCode <- B.c'git_reset repoPtr cidPtr B.c'GIT_RESET_HARD
when (exitCode /= 0) do
error (printf "reset failed (%d)" (fromIntegral exitCode :: Int))
|
