add Git store

1 files changed, 98 insertions, 0 deletions

diff --git a/app/Store.hs b/app/Store.hs
new file mode 100644
index 0000000..704a1cc
--- /dev/null
+++ b/app/Store.hs
@@ -0,0 +1,98 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Store
+  ( withStore,
+    listDirectory,
+    readFile,
+  )
+where
+
+import Control.Arrow (first)
+import Control.Monad.Catch
+import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Control.Monad.Reader (ReaderT)
+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.Text qualified as T
+import Git
+import Git.Libgit2 (LgRepo, lgFactory)
+import System.FilePath
+import Prelude hiding (readFile)
+
+withStore ::
+  (MonadMask m, MonadUnliftIO m) =>
+  FilePath ->
+  ReaderT LgRepo m a ->
+  m a
+withStore = withRepository lgFactory
+
+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
+
+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 :: MonadGit r m => CommitOid r -> 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' ::
+  MonadGit r m =>
+  (BlobOid r -> m a) ->
+  CommitOid r ->
+  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)