add schema version

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

backend/backend.cabal

@@ -23,6 +23,7 @@ executable backend
         autotypes,
         base,
         bytestring,
+        common,
         containers,
         directory,
         filepath,
@@ -33,8 +34,11 @@ executable backend
         http-types,
         mtl,
         optparse-applicative,
+        safe,
+        split,
         stm,
         tagged,
+        text,
         utf8-string,
         wai,
         warp