diff options
Diffstat (limited to 'backend/app/Main.hs')
| -rw-r--r-- | backend/app/Main.hs | 91 |
1 files changed, 60 insertions, 31 deletions
diff --git a/backend/app/Main.hs b/backend/app/Main.hs index 2b461e5..c9db2ea 100644 --- a/backend/app/Main.hs +++ b/backend/app/Main.hs @@ -177,7 +177,10 @@ initRepo root ref = do J.Array (V.toList -> (value : values)) <- do liftIO . Q.withStore root ref . Q.withCommit cid $ do Q.query (fromString ("SELECT " <> path <> " FROM " <> path)) - let schema = U.autoTypes' value values + let schema = + U.autoTypes' + (fileNameToId value) + (fileNameToId <$> values) pure $ Collection path files schema refMap <- liftIO . Q.withStore root ref . Q.withCommit cid $ do buildRefMap @@ -262,7 +265,10 @@ instance Exception ReferenceViolation buildRefMap :: Q.StoreM RefMap buildRefMap = do - allFiles <- S.fromList <$> Q.listFiles "" + allIds <- + S.fromList + . map ((,) <$> takeDirectory <*> (dropExtension . takeBaseName)) + <$> Q.listFiles "" refMap <- foldl' ( \refMap (referencee, reference) -> @@ -274,12 +280,12 @@ buildRefMap = do (RefMap M.empty M.empty) . concat <$> mapM - ( \filePath -> do - v@(J.Object _) <- Q.readFile @J.Value filePath - pure (map (filePath,) (collectReferences v)) + ( \(c, i) -> do + v@(J.Object _) <- head <$> Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE (T.pack i)))) + pure (map (c </> i,) (collectReferences v)) ) - (S.toList allFiles) - checkRefMap allFiles refMap + (S.toList allIds) + checkRefMap allIds refMap pure refMap where collectReferences (J.Object kvs) = @@ -289,10 +295,10 @@ buildRefMap = do collectReferences (J.Array vs) = concatMap collectReferences vs collectReferences _ = [] - checkRefMap allFiles (RefMap {referencees}) = do + checkRefMap allIds (RefMap {referencees}) = do mapM_ ( \(reference, referencees) -> - when (not (reference `S.member` allFiles)) do + when (not (reference `S.member` S.map (uncurry (</>)) allIds)) do liftIO (throwIO (ReferenceViolation reference referencees)) ) (M.toList referencees) @@ -359,8 +365,8 @@ queryApi root ref repoT app req resp = do when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" q <- fromString @Q.Query . LB.toString <$> W.lazyRequestBody req - resp . W.responseLBS W.status200 [] . J.encode - =<< Q.withStore root ref do Q.query q + resp . W.responseLBS W.status200 [] . J.encode . fileNameToId + =<< Q.withStore root ref do Q.query @J.Value q _ -> do error "not implemented" _ -> app req resp @@ -402,14 +408,14 @@ restApi root ref repoT app req resp = do Q.commit resp $ W.responseLBS W.status200 [] "{}" ("GET", ["collection", c]) -> do - resp . W.responseLBS W.status200 [] . J.encode + resp . W.responseLBS W.status200 [] . J.encode . fileNameToId =<< ( Q.withStore root ref $ Q.withCommit rev do - Q.query (fromString (printf "SELECT %s FROM %s" c c)) + Q.query @J.Value (fromString (printf "SELECT %s FROM %s" c c)) ) ("GET", ["collection", c, "paginated", read @Int . T.unpack -> limit, read @Int . T.unpack -> offset]) -> do - resp . W.responseLBS W.status200 [] . J.encode + resp . W.responseLBS W.status200 [] . J.encode . fileNameToId =<< ( Q.withStore root ref $ Q.withCommit rev do - Q.query + Q.query @J.Value ( fromString ( printf "SELECT %s FROM %s%s%s" @@ -421,37 +427,37 @@ restApi root ref repoT app req resp = do ) ) ("GET", ["collection", c, i]) -> do - resp . W.responseLBS W.status200 [] . J.encode . arrayHead + resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head =<< ( Q.withStore root ref $ Q.withCommit rev do - Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i)) + Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) ) ("PUT", ["collection", c, i]) -> do when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" o <- J.throwDecode @J.Object =<< W.lazyRequestBody req - resp . W.responseLBS W.status200 [] . J.encode . arrayHead + resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head =<< ( Q.withStore root ref do - _ <- Q.query (fromString (printf "UPDATE %s SET %s WHERE %s.$fileName == \"%s\"" c (LB.toString (J.encode o)) c i)) - J.Array (V.toList -> [J.Object r]) <- Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i)) - _ <- Q.query (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (dropNulls r))) c)) + _ <- Q.query @J.Value (fromString (printf "UPDATE %s SET %s WHERE %s.$fileName =~ /^%s\\.json$/" c (LB.toString (J.encode o)) c (escapePCRE i))) + J.Array (V.toList -> [J.Object r]) <- Q.query @J.Value (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) + _ <- Q.query @J.Value (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (dropNulls r))) c)) _ <- buildRefMap - Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i)) + Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) ) ("POST", ["collection", c]) -> do when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" - i <- ((<> ".json") . U.toText) <$> getUUID + i <- U.toText <$> getUUID o <- fmap dropNulls . J.throwDecode @J.Object =<< W.lazyRequestBody req - resp . W.responseLBS W.status200 [] . J.encode . arrayHead + resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head =<< ( Q.withStore root ref do - _ <- Q.query (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (JM.insert "$fileName" (J.String i) o))) c)) + _ <- Q.query @J.Value (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (JM.insert "$fileName" (J.String (i <> ".json")) o))) c)) _ <- buildRefMap - Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i)) + Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) ) ("DELETE", ["collection", c, i]) -> do when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" - resp . W.responseLBS W.status200 [] . J.encode . arrayHead + resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head =<< ( Q.withStore root ref do - r <- Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i)) - Q.query (fromString (printf "DELETE FROM %s WHERE %s.$fileName == \"%s\"" c c i)) + r <- Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) + Q.query @J.Value (fromString (printf "DELETE FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c (escapePCRE i))) _ <- buildRefMap pure r ) @@ -477,5 +483,28 @@ dropNulls = _ -> Just v ) -arrayHead :: J.Value -> J.Value -arrayHead (J.Array v) = V.head v +escapePCRE :: T.Text -> T.Text +escapePCRE = T.pack . escapePCRE' . T.unpack + +escapePCRE' :: String -> String +escapePCRE' [] = [] +escapePCRE' (c : cs) = + ((if c `elem` (".^$*+?()[{\\|" :: String) then ('\\' :) else id) [c]) + <> escapePCRE' cs + +fileNameToId :: J.Value -> J.Value +fileNameToId (J.Array xs) = J.Array (V.map fileNameToId xs) +fileNameToId (J.Object kvs) = + J.Object + ( JM.foldrWithKey + ( \k v -> + case (k, v) of + ("$fileName", J.String v) -> + JM.insert "$id" (J.String (T.pack (dropExtension (T.unpack v)))) + _ -> + JM.insert k (fileNameToId v) + ) + JM.empty + $ kvs + ) +fileNameToId v = v |