From 950eea3ba04e94cf3d5797f9b5d32b2621c89b55 Mon Sep 17 00:00:00 2001 From: Alexander Foremny Date: Tue, 13 Feb 2024 02:07:20 +0100 Subject: refactor library --- app/Debug.hs | 10 ---- app/Exception.hs | 23 -------- app/Main.hs | 2 +- app/Query.hs | 134 --------------------------------------------- app/Query/Field.hs | 32 ----------- app/Query/Parser.hs | 126 ------------------------------------------ app/Query/Printer.hs | 60 -------------------- app/Query/Record.hs | 80 --------------------------- app/Query/Type.hs | 62 --------------------- app/Store.hs | 121 ---------------------------------------- astore.cabal | 64 ++++++++++++++++++++++ json2sql.cabal | 60 -------------------- src/Store.hs | 6 ++ src/Store/Debug.hs | 10 ++++ src/Store/Exception.hs | 23 ++++++++ src/Store/Query.hs | 134 +++++++++++++++++++++++++++++++++++++++++++++ src/Store/Query/Field.hs | 32 +++++++++++ src/Store/Query/Parser.hs | 126 ++++++++++++++++++++++++++++++++++++++++++ src/Store/Query/Printer.hs | 60 ++++++++++++++++++++ src/Store/Query/Record.hs | 80 +++++++++++++++++++++++++++ src/Store/Query/Type.hs | 62 +++++++++++++++++++++ src/Store/Store.hs | 121 ++++++++++++++++++++++++++++++++++++++++ 22 files changed, 719 insertions(+), 709 deletions(-) delete mode 100644 app/Debug.hs delete mode 100644 app/Exception.hs delete mode 100644 app/Query.hs delete mode 100644 app/Query/Field.hs delete mode 100644 app/Query/Parser.hs delete mode 100644 app/Query/Printer.hs delete mode 100644 app/Query/Record.hs delete mode 100644 app/Query/Type.hs delete mode 100644 app/Store.hs create mode 100644 astore.cabal delete mode 100644 json2sql.cabal create mode 100644 src/Store.hs create mode 100644 src/Store/Debug.hs create mode 100644 src/Store/Exception.hs create mode 100644 src/Store/Query.hs create mode 100644 src/Store/Query/Field.hs create mode 100644 src/Store/Query/Parser.hs create mode 100644 src/Store/Query/Printer.hs create mode 100644 src/Store/Query/Record.hs create mode 100644 src/Store/Query/Type.hs create mode 100644 src/Store/Store.hs diff --git a/app/Debug.hs b/app/Debug.hs deleted file mode 100644 index 3499e02..0000000 --- a/app/Debug.hs +++ /dev/null @@ -1,10 +0,0 @@ -module 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/app/Exception.hs b/app/Exception.hs deleted file mode 100644 index 0cccf5b..0000000 --- a/app/Exception.hs +++ /dev/null @@ -1,23 +0,0 @@ -module 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/app/Main.hs b/app/Main.hs index 7bf67ba..5574afa 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -5,7 +5,7 @@ where import Data.Aeson qualified as J import Data.ByteString.Lazy.Char8 qualified as LB -import Query qualified as Q +import Store qualified as Q import System.Directory (setCurrentDirectory) import Text.Printf (printf) diff --git a/app/Query.hs b/app/Query.hs deleted file mode 100644 index 140d0f1..0000000 --- a/app/Query.hs +++ /dev/null @@ -1,134 +0,0 @@ -module Query - ( module 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 Exception (DecodeException (DecodeException)) -import Query.Parser () -import Query.Printer () -import Query.Record -import Query.Type -import 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 (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 = 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/app/Query/Field.hs b/app/Query/Field.hs deleted file mode 100644 index cdb977a..0000000 --- a/app/Query/Field.hs +++ /dev/null @@ -1,32 +0,0 @@ -module 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/app/Query/Parser.hs b/app/Query/Parser.hs deleted file mode 100644 index f2012e2..0000000 --- a/app/Query/Parser.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module 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 Exception (ParseError (ParseError)) -import 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/app/Query/Printer.hs b/app/Query/Printer.hs deleted file mode 100644 index e43b7d0..0000000 --- a/app/Query/Printer.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Query.Printer () where - -import Data.List (intercalate) -import Data.List.NonEmpty qualified as N -import Data.Maybe (catMaybes, mapMaybe) -import Query.Field -import 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 = 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/app/Query/Record.hs b/app/Query/Record.hs deleted file mode 100644 index b1b3329..0000000 --- a/app/Query/Record.hs +++ /dev/null @@ -1,80 +0,0 @@ -module 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 Exception (DuplicateField (DuplicateField)) -import 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/app/Query/Type.hs b/app/Query/Type.hs deleted file mode 100644 index d27106f..0000000 --- a/app/Query/Type.hs +++ /dev/null @@ -1,62 +0,0 @@ -module Query.Type - ( module Query.Field, - module Query.Record, - Collection, - Comparison (..), - EmbedClause (..), - EmbedClauses, - FieldSelector (..), - JoinClause (..), - JoinClauses, - JoinType (..), - Query (..), - WhereClause (..), - ) -where - -import Data.List.NonEmpty qualified as N -import Query.Field -import 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/app/Store.hs b/app/Store.hs deleted file mode 100644 index 3a899b6..0000000 --- a/app/Store.hs +++ /dev/null @@ -1,121 +0,0 @@ -module 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) diff --git a/astore.cabal b/astore.cabal new file mode 100644 index 0000000..fa9b4ea --- /dev/null +++ b/astore.cabal @@ -0,0 +1,64 @@ +cabal-version: 3.4 +name: astore +version: 0.1.0.0 +license: Apache-2.0 +license-file: LICENSE +maintainer: aforemny@posteo.de +author: Alexander Foremny +build-type: Simple +extra-doc-files: CHANGELOG.md + +library + exposed-modules: + Store + + hs-source-dirs: src + other-modules: Store.Debug + Store.Exception + Store.Query + Store.Query.Field + Store.Query.Parser + Store.Query.Printer + Store.Query.Record + Store.Query.Type + Store.Store + default-language: GHC2021 + default-extensions: + AllowAmbiguousTypes BlockArguments GeneralizedNewtypeDeriving + OverloadedRecordDot OverloadedStrings ViewPatterns + + ghc-options: + -Wall -fno-warn-incomplete-patterns -fno-warn-name-shadowing + + build-depends: + aeson, + base, + bytestring, + containers, + directory, + exceptions, + filepath, + gitlib, + gitlib-libgit2, + megaparsec, + mtl, + parser-combinators, + tagged, + text, + unliftio, + unliftio-core, + unordered-containers, + utf8-string, + vector + +executable astore + main-is: Main.hs + hs-source-dirs: app + default-language: GHC2021 + default-extensions: OverloadedStrings + build-depends: + aeson, + astore, + base, + bytestring, + directory diff --git a/json2sql.cabal b/json2sql.cabal deleted file mode 100644 index 1cfd4da..0000000 --- a/json2sql.cabal +++ /dev/null @@ -1,60 +0,0 @@ -cabal-version: 3.4 -name: json2sql -version: 0.1.0.0 --- synopsis: --- description: -license: Apache-2.0 -license-file: LICENSE -author: Alexander Foremny -maintainer: aforemny@posteo.de --- copyright: -build-type: Simple -extra-doc-files: CHANGELOG.md --- extra-source-files: - -executable json2sql - ghc-options: - -Wall - -fno-warn-incomplete-patterns - -fno-warn-name-shadowing - main-is: Main.hs - other-modules: - Debug - Exception - Query - Query.Field - Query.Parser - Query.Printer - Query.Record - Query.Type - Store - -- other-extensions: - build-depends: base ^>=4.16.4.0, - aeson, - bytestring, - containers, - directory, - exceptions, - filepath, - gitlib, - gitlib-libgit2, - megaparsec, - mtl, - parser-combinators, - tagged, - text, - unliftio, - unliftio-core, - unordered-containers, - utf8-string, - vector - hs-source-dirs: app - default-language: GHC2021 - default-extensions: - AllowAmbiguousTypes - BlockArguments - GeneralizedNewtypeDeriving - OverloadedRecordDot - OverloadedStrings - ViewPatterns - diff --git a/src/Store.hs b/src/Store.hs new file mode 100644 index 0000000..f7562f5 --- /dev/null +++ b/src/Store.hs @@ -0,0 +1,6 @@ +module Store + ( module Store.Query, + ) +where + +import Store.Query 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) -- cgit v1.2.3