From 950eea3ba04e94cf3d5797f9b5d32b2621c89b55 Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
Date: Tue, 13 Feb 2024 02:07:20 +0100
Subject: refactor library

---
 src/Store/Store.hs | 121 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 121 insertions(+)
 create mode 100644 src/Store/Store.hs

(limited to 'src/Store/Store.hs')

diff --git a/src/Store/Store.hs b/src/Store/Store.hs
new file mode 100644
index 0000000..7917449
--- /dev/null
+++ b/src/Store/Store.hs
@@ -0,0 +1,121 @@
+module Store.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)
-- 
cgit v1.2.3