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
|
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Store
( StoreT (..),
withStore,
listDirectory,
readFile,
)
where
import Control.Arrow (first)
import Control.Exception (Exception)
import Control.Monad.Catch (MonadCatch (catch), MonadMask (generalBracket, mask, uninterruptibleMask), MonadThrow, throwM)
import Control.Monad.IO.Unlift (MonadUnliftIO (withRunInIO))
import Control.Monad.Reader (ReaderT)
import Control.Monad.State (MonadState (state), StateT (StateT), evalStateT, get)
import Control.Monad.Trans (MonadIO, lift, liftIO)
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))
import Data.Text qualified as T
import Git
import Git.Libgit2 (HasLgRepo (getRepository), LgRepo, OidPtr, lgFactory)
import Git.Libgit2 qualified as GB
import System.FilePath
import Prelude hiding (readFile)
data StoreT m a = StoreT
{ unStoreT :: StateT OidPtr m a
}
-- XXX `DeriveAnyClass` does not work for `StoreT`
--
-- The instances generated by `DeriveAnyClass` are empty..
instance (Monad m, Applicative m) => Applicative (StoreT m) where
pure = StoreT . pure
f <*> x = StoreT $ unStoreT f <*> unStoreT x
instance Functor m => Functor (StoreT m) where
fmap f = StoreT . fmap f . unStoreT
instance Monad m => Monad (StoreT m) where
m >>= k = StoreT $ unStoreT m >>= unStoreT . k
instance MonadThrow m => MonadThrow (StoreT m) where
throwM = StoreT . throwM
instance MonadCatch m => MonadCatch (StoreT m) where
m `catch` h = StoreT $ unStoreT m `catch` (unStoreT . h)
instance MonadIO m => MonadIO (StoreT m) where
liftIO = StoreT . liftIO
instance Monad m => MonadState OidPtr (StoreT m) where
state = StoreT . state
instance MonadMask m => MonadMask (StoreT m) where
mask f = StoreT $ mask (\g -> unStoreT (f (\m -> (StoreT (g (unStoreT m))))))
uninterruptibleMask f = StoreT $ uninterruptibleMask (\g -> unStoreT (f (\m -> (StoreT (g (unStoreT m))))))
generalBracket m n k = StoreT (generalBracket (unStoreT m) ((unStoreT .) . n) (unStoreT . k))
instance MonadUnliftIO m => MonadUnliftIO (StateT s m) where
withRunInIO f =
StateT $ \s ->
(,s) <$> withRunInIO (\g -> f (\m -> g (evalStateT m s)))
instance MonadUnliftIO m => MonadUnliftIO (StoreT m) where
withRunInIO f =
StoreT (withRunInIO (\g -> f (\m -> g (unStoreT m))))
instance (HasLgRepo m, Monad m) => HasLgRepo (StoreT m) where
getRepository = StoreT $ lift GB.getRepository
withStore ::
(MonadUnliftIO m, MonadMask m, MonadFail m) =>
FilePath ->
RefName ->
StoreT (ReaderT LgRepo m) a ->
m a
withStore fp ref act = withRepository lgFactory fp do
Just cid <- resolveReference ref
evalStateT (unStoreT act) cid
listDirectory ::
( MonadState OidPtr m,
MonadMask m,
MonadUnliftIO m,
HasLgRepo m
) =>
FilePath ->
m [FilePath]
listDirectory dir' = do
let dir = normalise $ if hasDrive dir' then dir' else joinDrive "/" dir'
n = length (splitPath dir)
cid <- Tagged <$> get
tid <- (.commitTree) <$> lookupCommit cid
tree <- lookupTree tid
sort
. map (makeRelative dir)
. filter ((== n + 1) . length . splitPath)
. filter (isPrefixOf (addTrailingPathSeparator dir))
. map fst
. map
( \e ->
case snd e of
BlobEntry _ _ -> e
CommitEntry _ -> error "XXX commit entry"
TreeEntry _ -> first addTrailingPathSeparator e
)
. map (first (("/" <>) . B.toString))
<$> listTreeEntries tree
data DoesNotExist = DoesNotExist String FilePath
deriving (Show)
instance Exception DoesNotExist
data InappropriateType = InappropriateType String FilePath
deriving (Show)
instance Exception InappropriateType
class Readable a where
readFile ::
( MonadState OidPtr m,
MonadMask m,
MonadUnliftIO m,
HasLgRepo m
) =>
FilePath ->
m a
instance Readable T.Text where
readFile = readFile' catBlobUtf8
instance Readable B.ByteString where
readFile = readFile' catBlob
instance Readable LB.ByteString where
readFile = readFile' catBlobLazy
readFile' ::
( MonadState OidPtr m,
MonadMask m,
MonadUnliftIO m,
HasLgRepo m
) =>
(Tagged LgRepo OidPtr -> m b) ->
FilePath ->
m b
readFile' cat fp = do
cid <- Tagged <$> get
tid <- (.commitTree) <$> lookupCommit cid
tree <- lookupTree tid
maybe
(throwM (DoesNotExist "readFile" fp))
( \e ->
case e of
BlobEntry bid _ -> cat bid
CommitEntry _ -> error "XXX commit entry"
TreeEntry _ -> throwM (InappropriateType "readFile" fp)
)
=<< treeEntry tree (B.fromString fp)
|
