aboutsummaryrefslogtreecommitdiffstats
path: root/app/Store.hs
diff options
context:
space:
mode:
Diffstat (limited to 'app/Store.hs')
-rw-r--r--app/Store.hs121
1 files changed, 0 insertions, 121 deletions
diff --git a/app/Store.hs b/app/Store.hs
deleted file mode 100644
index 3a899b6..0000000
--- a/app/Store.hs
+++ /dev/null
@@ -1,121 +0,0 @@
-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)