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
|
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
module Store
( withStore,
listDirectory,
readFile,
)
where
import Control.Arrow (first)
import Control.Exception (Exception, finally)
import Control.Monad.Catch (MonadCatch, MonadThrow, throwM)
import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT)
import Control.Monad.State (MonadState, StateT, evalStateT, get)
import Control.Monad.Trans (MonadIO, MonadTrans, lift)
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 qualified as G
import Git.Libgit2 qualified as GB
import System.FilePath (addTrailingPathSeparator, hasDrive, joinDrive, makeRelative, normalise, splitPath)
import Prelude hiding (readFile)
newtype StoreT m a = StoreT
{ runStoreT :: StateT GB.OidPtr (ReaderT GB.LgRepo m) a
}
deriving
( Applicative,
Functor,
Monad,
MonadReader GB.LgRepo,
MonadState GB.OidPtr,
MonadCatch,
MonadThrow,
MonadIO
)
instance MonadTrans StoreT where
lift = StoreT . lift . lift
class MonadStore m where
getCommitOid :: m (G.CommitOid GB.LgRepo)
getRepository :: m GB.LgRepo
instance Monad m => MonadStore (StoreT m) where
getCommitOid = Tagged <$> get
getRepository = ask
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}
Just cid <- G.runRepository GB.lgFactory repo (G.resolveReference ref)
runReaderT (evalStateT (runStoreT action) cid) repo
`finally` G.runRepository GB.lgFactory repo G.closeRepository
listDirectory :: FilePath -> StoreM [FilePath]
listDirectory dir' = do
cid <- getCommitOid
repo <- getRepository
lift $ G.runRepository GB.lgFactory repo $ do
let dir = normalise $ if hasDrive dir' then dir' else joinDrive "/" dir'
n = length (splitPath dir)
tree <- G.lookupTree =<< (.commitTree) <$> G.lookupCommit cid
sort
. map (makeRelative dir)
. filter ((== n + 1) . length . splitPath)
. filter (isPrefixOf (addTrailingPathSeparator dir))
. map fst
. map
( \e ->
case snd e of
G.BlobEntry _ _ -> e
G.CommitEntry _ -> error "XXX commit entry"
G.TreeEntry _ -> first addTrailingPathSeparator e
)
. map (first (("/" <>) . B.toString))
<$> G.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 :: 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
readFile' ::
(G.BlobOid GB.LgRepo -> ReaderT GB.LgRepo IO a) ->
FilePath ->
StoreM a
readFile' cat fp = do
cid <- getCommitOid
repo <- getRepository
lift $ G.runRepository GB.lgFactory repo do
tree <- G.lookupTree =<< (.commitTree) <$> G.lookupCommit cid
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)
|
