diff options
Diffstat (limited to 'app')
| -rw-r--r-- | app/Main.hs | 37 | ||||
| -rw-r--r-- | app/Store.hs | 98 |
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) |