check referencesmain

2 files changed, 85 insertions, 15 deletions

diff --git a/backend/app/Main.hs b/backend/app/Main.hs
index 0985a3a..3f0072b 100644
--- a/backend/app/Main.hs
+++ b/backend/app/Main.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NondecreasingIndentation #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -13,17 +14,20 @@ import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception (throwIO)
 import Control.Monad
-import Control.Monad.Catch (Exception, SomeException, catch, displayException)
+import Control.Monad.Catch
 import Control.Monad.Trans (liftIO)
 import Data.Aeson qualified as J
+import Data.Aeson.Key qualified as JK
 import Data.Aeson.KeyMap qualified as JM
+import Data.Bifunctor
 import Data.ByteString.Lazy.UTF8 qualified as LB
 import Data.ByteString.UTF8 qualified as B
 import Data.Function (on, (&))
-import Data.List (find)
+import Data.List
 import Data.Map qualified as M
 import Data.Map.Merge.Strict qualified as M
 import Data.Maybe
+import Data.Set qualified as S
 import Data.String (IsString (fromString))
 import Data.Tagged (Tagged (..), untag)
 import Data.Text qualified as T
@@ -83,7 +87,8 @@ data Repo = Repo
 data Commit = Commit
   { id :: G.CommitOid GB.LgRepo,
     collections :: [Collection],
-    schemaVersion :: Version
+    schemaVersion :: Version,
+    refMap :: RefMap
   }
   deriving (Show)
 
@@ -134,15 +139,22 @@ watch repoT root ref = do
       let loop = maybe (pure ()) (const loop) =<< tryReadTQueue qT
       readTQueue qT >> loop
     repo' <- atomically do takeTMVar repoT
-    catch
+    catches
       ( do
           repo <- initRepo root ref
           atomically do putTMVar repoT repo
       )
-      ( \(e :: SomeException) -> do
-          printf "warning: %s\n" (displayException e)
-          atomically do putTMVar repoT repo'
-      )
+      [ Handler
+          ( \(e :: ReferenceViolation) -> do
+              atomically do putTMVar repoT repo'
+              throwIO e
+          ),
+        Handler
+          ( \(e :: SomeException) -> do
+              printf "debug: %s\n" (displayException e)
+              atomically do putTMVar repoT repo'
+          )
+      ]
     pure ()
 
 initRepo :: FilePath -> G.RefName -> IO Repo
@@ -166,6 +178,8 @@ initRepo root ref = do
                   Q.query (fromString ("SELECT " <> path <> " FROM " <> path))
               let schema = U.autoTypes' value values
               pure $ Collection path files schema
+            refMap <- liftIO . Q.withStore root ref . Q.withCommit cid $ do
+              buildRefMap
             let schemaVersion =
                   case headMay cs of
                     Nothing -> Version 1 0 0
@@ -186,7 +200,7 @@ initRepo root ref = do
                             Just Minor -> Version major' (minor' + 1) 0
                             Just Patch -> Version major' minor' (patch' + 1)
                             Nothing -> Version major' minor' patch'
-                c = Commit cid colls schemaVersion
+                c = Commit cid colls schemaVersion refMap
             pure (c : cs)
         )
         []
@@ -230,6 +244,58 @@ data SchemaDifference
 logStderr :: String -> IO ()
 logStderr = IO.hPutStrLn IO.stderr
 
+data RefMap = RefMap
+  { references :: M.Map FilePath (S.Set FilePath),
+    referencees :: M.Map FilePath (S.Set FilePath)
+  }
+  deriving (Show)
+
+data ReferenceViolation
+  = ReferenceViolation
+  { referencee :: FilePath,
+    referencees :: S.Set FilePath
+  }
+  deriving (Show)
+
+instance Exception ReferenceViolation
+
+buildRefMap :: Q.StoreM RefMap
+buildRefMap = do
+  allFiles <- S.fromList <$> Q.listFiles ""
+  refMap <-
+    foldl'
+      ( \refMap (referencee, reference) ->
+          RefMap
+            { references = M.insertWith S.union referencee (S.singleton reference) refMap.references,
+              referencees = M.insertWith S.union reference (S.singleton referencee) refMap.referencees
+            }
+      )
+      (RefMap M.empty M.empty)
+      . concat
+      <$> mapM
+        ( \filePath -> do
+            v@(J.Object _) <- Q.readFile @J.Value filePath
+            pure (map (filePath,) (collectReferences v))
+        )
+        (S.toList allFiles)
+  checkRefMap allFiles refMap
+  pure refMap
+  where
+    collectReferences (J.Object kvs) =
+      case map (first JK.toString) (JM.toList kvs) of
+        [("$ref", J.String i)] -> [T.unpack i]
+        _ -> concat (JM.elems (JM.map collectReferences kvs))
+    collectReferences (J.Array vs) = concatMap collectReferences vs
+    collectReferences _ = []
+
+    checkRefMap allFiles (RefMap {referencees}) = do
+      mapM_
+        ( \(reference, referencees) ->
+            when (not (reference `S.member` allFiles)) do
+              liftIO (throwIO (ReferenceViolation reference referencees))
+        )
+        (M.toList referencees)
+
 main :: IO ()
 main = do
   uuidSeed <- lookupEnv "UUID_SEED"
@@ -245,16 +311,15 @@ main = do
         exitFailure
 
       setCurrentDirectory contentRepositoryPath'
+
       let root = "."
           ref = "refs/heads/master"
       repoT <- newEmptyTMVarIO
-      _ <- forkIO do watch repoT root ref
-
-      logStderr ("Serving " ++ contentRepositoryPath' ++ " on port " ++ show serverPort ++ ".")
 
       stopM <- newEmptyMVar
-      mapM_
-        ( \hostPref -> flip forkFinally (either throwIO (putMVar stopM)) do
+      flip forkFinally (putMVar stopM) do watch repoT root ref
+      mapM
+        ( \hostPref -> flip forkFinally (putMVar stopM) do
             W.runSettings
               ( W.defaultSettings
                   & W.setPort serverPort
@@ -265,7 +330,8 @@ main = do
               $ (\_ resp -> resp (W.responseLBS W.status404 [] "Not found"))
         )
         ["!4", "::1"] -- XXX note !6 does not work..
-      takeMVar stopM
+      logStderr ("Serving " ++ contentRepositoryPath' ++ " on port " ++ show serverPort ++ ".")
+      either throwIO pure =<< takeMVar stopM
 
 data InvalidSchemaVersion = InvalidSchemaVersion String
   deriving (Show)
@@ -352,6 +418,7 @@ restApi root ref repoT app req resp = do
                     _ <- Q.query (fromString (printf "UPDATE %s SET %s WHERE %s.$fileName == \"%s\"" c (LB.toString (J.encode o)) c i))
                     [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))
+                    _ <- buildRefMap
                     Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i))
                 )
         ("POST", ["collection", c]) -> do
@@ -361,6 +428,7 @@ restApi root ref repoT app req resp = do
           resp . W.responseLBS W.status200 [] . J.encode
             =<< ( 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))
+                    _ <- buildRefMap
                     headMay <$> Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i))
                 )
         ("DELETE", ["collection", c, i]) -> do
@@ -369,6 +437,7 @@ restApi root ref repoT app req resp = do
             =<< ( 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))
+                    _ <- buildRefMap
                     pure r
                 )
         (method, path) -> fail $ "Method " ++ show method ++ " on route " ++ show path ++ " not supported."
diff --git a/backend/backend.cabal b/backend/backend.cabal
index c8bff6f..fd0502a 100644
--- a/backend/backend.cabal
+++ b/backend/backend.cabal
@@ -62,6 +62,7 @@ executable backend
         hlibgit2,
         http-types,
         mtl,
+        non-empty,
         optparse-applicative,
         random,
         safe,