add Git store

2 files changed, 122 insertions, 13 deletions

diff --git a/app/Main.hs b/app/Main.hs
index 493a807..47f0280 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 
@@ -8,14 +9,17 @@ import Data.Aeson qualified as J
 import Data.Aeson.Key qualified as JK
 import Data.Aeson.KeyMap qualified as JM
 import Data.ByteString.Lazy.Char8 qualified as LB
-import Data.List (foldl')
+import Data.List (foldl', isSuffixOf)
 import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Set qualified as S
 import Data.String (IsString (fromString))
+import Data.Tagged (Tagged (Tagged))
 import Data.Text qualified as T
 import Debug.Trace (trace)
-import System.Directory (listDirectory, setCurrentDirectory)
-import System.FilePath (takeExtension, (</>))
+import Git
+import Store qualified as S
+import System.Directory (setCurrentDirectory)
+import System.FilePath ((</>))
 import Text.Megaparsec qualified as P
 import Text.Megaparsec.Char qualified as P
 import Text.Megaparsec.Char.Lexer qualified as P
@@ -121,20 +125,30 @@ instance IsString Query where
 
 query :: Query -> IO [J.Value]
 query (Select fs c js ws) = do
-  c' <- mapM (fmap (Record c) . decodeFile . (c </>)) =<< ls c
+  c' <-
+    mapM (fmap (Record c) . decodeFile . (c </>)) =<< ls c
   js' <-
     mapM
       ( \j ->
           case j of
             LeftJoin c ws ->
-              fmap (\j' -> LeftJoin (map (Record c) j') ws) . mapM (decodeFile . (c </>)) =<< ls c
+              fmap (\j' -> LeftJoin (map (Record c) j') ws) . mapM (decodeFile . (c </>))
+                =<< ls c
             RightJoin c ws ->
-              fmap (\j' -> RightJoin (map (Record c) j') ws) . mapM (decodeFile . (c </>)) =<< ls c
+              fmap (\j' -> RightJoin (map (Record c) j') ws) . mapM (decodeFile . (c </>))
+                =<< ls c
             FullJoin c ws ->
-              fmap (\j' -> FullJoin (map (Record c) j') ws) . mapM (decodeFile . (c </>)) =<< ls c
+              fmap (\j' -> FullJoin (map (Record c) j') ws) . mapM (decodeFile . (c </>))
+                =<< ls c
       )
       js
   pure $ map (select fs) $ where_ ws $ combine c' js'
+  where
+    ls c =
+      filter (not . (isSuffixOf "/"))
+        <$> S.withStore "." do
+          Just cid <- fmap Tagged <$> resolveReference "HEAD"
+          S.listDirectory cid c
 
 combine :: [Record J.Value] -> [Join [Record J.Value]] -> [[Record J.Value]]
 combine vs js = combine' (map (: []) vs) js
@@ -177,18 +191,15 @@ combine vs js = combine' (map (: []) vs) js
         )
         jss
 
-ls :: FilePath -> IO [FilePath]
-ls =
-  fmap (filter ((== ".json") . takeExtension)) . listDirectory
-
 data DecodeException = DecodeException
   deriving (Show)
 
 instance Exception DecodeException
 
 decodeFile :: J.FromJSON a => FilePath -> IO a
-decodeFile =
-  fmap (fromMaybe (throw DecodeException)) . J.decodeFileStrict
+decodeFile fp = S.withStore "." do
+  Just cid <- fmap Tagged <$> resolveReference "HEAD"
+  fromMaybe (throw DecodeException) . J.decode <$> S.readFile cid fp
 
 select :: FieldSelector -> [Record J.Value] -> J.Value
 select All vs =
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)