`$fileName` -> `$id`, drop extension

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