diff options
| -rw-r--r-- | app/Main.hs | 28 | ||||
| -rw-r--r-- | astore.cabal | 2 | ||||
| -rw-r--r-- | default.nix | 1 | ||||
| -rw-r--r-- | src/Store/Exception.hs | 2 | ||||
| -rw-r--r-- | src/Store/Query.hs | 72 | ||||
| -rw-r--r-- | src/Store/Query/Parser.hs | 55 | ||||
| -rw-r--r-- | src/Store/Query/Printer.hs | 14 | ||||
| -rw-r--r-- | src/Store/Query/Type.hs | 15 | ||||
| -rw-r--r-- | src/Store/Store.hs | 30 |
9 files changed, 178 insertions, 41 deletions
diff --git a/app/Main.hs b/app/Main.hs index 945bfc9..9da083a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + module Main ( main, ) @@ -9,6 +11,7 @@ import Data.Aeson qualified as J import Data.ByteString.Lazy.Char8 qualified as LB import Data.ByteString.Lazy.UTF8 qualified as LB import Data.String (IsString (fromString)) +import Data.Vector qualified as V import Network.HTTP.Types.Method qualified as W import Network.HTTP.Types.Status qualified as W import Network.Wai qualified as W @@ -63,7 +66,12 @@ main = do R.evalRepl (const . pure $ ">>> ") ( liftIO - . (mapM_ (LB.putStrLn . J.encode) =<<) + . ( ( \case + J.Array xs -> mapM_ (LB.putStrLn . J.encode) (V.toList xs) + x -> LB.putStrLn (J.encode x) + ) + =<< + ) . Q.withStore root ref . Q.query . fromString @@ -77,12 +85,12 @@ main = do Args {cmd = Serve} -> do W.runEnv 8080 $ \req respond -> do if - | W.requestMethod req == W.methodPost -> do - q <- - fromString @Q.Query . LB.toString - <$> W.lazyRequestBody req - r <- liftIO $ Q.withStore root ref (Q.query q) - respond . W.responseLBS W.status200 [] $ - J.encode r - | otherwise -> - respond $ W.responseLBS W.status200 [] "OK" + | W.requestMethod req == W.methodPost -> do + q <- + fromString @Q.Query . LB.toString + <$> W.lazyRequestBody req + r <- liftIO $ Q.withStore root ref (Q.query q) + respond . W.responseLBS W.status200 [] $ + J.encode @J.Value r + | otherwise -> + respond $ W.responseLBS W.status200 [] "OK" diff --git a/astore.cabal b/astore.cabal index a59eb0f..eeb8189 100644 --- a/astore.cabal +++ b/astore.cabal @@ -45,6 +45,7 @@ library megaparsec, mtl, parser-combinators, + regex-pcre, resourcet, tagged, text, @@ -74,5 +75,6 @@ executable astore optparse-applicative, repline, utf8-string, + vector, wai, warp diff --git a/default.nix b/default.nix index 6bd2d86..b123f31 100644 --- a/default.nix +++ b/default.nix @@ -13,6 +13,7 @@ rec { buildInputs = [ haskellPackages.cabal-install haskellPackages.ormolu + pkgs.pkg-config ]; withHoogle = true; withHaddock = true; diff --git a/src/Store/Exception.hs b/src/Store/Exception.hs index 94beaab..579256c 100644 --- a/src/Store/Exception.hs +++ b/src/Store/Exception.hs @@ -9,7 +9,7 @@ where import Control.Exception (Exception) import Data.Aeson qualified as J -data DecodeException = DecodeException +data DecodeException = DecodeException String deriving (Show) instance Exception DecodeException diff --git a/src/Store/Query.hs b/src/Store/Query.hs index 091aae7..5d375bd 100644 --- a/src/Store/Query.hs +++ b/src/Store/Query.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + module Store.Query ( module Store.Query.Type, query, @@ -6,7 +8,6 @@ where import Control.Arrow (second) import Control.Exception (throw) -import Control.Monad.Trans (lift) import Data.Aeson qualified as J import Data.Aeson.Encode.Pretty qualified as JP import Data.Aeson.Key qualified as JK @@ -16,6 +17,7 @@ import Data.Map qualified as M import Data.Maybe (fromMaybe) import Data.Text qualified as T import Data.Vector qualified as V +import GHC.Generics (Generic) import Store.Exception (DecodeException (DecodeException), MissingFileName (MissingFileName)) import Store.Query.Parser () import Store.Query.Printer () @@ -23,18 +25,39 @@ import Store.Query.Record import Store.Query.Type import Store.Store qualified as S import System.FilePath ((</>)) +import Text.Regex.PCRE + +data Paginated = Paginated + { count :: Int, + data_ :: [J.Value] + } + deriving (Show, Generic) + +instance J.ToJSON Paginated -query :: Query -> S.StoreM [J.Value] -query (Delete c w) = do +instance J.FromJSON Paginated + +query :: (J.FromJSON a) => Query -> S.StoreM a +query = + ( ( \case + J.Error e -> throw (DecodeException e) + J.Success x -> pure x + ) + =<< + ) + . fmap J.fromJSON + . query' + +query' :: Query -> S.StoreM J.Value +query' (Delete c w) = do c' <- mapM (\fn -> fmap ((fn,) . fromValue c) . decodeFile c $ fn) =<< S.listFiles c let fps = map fst $ whereBy snd w (map (second (: [])) c') - lift $ print fps mapM_ S.deleteFile (map (c </>) fps) S.commit - pure [] -query (Insert vs c) = do + pure (J.toJSON ([] @())) +query' (Insert vs c) = do let vs' = map (\v -> ((c, fileName v), v)) vs fileName v@(J.Object kvs) = @@ -43,8 +66,8 @@ query (Insert vs c) = do _ -> throw (MissingFileName v) mapM_ (\((c, fn), v) -> encodeFile c fn v) vs' S.commit - pure [] -query (Select fs c js es w) = do + pure (J.toJSON ([] @())) +query' (Select fs c js es w l o) = do c' <- mapM (\fn -> fromValue c <$> decodeFile c fn) =<< S.listFiles c @@ -64,8 +87,19 @@ query (Select fs c js es w) = do =<< S.listFiles c ) es - pure $ map (Store.Query.select fs) $ where_ w $ embeds es' $ joins js' c' -query (Update c v w) = do + let rs = + map (Store.Query.select fs) + . where_ w + . embeds es' + . joins js' + $ c' + rs' = + case l >> o >> pure () of + (Just _) -> + J.toJSON (Paginated (length rs) . applyLimit l . applyOffset o $ rs) + _ -> J.toJSON rs + pure rs' +query' (Update c v w) = do c' <- mapM (\fn -> fmap (((c, fn),) . fromValue c) . decodeFile c $ fn) =<< S.listFiles c @@ -76,7 +110,15 @@ query (Update c v w) = do ) c'' S.commit - pure [] + pure (J.toJSON ([] @())) + +applyLimit :: Maybe LimitClause -> [a] -> [a] +applyLimit Nothing = id +applyLimit (Just (Limit n)) = take n + +applyOffset :: Maybe OffsetClause -> [a] -> [a] +applyOffset Nothing = id +applyOffset (Just (Offset n)) = drop n embeds :: EmbedClauses (Record [J.Value]) -> @@ -164,13 +206,17 @@ 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 = either Just (flip lookups vs) f == either Just (flip lookups vs) g +satisfies (Just (Where (Regex f p))) vs = + case either Just (flip lookups vs) f of + Just (J.String s) -> p `matchTest` T.unpack s + _ -> False decodeFile :: String -> String -> S.StoreM J.Value decodeFile c fn = do let fp = c </> fn union (J.Object (JM.singleton "$fileName" (J.String (T.pack fn)))) - . fromMaybe (throw DecodeException) - . J.decode + . either (throw . DecodeException) id + . J.eitherDecode <$> S.readFile fp encodeFile :: String -> String -> J.Value -> S.StoreM () diff --git a/src/Store/Query/Parser.hs b/src/Store/Query/Parser.hs index 99ddc79..ce2a4dd 100644 --- a/src/Store/Query/Parser.hs +++ b/src/Store/Query/Parser.hs @@ -15,9 +15,11 @@ import Data.Vector qualified as V import Data.Void (Void) import Store.Exception (ParseError (ParseError)) import Store.Query.Type +import System.IO.Unsafe (unsafePerformIO) import Text.Megaparsec qualified as P import Text.Megaparsec.Char qualified as P import Text.Megaparsec.Char.Lexer qualified as P +import Text.Regex.PCRE.String instance IsString Query where fromString = @@ -51,7 +53,11 @@ instance IsString Query where w <- P.optional do where_ whereClause - pure $ Select fs c js es w, + l <- P.optional do + limitClause + o <- P.optional do + offsetClause + pure $ Select fs c js es w l o, do update c <- collection @@ -78,11 +84,14 @@ instance IsString Query where comma = void $ lexeme (P.string ",") embed = void $ lexeme (P.string "EMBED") eq = void $ lexeme (P.string "==") + match = 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") + offset_ = void $ lexeme (P.string "OFFSET") + limit_ = void $ lexeme (P.string "LIMIT") collection = lexeme $ P.takeWhile1P (Just "collection") (not . isSpace) @@ -113,11 +122,30 @@ instance IsString Query where Where <$> comparison ] - comparison = do - a <- P.choice [Left <$> value, Right <$> field] - eq - b <- P.choice [Left <$> value, Right <$> field] - pure $ Eq a b + comparison = + P.choice + ( map + P.try + [ do + a <- P.choice [Left <$> value, Right <$> field] + eq + b <- P.choice [Left <$> value, Right <$> field] + pure $ Eq a b, + do + a <- P.choice [Left <$> value, Right <$> field] + match + b <- regex + pure $ Regex a b + ] + ) + + offsetClause = do + offset_ + Offset <$> lexeme P.decimal + + limitClause = do + limit_ + Limit <$> lexeme P.decimal fieldSelector = lexeme $ @@ -230,6 +258,21 @@ instance IsString Query where fieldPart :: P.Parsec Void String String fieldPart = P.takeWhile1P Nothing (\c -> not (isSpace c) && c /= ',' && c /= '.') + regex = lexeme do + ( unsafePerformIO . compile compBlank execBlank + <$> between (Just (P.string "\\")) (P.string "/") (P.string "/") + ) + >>= either (\e -> error ("regex failed to compile: " <> show e)) pure + + between (Just e) start end = start >> go + where + go = + P.choice + [ e >> (:) <$> P.anySingle <*> go, + P.try ((const "") <$> end), + (:) <$> P.anySingle <*> go + ] + joinType :: P.Parsec Void String JoinType joinType = P.choice diff --git a/src/Store/Query/Printer.hs b/src/Store/Query/Printer.hs index cff543f..ecde378 100644 --- a/src/Store/Query/Printer.hs +++ b/src/Store/Query/Printer.hs @@ -26,7 +26,7 @@ instance Show Query where Just "INTO", Just (showCollection c) ] - show (Select fs c js es w) = + show (Select fs c js es w l o) = intercalate " " . catMaybes $ [ Just "SELECT", Just (showFieldSelector fs), @@ -34,7 +34,9 @@ instance Show Query where Just (showCollection c), showJoinClauses js, showEmbedClauses es, - showWhereClause w + showWhereClause w, + showLimitClause l, + showOffsetClause o ] show (Update c v w) = intercalate " " . catMaybes $ @@ -106,6 +108,14 @@ showComparison (Eq a b) = intercalate " " [showArg a, "==", showArg b] where showArg = either showValue showField +showOffsetClause :: Maybe OffsetClause -> Maybe String +showOffsetClause (Just (Offset n)) = Just (" OFFSET %d" <> show n) +showOffsetClause Nothing = Nothing + +showLimitClause :: Maybe LimitClause -> Maybe String +showLimitClause (Just (Limit n)) = Just (" LIMIT %d" <> show n) +showLimitClause Nothing = Nothing + showValues :: [J.Value] -> Maybe String showValues [] = Nothing showValues vs = Just (intercalate ", " (map showValue vs)) diff --git a/src/Store/Query/Type.hs b/src/Store/Query/Type.hs index 912d020..b431f6c 100644 --- a/src/Store/Query/Type.hs +++ b/src/Store/Query/Type.hs @@ -11,6 +11,8 @@ module Store.Query.Type JoinType (..), Query (..), WhereClause (..), + LimitClause (..), + OffsetClause (..), ) where @@ -18,6 +20,7 @@ import Data.Aeson qualified as J import Data.Map qualified as M import Store.Query.Field import Store.Query.Record +import Text.Regex.PCRE data Query = Delete Collection (Maybe WhereClause) @@ -28,6 +31,8 @@ data Query (JoinClauses FilePath) (EmbedClauses FilePath) (Maybe WhereClause) + (Maybe LimitClause) + (Maybe OffsetClause) | Update Collection J.Value (Maybe WhereClause) data FieldSelector @@ -63,4 +68,14 @@ data WhereClause data Comparison = Eq (Either J.Value Field) (Either J.Value Field) + | Regex (Either J.Value Field) Regex + deriving (Show) + +instance Show Regex where + show _ = "<REGEX>" + +data LimitClause = Limit Int + deriving (Show) + +data OffsetClause = Offset Int deriving (Show) diff --git a/src/Store/Store.hs b/src/Store/Store.hs index 134c8c3..94382af 100644 --- a/src/Store/Store.hs +++ b/src/Store/Store.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + module Store.Store ( StoreM, withStore, @@ -32,6 +34,7 @@ import Data.Time.Clock (getCurrentTime) import Foreign import Git qualified as G import Git.Libgit2 qualified as GB +import Store.Exception (DecodeException (DecodeException)) import System.FilePath (addTrailingPathSeparator, makeRelative, normalise, (</>)) import Text.Printf (printf) import Prelude hiding (readFile, writeFile) @@ -70,11 +73,25 @@ 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} + repo <- + G.openRepository + GB.lgFactory + G.defaultRepositoryOptions + { G.repoPath, + G.repoAutoCreate = True + } + (cid, tid) <- G.runRepository GB.lgFactory repo do - Just cid <- fmap Tagged <$> G.resolveReference ref - tid <- (.commitTree) <$> G.lookupCommit cid - pure (cid, tid) + fmap Tagged <$> G.resolveReference ref >>= \case + Nothing -> do + now <- lift (utcToZonedTime <$> getCurrentTimeZone <*> getCurrentTime) + let sig = G.Signature "author" "email" now + tid <- G.createTree (pure ()) + cid <- G.commitOid <$> G.createCommit [] tid sig sig "auto-init" (Just ref) + pure (cid, tid) + Just cid -> do + tid <- (.commitTree) <$> G.lookupCommit cid + pure (cid, tid) runReaderT (evalStateT (runStoreT action) (State {cid, tid})) @@ -128,11 +145,6 @@ data InappropriateType = InappropriateType String FilePath instance Exception InappropriateType -data DecodeException = DecodeException String - deriving (Show) - -instance Exception DecodeException - class Readable a where readFile :: FilePath -> StoreM a |