diff options
Diffstat (limited to 'backend/app')
| -rw-r--r-- | backend/app/Main.hs | 108 |
1 files changed, 88 insertions, 20 deletions
diff --git a/backend/app/Main.hs b/backend/app/Main.hs index 6773916..6742ad2 100644 --- a/backend/app/Main.hs +++ b/backend/app/Main.hs @@ -15,6 +15,8 @@ import Data.ByteString.Lazy.UTF8 qualified as LB import Data.ByteString.UTF8 qualified as B import Data.List import Data.Map qualified as M +import Data.Map.Merge.Strict qualified as M +import Data.Maybe import Data.String (IsString (fromString)) import Data.Tagged (Tagged (..), untag) import Debug.Trace @@ -25,11 +27,13 @@ import Network.HTTP.Types.Status qualified as W import Network.Wai qualified as W import Network.Wai.Handler.Warp qualified as W import Options.Applicative qualified as A +import Safe import Store qualified as Q import System.Directory (setCurrentDirectory) import System.FilePath import System.INotify import Text.Printf (printf) +import Version data Args = Args { cmd :: Cmd @@ -57,7 +61,8 @@ data Repo = Repo data Commit = Commit { id :: G.CommitOid GB.LgRepo, - collections :: [Collection] + collections :: [Collection], + schemaVersion :: Version } deriving (Show) @@ -110,22 +115,78 @@ initRepo root ref = do Just cid <- fmap Tagged <$> G.resolveReference ref c <- G.lookupCommit cid cs <- mapM G.lookupCommit =<< G.listCommits Nothing cid - fmap Repo . forM cs $ \c -> do - let cid = G.commitOid c - fs <- - fmap (filter ((== ".json") . takeExtension)) . liftIO $ - Q.withStore root ref do - Q.withCommit cid Q.listAllFiles - let cls = - M.toList . M.unionsWith (++) $ - map (\f -> M.singleton (takeDirectory f) [f]) fs - colls <- forM cls $ \(makeRelative "/" -> path, (file : files)) -> do - (value : values) <- do - liftIO $ Q.withStore root ref do - mapM (Q.withCommit cid . Q.readFile) (file : files) - let schema = fromAutoTypes path $ U.autoTypes' value values - pure $ Collection path files schema - pure (Commit cid colls) + fmap (Repo . reverse) $ + foldM + ( \cs c -> do + let cid = G.commitOid c + fs <- + fmap (filter ((== ".json") . takeExtension)) . liftIO $ + Q.withStore root ref do + Q.withCommit cid (Q.listFiles "/") + let cls = + M.toList . M.unionsWith (++) $ + map (\f -> M.singleton (takeDirectory f) [f]) fs + colls <- forM cls $ \(path, (file : files)) -> do + (value : values) <- do + liftIO $ Q.withStore root ref do + mapM (Q.withCommit cid . Q.readFile) (file : files) + let schema = fromAutoTypes path $ U.autoTypes' value values + pure $ Collection path files schema + let schemaVersion = + case lastMay cs of + Nothing -> Version 1 0 0 + Just c' -> + let Version major' minor' patch' = c'.schemaVersion + schemas' = + M.fromList + ( (\coll -> (coll.path, coll.schema)) + <$> c'.collections + ) + schemas = + M.fromList + ( (\coll -> (coll.path, coll.schema)) + <$> c.collections + ) + in case compareSchemas schemas' schemas of + Just Major -> Version (major' + 1) 0 0 + Just Minor -> Version major' (minor' + 1) 0 + Just Patch -> Version major' minor' (patch' + 1) + Nothing -> Version major' minor' patch' + c = Commit cid colls schemaVersion + pure (c : cs) + ) + [] + cs + +compareSchemas :: + M.Map String Schema -> + M.Map String Schema -> + Maybe SchemaDifference +compareSchemas schemas' schemas = + maximumMay + . catMaybes + . M.elems + . M.map (uncurry compareSchemas') + $ M.merge + (M.mapMissing (\_ schema' -> (Just schema', Nothing))) + (M.mapMissing (\_ schema -> (Nothing, Just schema))) + (M.zipWithMatched (\_ schema' schema -> (Just schema', Just schema))) + schemas' + schemas + where + compareSchemas' Nothing (Just _) = Just Patch + compareSchemas' (Just _) Nothing = Just Patch + compareSchemas' (Just schema') (Just schema) = compareSchema schema' schema + +-- TODO +compareSchema :: Schema -> Schema -> Maybe SchemaDifference +compareSchema schema' schema = Nothing + +data SchemaDifference + = Major + | Minor + | Patch + deriving (Eq, Ord) main :: IO () main = do @@ -146,21 +207,28 @@ main = do q <- fromString @Q.Query . LB.toString <$> W.lazyRequestBody req - r <- liftIO $ Q.withStore root ref (Q.query q) + r <- liftIO $ Q.withStore root ref do Q.query q respond . W.responseLBS W.status200 [] $ J.encode r - (Debug.Trace.traceShowId -> !_) -> + Right SchemaVersion -> do + repo <- atomically (readTMVar repoT) + respond $ + W.responseLBS W.status200 [] $ + J.encode (last repo.commits).schemaVersion + (traceShowId -> !_) -> respond $ W.responseLBS W.status200 [] "not implemented" data Route = SchemaJson String | Query + | SchemaVersion deriving (Show) routeP :: P.Parser Route routeP = ( P.choice [ SchemaJson <$> (P.string "/" *> P.manyTill P.anyChar (P.string ".schema.json")), - pure Query <* (P.string "/") + pure SchemaVersion <* P.string "/schemaVersion", + pure Query <* P.string "/" ] ) <* P.endOfInput |