aboutsummaryrefslogtreecommitdiffstats
path: root/src/Store
diff options
context:
space:
mode:
Diffstat (limited to 'src/Store')
-rw-r--r--src/Store/Debug.hs10
-rw-r--r--src/Store/Exception.hs23
-rw-r--r--src/Store/Query.hs134
-rw-r--r--src/Store/Query/Field.hs32
-rw-r--r--src/Store/Query/Parser.hs126
-rw-r--r--src/Store/Query/Printer.hs60
-rw-r--r--src/Store/Query/Record.hs80
-rw-r--r--src/Store/Query/Type.hs62
-rw-r--r--src/Store/Store.hs121
9 files changed, 648 insertions, 0 deletions
diff --git a/src/Store/Debug.hs b/src/Store/Debug.hs
new file mode 100644
index 0000000..5e0b704
--- /dev/null
+++ b/src/Store/Debug.hs
@@ -0,0 +1,10 @@
+module Store.Debug
+ ( debug,
+ )
+where
+
+import Debug.Trace (trace)
+import Text.Printf (printf)
+
+debug :: Show a => String -> a -> a
+debug s x = trace (printf "%s: %s" s (show x)) x
diff --git a/src/Store/Exception.hs b/src/Store/Exception.hs
new file mode 100644
index 0000000..245780c
--- /dev/null
+++ b/src/Store/Exception.hs
@@ -0,0 +1,23 @@
+module Store.Exception
+ ( DecodeException (DecodeException),
+ DuplicateField (DuplicateField),
+ ParseError (ParseError),
+ )
+where
+
+import Control.Exception (Exception)
+
+data DecodeException = DecodeException
+ deriving (Show)
+
+instance Exception DecodeException
+
+data DuplicateField = DuplicateField String
+ deriving (Show)
+
+instance Exception DuplicateField
+
+data ParseError = ParseError String
+ deriving (Show)
+
+instance Exception ParseError
diff --git a/src/Store/Query.hs b/src/Store/Query.hs
new file mode 100644
index 0000000..b63b176
--- /dev/null
+++ b/src/Store/Query.hs
@@ -0,0 +1,134 @@
+module Store.Query
+ ( module Store.Query.Type,
+ query,
+ )
+where
+
+import Control.Exception (throw)
+import Data.Aeson qualified as J
+import Data.Aeson.Key qualified as JK
+import Data.Aeson.KeyMap qualified as JM
+import Data.List (foldl', isSuffixOf)
+import Data.List.NonEmpty qualified as N
+import Data.Maybe (fromMaybe)
+import Data.Vector qualified as V
+import Store.Exception (DecodeException (DecodeException))
+import Store.Query.Parser ()
+import Store.Query.Printer ()
+import Store.Query.Record
+import Store.Query.Type
+import Store.Store qualified as S
+import System.FilePath ((</>))
+
+query :: Query -> IO [J.Value]
+query (Select fs c js es w) = do
+ c' <-
+ mapM (fmap (fromValue c) . decodeFile . (c </>)) =<< ls c
+ js' <-
+ mapM
+ ( \(JoinClause t c w) ->
+ fmap (\j' -> JoinClause t (map (fromValue c) j') w) . mapM (decodeFile . (c </>))
+ =<< ls c
+ )
+ js
+ es' <-
+ mapM
+ ( \(EmbedClause c w) ->
+ fmap (\e' -> EmbedClause (fromValue c e') w) . mapM (decodeFile . (c </>))
+ =<< ls c
+ )
+ es
+ pure $ map (Store.Query.select fs) $ where_ w $ embeds es' $ joins js' c'
+ where
+ ls c =
+ filter (not . (isSuffixOf "/"))
+ <$> S.withStore "." "HEAD" do
+ S.listDirectory c
+
+embeds ::
+ EmbedClauses (Record [J.Value]) ->
+ [Records J.Value] ->
+ [Records J.Value]
+embeds = flip (foldl' embed)
+
+embed ::
+ [Records J.Value] ->
+ EmbedClause (Record [J.Value]) ->
+ [Records J.Value]
+embed vss (EmbedClause (Record c es) w) =
+ map
+ ( \vs ->
+ vs
+ ++ [ fromValue
+ c
+ ( J.Object
+ ( JM.singleton
+ (JK.fromString c)
+ ( J.Array
+ ( V.fromList
+ [ e
+ | e <- es,
+ satisfies w (vs ++ [Record c e])
+ ]
+ )
+ )
+ )
+ )
+ ]
+ )
+ vss
+
+joins ::
+ JoinClauses (Records J.Value) ->
+ [Record J.Value] ->
+ [Records J.Value]
+joins js (map (: []) -> vss) = foldl' join vss js
+
+join ::
+ [Records J.Value] ->
+ JoinClause (Records J.Value) ->
+ [Records J.Value]
+join vss (JoinClause JoinLeft js w) =
+ concatMap
+ ( \vs -> case filter (satisfies w) $ map (\j -> vs ++ [j]) js of
+ [] -> [vs]
+ vs' -> vs'
+ )
+ vss
+join vss (JoinClause JoinRight js w) =
+ concatMap
+ ( \j -> case filter (satisfies w) $ map (\vs -> vs ++ [j]) vss of
+ [] -> [[j]]
+ vs' -> vs'
+ )
+ js
+join vss (JoinClause JoinFull js w) =
+ concatMap
+ ( \vs -> case filter (satisfies w) $ map (\j -> vs ++ [j]) js of
+ [] -> [vs]
+ vs' -> vs'
+ )
+ vss
+ ++ concatMap
+ ( \j -> case filter (satisfies w) $ map (\vs -> vs ++ [j]) vss of
+ [] -> [[j]]
+ _ -> []
+ )
+ js
+
+select :: FieldSelector -> Records J.Value -> J.Value
+select All vs = disjointUnions (map toValue vs)
+select (Only fs) vs = Store.Query.Record.select (N.toList fs) vs
+
+where_ :: Maybe WhereClause -> [Records J.Value] -> [Records J.Value]
+where_ w = filter (satisfies w)
+
+satisfies :: Maybe WhereClause -> Records J.Value -> Bool
+satisfies Nothing _ = True
+satisfies (Just (And ws)) vs = all (\w -> satisfies (Just w) vs) ws
+satisfies (Just (Or ws)) vs = any (\w -> satisfies (Just w) vs) ws
+satisfies (Just (Where (Eq f g))) vs = lookups f vs == lookups g vs
+
+decodeFile :: J.FromJSON a => Collection -> IO a
+decodeFile fp = S.withStore "." "HEAD" do
+ fromMaybe (throw DecodeException) . J.decode <$> S.readFile fp
diff --git a/src/Store/Query/Field.hs b/src/Store/Query/Field.hs
new file mode 100644
index 0000000..69a0983
--- /dev/null
+++ b/src/Store/Query/Field.hs
@@ -0,0 +1,32 @@
+module Store.Query.Field
+ ( Field (..),
+ toString,
+ prefix,
+ )
+where
+
+import Data.Aeson qualified as J
+import Data.Aeson.Key qualified as JK
+import Data.Aeson.KeyMap qualified as JM
+import Data.List (intercalate)
+import Data.List.NonEmpty qualified as N
+import Data.Text qualified as T
+
+data Field
+ = Qualified Collection (N.NonEmpty T.Text)
+ | Unqualified (N.NonEmpty T.Text)
+ deriving (Show)
+
+toString :: Field -> String
+toString (Qualified c ks) = intercalate "." (c : map T.unpack (N.toList ks))
+toString (Unqualified ks) = intercalate "." (map T.unpack (N.toList ks))
+
+type Collection = FilePath
+
+prefix :: Field -> J.Value -> J.Value
+prefix (Qualified c ks) = prefix' (T.pack c : N.toList ks)
+prefix (Unqualified ks) = prefix' (N.toList ks)
+
+prefix' :: [T.Text] -> J.Value -> J.Value
+prefix' ks v =
+ foldr ((J.Object .) . JM.singleton) v (map JK.fromText ks)
diff --git a/src/Store/Query/Parser.hs b/src/Store/Query/Parser.hs
new file mode 100644
index 0000000..93e408c
--- /dev/null
+++ b/src/Store/Query/Parser.hs
@@ -0,0 +1,126 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Store.Query.Parser () where
+
+import Control.Exception (throw)
+import Control.Monad (void)
+import Control.Monad.Combinators.NonEmpty qualified as PN
+import Data.Char (isSpace)
+import Data.List.NonEmpty qualified as N
+import Data.String (IsString (fromString))
+import Data.Text qualified as T
+import Data.Void (Void)
+import Store.Exception (ParseError (ParseError))
+import Store.Query.Type
+import Text.Megaparsec qualified as P
+import Text.Megaparsec.Char qualified as P
+import Text.Megaparsec.Char.Lexer qualified as P
+
+instance IsString Query where
+ fromString =
+ either (throw . ParseError . P.errorBundlePretty @String @Void) id
+ . P.parse parser ""
+ where
+ parser = do
+ void $ P.many P.space1
+ select
+ fs <- fieldSelector
+ from
+ c <- collection
+ js <- joinClauses
+ es <- embedClauses
+ w <- P.optional do
+ where_
+ whereClause
+ P.eof
+ pure $ Select fs c js es w
+
+ lexeme :: P.Parsec Void String a -> P.Parsec Void String a
+ lexeme = P.lexeme $ void $ P.takeWhileP Nothing isSpace
+
+ and = void $ lexeme (P.string "AND")
+ comma = void $ lexeme (P.string ",")
+ embed = void $ lexeme (P.string "EMBED")
+ eq = void $ lexeme (P.string "==")
+ from = void $ lexeme (P.string "FROM")
+ on = void $ lexeme (P.string "ON")
+ or = void $ lexeme (P.string "OR")
+ select = void $ lexeme (P.string "SELECT")
+ where_ = void $ lexeme (P.string "WHERE")
+
+ collection = lexeme $ P.takeWhile1P (Just "collection") (not . isSpace)
+
+ joinClauses = P.many joinClause
+
+ joinClause = do
+ t <- joinType
+ c <- collection
+ w <- P.optional do
+ on
+ whereClause
+ pure $ JoinClause t c w
+
+ embedClauses = P.many embedClause
+
+ embedClause = do
+ embed
+ c <- collection
+ w <- P.optional do
+ on
+ whereClause
+ pure $ EmbedClause c w
+
+ whereClause =
+ P.choice
+ [ P.try (And . map Where <$> P.sepBy1 comparison and),
+ P.try (Or . map Where <$> P.sepBy1 comparison or),
+ Where <$> comparison
+ ]
+
+ comparison = do
+ a <- field
+ eq
+ b <- field
+ pure $ Eq a b
+
+ fieldSelector =
+ P.choice
+ [ do
+ void $ lexeme $ P.string "*"
+ pure All,
+ do
+ Only <$> PN.sepBy1 field comma
+ ]
+
+ field :: P.Parsec Void String Field
+ field =
+ lexeme . P.choice $
+ [ P.try
+ do
+ Qualified
+ <$> (fieldPart <* P.string ".")
+ <*> (N.map T.pack <$> PN.sepBy1 fieldPart (P.string ".")),
+ do
+ Unqualified
+ <$> (N.map T.pack <$> PN.sepBy1 fieldPart (P.string "."))
+ ]
+
+ fieldPart :: P.Parsec Void String String
+ fieldPart = P.takeWhile1P Nothing (\c -> not (isSpace c) && c /= ',' && c /= '.')
+
+ joinType :: P.Parsec Void String JoinType
+ joinType =
+ P.choice
+ [ do
+ void $ lexeme (P.string "LEFT")
+ void $ lexeme (P.string "JOIN")
+ pure JoinLeft,
+ do
+ void $ lexeme (P.string "RIGHT")
+ void $ lexeme (P.string "JOIN")
+ pure JoinRight,
+ do
+ void $ lexeme (P.string "FULL")
+ void $ lexeme (P.string "JOIN")
+ pure JoinFull
+ ]
diff --git a/src/Store/Query/Printer.hs b/src/Store/Query/Printer.hs
new file mode 100644
index 0000000..5692ba8
--- /dev/null
+++ b/src/Store/Query/Printer.hs
@@ -0,0 +1,60 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Store.Query.Printer () where
+
+import Data.List (intercalate)
+import Data.List.NonEmpty qualified as N
+import Data.Maybe (catMaybes, mapMaybe)
+import Store.Query.Field
+import Store.Query.Type
+
+instance Show Query where
+ show (Select fs c js es w) =
+ intercalate " " $
+ catMaybes $
+ [ Just "SELECT",
+ Just (showFieldSelector fs),
+ Just "FROM",
+ Just (showCollection c),
+ showJoinClauses js,
+ showEmbedClauses es,
+ showWhereClause w
+ ]
+ where
+ showFieldSelector All = "*"
+ showFieldSelector (Only (N.toList -> fs)) =
+ intercalate ", " (map showField fs)
+ showField = Store.Query.Field.toString
+ showCollection c = c
+ showJoinClauses js = case map showJoinClause js of
+ [] -> Nothing
+ xs -> Just (intercalate " " xs)
+ showJoinClause (JoinClause t c w) =
+ intercalate " " $
+ catMaybes $
+ [ Just (showJoinType t),
+ Just (showCollection c),
+ Just "ON",
+ showWhereClause w
+ ]
+ showJoinType JoinLeft = "LEFT JOIN"
+ showJoinType JoinRight = "RIGHT JOIN"
+ showJoinType JoinFull = "FULL JOIN"
+ showEmbedClauses js = case map showEmbedClause js of
+ [] -> Nothing
+ xs -> Just (intercalate " " xs)
+ showEmbedClause (EmbedClause c w) =
+ intercalate " " $
+ catMaybes $
+ [ Just "EMBED",
+ Just (showCollection c),
+ Just "ON",
+ showWhereClause w
+ ]
+ showWhereClause = showWhereClauseWith id
+ showWhereClause' = showWhereClauseWith (\x -> "(" <> x <> ")")
+ showWhereClauseWith _ Nothing = Nothing
+ showWhereClauseWith wrap (Just (And ws)) = Just (wrap (intercalate "AND" (mapMaybe (showWhereClause' . Just) ws)))
+ showWhereClauseWith wrap (Just (Or ws)) = Just (wrap (intercalate "OR" (mapMaybe (showWhereClause' . Just) ws)))
+ showWhereClauseWith _ (Just (Where p)) = Just (showComparison p)
+ showComparison (Eq a b) = intercalate " " [showField a, "==", showField b]
diff --git a/src/Store/Query/Record.hs b/src/Store/Query/Record.hs
new file mode 100644
index 0000000..71461d5
--- /dev/null
+++ b/src/Store/Query/Record.hs
@@ -0,0 +1,80 @@
+module Store.Query.Record
+ ( Record (..),
+ fromValue,
+ toValue,
+ lookup,
+ Records,
+ lookups,
+ select,
+ disjointUnion,
+ disjointUnions,
+ )
+where
+
+import Control.Exception (throw)
+import Data.Aeson qualified as J
+import Data.Aeson.Key qualified as JK
+import Data.Aeson.KeyMap qualified as JM
+import Data.List (foldl')
+import Data.List.NonEmpty qualified as N
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Text qualified as T
+import Store.Exception (DuplicateField (DuplicateField))
+import Store.Query.Field
+import Prelude hiding (lookup)
+
+data Record a
+ = Record Collection a
+ deriving (Show, Eq)
+
+type Collection = FilePath
+
+fromValue :: Collection -> a -> Record a
+fromValue = Record
+
+toValue :: Record a -> a
+toValue (Record _ v) = v
+
+lookup :: Field -> Record J.Value -> Maybe J.Value
+lookup (Unqualified ks) (Record _ v) =
+ lookup' (N.toList ks) v
+lookup (Qualified c' ks) (Record c v)
+ | c' == c = lookup' (N.toList ks) v
+ | otherwise = Nothing
+
+lookup' :: [T.Text] -> J.Value -> Maybe J.Value
+lookup' [] v = Just v
+lookup' (k : ks) (J.Object kvs) =
+ lookup' ks =<< JM.lookup (JK.fromText k) kvs
+
+type Records a = [Record a]
+
+lookups :: Field -> Records J.Value -> Maybe J.Value
+lookups f rs =
+ case mapMaybe (lookup f) rs of
+ [] -> Nothing
+ [v] -> Just v
+ (_ : _) -> throw (DuplicateField (toString f))
+
+select :: [Field] -> Records J.Value -> J.Value
+select fs rs =
+ foldl'
+ union
+ (J.Object JM.empty)
+ (map (\f -> prefix f ((fromMaybe J.Null (lookups f rs)))) fs)
+
+union :: J.Value -> J.Value -> J.Value
+union (J.Object r) (J.Object s) = J.Object (JM.unionWith union r s)
+
+disjointUnion :: J.Value -> J.Value -> J.Value
+disjointUnion (J.Object r) (J.Object s) =
+ J.Object (JM.unionWithKey disjointUnion' r s)
+
+disjointUnion' :: JK.Key -> J.Value -> J.Value -> J.Value
+disjointUnion' _ (J.Object r) (J.Object s) =
+ J.Object (JM.unionWithKey disjointUnion' r s)
+disjointUnion' k _ _ =
+ throw (DuplicateField (JK.toString k))
+
+disjointUnions :: [J.Value] -> J.Value
+disjointUnions = foldl' disjointUnion (J.Object JM.empty)
diff --git a/src/Store/Query/Type.hs b/src/Store/Query/Type.hs
new file mode 100644
index 0000000..5aa0e36
--- /dev/null
+++ b/src/Store/Query/Type.hs
@@ -0,0 +1,62 @@
+module Store.Query.Type
+ ( module Store.Query.Field,
+ module Store.Query.Record,
+ Collection,
+ Comparison (..),
+ EmbedClause (..),
+ EmbedClauses,
+ FieldSelector (..),
+ JoinClause (..),
+ JoinClauses,
+ JoinType (..),
+ Query (..),
+ WhereClause (..),
+ )
+where
+
+import Data.List.NonEmpty qualified as N
+import Store.Query.Field
+import Store.Query.Record
+
+data Query
+ = Select
+ FieldSelector
+ Collection
+ (JoinClauses FilePath)
+ (EmbedClauses FilePath)
+ (Maybe WhereClause)
+
+data FieldSelector
+ = All
+ | Only (N.NonEmpty Field)
+ deriving (Show)
+
+type Collection = FilePath
+
+type JoinClauses a = [JoinClause a]
+
+data JoinClause a
+ = JoinClause JoinType a (Maybe WhereClause)
+ deriving (Show)
+
+data JoinType
+ = JoinLeft
+ | JoinRight
+ | JoinFull
+ deriving (Show)
+
+type EmbedClauses a = [EmbedClause a]
+
+data EmbedClause a
+ = EmbedClause a (Maybe WhereClause)
+ deriving (Show)
+
+data WhereClause
+ = And [WhereClause]
+ | Or [WhereClause]
+ | Where Comparison
+ deriving (Show)
+
+data Comparison
+ = Eq Field Field
+ deriving (Show)
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)
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-23 09:52:28 +0000