From 04b43e75fb0822de7db67f108c3545dee451069c Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
Date: Wed, 5 Jun 2024 10:24:31 +0200
Subject: fix restricting UPDATE to `$fileName` comparison
---
src/Store/Query.hs | 41 ++++++++++++++++++++---------------------
1 file changed, 20 insertions(+), 21 deletions(-)
diff --git a/src/Store/Query.hs b/src/Store/Query.hs
index 49fa4fb..2b86c82 100644
--- a/src/Store/Query.hs
+++ b/src/Store/Query.hs
@@ -26,7 +26,7 @@ import System.FilePath ((</>))
query :: Query -> S.StoreM [J.Value]
query (Delete c w) = do
c' <-
- mapM (\fn -> fmap ((fn,) . fromValue c) . decodeFile $ fn)
+ mapM (\fn -> fmap ((fn,) . fromValue c) . decodeFile c $ fn)
. map (c </>)
=<< S.listFiles c
let fps = map fst $ whereBy snd w (map (second (: [])) c')
@@ -35,29 +35,24 @@ query (Delete c w) = do
S.commit
pure []
query (Insert vs c) = do
- let vs' = map (\v -> (fileName v, v)) vs
+ let vs' = map (\v -> ((c, fileName v), v)) vs
fileName v@(J.Object kvs) =
case JM.lookup "$fileName" kvs of
Just (J.String fileName) -> c </> T.unpack fileName
_ -> throw (MissingFileName v)
- mapM_ (\(fp, v) -> encodeFile fp v) vs'
+ mapM_ (\((c, fn), v) -> encodeFile c fn v) vs'
S.commit
pure []
query (Select fs c js es w) = do
c' <-
- mapM
- ( \fn ->
- fromValue c
- . union (J.Object (JM.singleton "$fileName" (J.String (T.pack fn))))
- <$> decodeFile (c </> fn)
- )
+ mapM (\fn -> fromValue c <$> decodeFile c fn)
=<< S.listFiles c
js' <-
mapM
( \(JoinClause t c w) ->
fmap (\j' -> JoinClause t (map (fromValue c) j') w)
- . mapM (decodeFile . (c </>))
+ . mapM (decodeFile c)
=<< S.listFiles c
)
js
@@ -65,20 +60,19 @@ query (Select fs c js es w) = do
mapM
( \(EmbedClause c w) ->
fmap (\e' -> EmbedClause (fromValue c e') w)
- . mapM (decodeFile . (c </>))
+ . mapM (decodeFile c)
=<< S.listFiles c
)
es
pure $ map (Store.Query.select fs) $ where_ w $ embeds es' $ joins js' c'
query (Update c v w) = do
c' <-
- mapM (\fn -> fmap ((fn,) . fromValue c) . decodeFile $ fn)
- . map (c </>)
+ mapM (\fn -> fmap (((c, fn),) . fromValue c) . decodeFile c $ fn)
=<< S.listFiles c
let c'' = whereBy snd w (map (second (: [])) c')
mapM_
- ( \(fp, v') ->
- encodeFile fp (foldl1' union (map toValue v') `union` v)
+ ( \((c, fn), v') ->
+ encodeFile c fn (foldl1' union (map toValue v') `union` v)
)
c''
S.commit
@@ -171,10 +165,15 @@ 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
-decodeFile :: (J.FromJSON a) => Collection -> S.StoreM a
-decodeFile fp =
- fromMaybe (throw DecodeException) . J.decode <$> S.readFile fp
+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
+ <$> S.readFile fp
-encodeFile :: Collection -> J.Value -> S.StoreM ()
-encodeFile fp v =
- S.writeFile fp (J.encode v)
+encodeFile :: String -> String -> J.Value -> S.StoreM ()
+encodeFile c fn (J.Object kvs) = do
+ let fp = c </> fn
+ S.writeFile fp (J.encode (J.Object (JM.filterWithKey (\k _ -> k /= "$fileName") kvs)))
--
cgit v1.2.3