diff options
| -rw-r--r-- | backend/app/Main.hs | 99 | ||||
| -rw-r--r-- | backend/backend.cabal | 1 |
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, |