add (simpler) `StoreT` type

1 files changed, 85 insertions, 56 deletions

diff --git a/app/Store.hs b/app/Store.hs
index 704a1cc..3e0f3d3 100644
--- a/app/Store.hs
+++ b/app/Store.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -11,50 +12,78 @@ module Store
 where
 
 import Control.Arrow (first)
-import Control.Monad.Catch
-import Control.Monad.IO.Unlift (MonadUnliftIO)
-import Control.Monad.Reader (ReaderT)
+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
-import Git.Libgit2 (LgRepo, lgFactory)
-import System.FilePath
+import Git qualified as G
+import Git.Libgit2 qualified as GB
+import System.FilePath (addTrailingPathSeparator, hasDrive, joinDrive, makeRelative, normalise, splitPath)
 import Prelude hiding (readFile)
 
-withStore ::
-  (MonadMask m, MonadUnliftIO m) =>
-  FilePath ->
-  ReaderT LgRepo m a ->
-  m a
-withStore = withRepository lgFactory
+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
+    )
 
-listDirectory ::
-  MonadGit r m =>
-  CommitOid r ->
-  FilePath ->
-  m [FilePath]
-listDirectory cid dir' = do
-  let dir = normalise $ if hasDrive dir' then dir' else joinDrive "/" dir'
-      n = length (splitPath dir)
-  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
+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)
@@ -67,32 +96,32 @@ data InappropriateType = InappropriateType String FilePath
 instance Exception InappropriateType
 
 class Readable a where
-  readFile :: MonadGit r m => CommitOid r -> FilePath -> m a
+  readFile :: FilePath -> StoreM a
 
 instance Readable T.Text where
-  readFile = readFile' catBlobUtf8
+  readFile = readFile' G.catBlobUtf8
 
 instance Readable B.ByteString where
-  readFile = readFile' catBlob
+  readFile = readFile' G.catBlob
 
 instance Readable LB.ByteString where
-  readFile = readFile' catBlobLazy
+  readFile = readFile' G.catBlobLazy
 
 readFile' ::
-  MonadGit r m =>
-  (BlobOid r -> m a) ->
-  CommitOid r ->
+  (G.BlobOid GB.LgRepo -> ReaderT GB.LgRepo IO a) ->
   FilePath ->
-  m a
-readFile' cat cid fp = do
-  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)
+  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)