support ?schemaVersion

3 files changed, 79 insertions, 39 deletions

diff --git a/backend/app/Main.hs b/backend/app/Main.hs
index 24a110f..ec98a9a 100644
--- a/backend/app/Main.hs
+++ b/backend/app/Main.hs
@@ -11,7 +11,9 @@ import AutoTypes.Unify qualified as U
 import Control.Applicative ((<**>))
 import Control.Concurrent
 import Control.Concurrent.STM
+import Control.Exception (throwIO)
 import Control.Monad
+import Control.Monad.Catch (Exception)
 import Control.Monad.Trans (liftIO)
 import Data.Aeson qualified as J
 import Data.Aeson.KeyMap qualified as JM
@@ -19,6 +21,7 @@ import Data.Attoparsec.Char8 qualified as P
 import Data.ByteString.Char8 qualified as B
 import Data.ByteString.Lazy.UTF8 qualified as LB
 import Data.ByteString.UTF8 qualified as B
+import Data.List (find)
 import Data.Map qualified as M
 import Data.Map.Merge.Strict qualified as M
 import Data.Maybe
@@ -240,66 +243,91 @@ main = do
       logStderr ("Serving " ++ contentRepositoryPath' ++ " on port " ++ show serverPort ++ ".")
 
       W.runEnv serverPort . restApi root ref repoT $
-        ( \req respond -> do
+        ( \req resp -> do
             case P.parseOnly R.parser (W.rawPathInfo req) of
               Right R.Query -> do
                 q <-
                   fromString @Q.Query . LB.toString
                     <$> W.lazyRequestBody req
                 r <- liftIO $ Q.withStore root ref do Q.query q
-                respond . W.responseLBS W.status200 [] $ J.encode r
+                resp . W.responseLBS W.status200 [] $ J.encode r
               (traceShowId -> !_) ->
-                respond $ W.responseLBS W.status200 [] "not implemented"
+                resp $ W.responseLBS W.status200 [] "not implemented"
         )
 
-restApi :: String -> T.Text -> TMVar Repo -> W.Middleware
-restApi root ref repoT app req respond =
-  case traceShowId (drop 1 (B.split '/' (W.rawPathInfo req))) of
+data InvalidSchemaVersion = InvalidSchemaVersion String
+  deriving (Show)
+
+instance Exception InvalidSchemaVersion
+
+restApi :: FilePath -> T.Text -> TMVar Repo -> W.Middleware
+restApi root ref repoT app req resp = do
+  schemaVersion <-
+    case find ((== "schemaVersion") . fst) (W.queryString req) of
+      Nothing -> pure Nothing
+      Just (_, Nothing) -> throwIO (InvalidSchemaVersion "")
+      Just (_, Just (B.toString -> v)) ->
+        case versionFromString v of
+          Just v -> pure (Just v)
+          Nothing -> throwIO (InvalidSchemaVersion v)
+  repo <- atomically (readTMVar repoT)
+  let lastCommit = lastCompatible schemaVersion repo.commits
+      rev = lastCommit.id
+  case drop 1 (B.split '/' (W.rawPathInfo req)) of
     ("api" : "rest" : rs) ->
       case (W.requestMethod req, rs) of
         ("GET", ["schemaVersion"]) -> do
-          repo <- atomically (readTMVar repoT)
-          respond $
-            W.responseLBS W.status200 [] $
-              J.encode (last repo.commits).schemaVersion
+          resp . W.responseLBS W.status200 [] $
+            J.encode lastCommit.schemaVersion
         ("GET", ["collection"]) -> do
-          repo <- atomically (readTMVar repoT)
-          respond $
-            W.responseLBS W.status200 [] $
-              J.encode (map (.path) (last repo.commits).collections)
+          resp . W.responseLBS W.status200 [] $
+            J.encode (map (.path) lastCommit.collections)
+        ("GET", ["collection", B.toString -> c, "schema"]) -> do
+          let [collection] = filter ((== c) . (.path)) lastCommit.collections
+          resp . W.responseLBS W.status200 [] $
+            J.encode (fromAutoTypes c collection.schema)
         ("POST", ["collection"]) -> do
           Right collection <- J.eitherDecode <$> W.lazyRequestBody req
-          Q.withStore root ref do
+          Q.withStore root ref $ Q.withCommit rev do
             Q.writeFile (collection </> ".gitkeep") ""
             Q.commit
-          respond $ W.responseLBS W.status200 [] "{}"
+          resp $ W.responseLBS W.status200 [] "{}"
         ("GET", ["collection", B.toString -> c]) -> do
-          respond . W.responseLBS W.status200 [] . J.encode
-            =<< Q.withStore root ref do
-              Q.query (fromString (printf "SELECT %s FROM %s" c c))
-        ("GET", ["collection", B.toString -> c, "schema"]) -> do
-          repo <- atomically (readTMVar repoT)
-          let [collection] = filter ((== c) . (.path)) (last repo.commits).collections
-          respond . W.responseLBS W.status200 [] $
-            J.encode (fromAutoTypes c collection.schema)
+          resp . W.responseLBS W.status200 [] . J.encode
+            =<< ( Q.withStore root ref $ Q.withCommit rev do
+                    Q.query (fromString (printf "SELECT %s FROM %s" c c))
+                )
         ("GET", ["collection", B.toString -> c, B.toString -> i]) -> do
-          respond . W.responseLBS W.status200 [] . J.encode
-            =<< Q.withStore root ref do
-              Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i))
+          resp . W.responseLBS W.status200 [] . J.encode
+            =<< ( Q.withStore root ref $ Q.withCommit rev do
+                    Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i))
+                )
         ("PUT", ["collection", B.toString -> c, B.toString -> i]) -> do
           o <- J.throwDecode @J.Object =<< W.lazyRequestBody req
-          respond . W.responseLBS W.status200 [] . J.encode
-            =<< 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))
+          resp . W.responseLBS W.status200 [] . J.encode
+            =<< ( Q.withStore root ref $ Q.withCommit rev do
+                    Q.query (fromString (printf "UPDATE %s SET %s WHERE %s.$fileName == \"%s\"" c (LB.toString (J.encode o)) c i))
+                )
         ("POST", ["collection", B.toString -> c]) -> do
           i <- ((<> ".json") . U.toText) <$> getUUID
           o <- J.throwDecode @J.Object =<< W.lazyRequestBody req
-          respond . 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))
+          resp . W.responseLBS W.status200 [] . J.encode
+            =<< ( Q.withStore root ref $ Q.withCommit rev do
+                    Q.query (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (JM.insert "$fileName" (J.String i) o))) c))
+                )
         ("DELETE", ["collection", B.toString -> c, B.toString -> i]) -> do
-          respond . W.responseLBS W.status200 [] . J.encode
-            =<< Q.withStore root ref do
-              Q.query (fromString (printf "DELETE FROM %s WHERE %s.$fileName == \"%s\"" c c i))
+          resp . W.responseLBS W.status200 [] . J.encode
+            =<< ( Q.withStore root ref $ Q.withCommit rev do
+                    Q.query (fromString (printf "DELETE FROM %s WHERE %s.$fileName == \"%s\"" c c i))
+                )
         (method, path) -> fail $ "Method " ++ show method ++ " on route " ++ show path ++ " not supported."
-    _ -> app req respond
+    _ -> app req resp
+
+lastCompatible :: Maybe Version -> [Commit] -> Commit
+lastCompatible Nothing commits = last commits
+lastCompatible (Just v) commits
+  | isCompatible v (last commits) = last commits
+  | otherwise = lastCompatible (Just v) (init commits)
+
+isCompatible :: Version -> Commit -> Bool
+isCompatible v c = c.schemaVersion <= traceShowId v
diff --git a/backend/backend.cabal b/backend/backend.cabal
index 0ed54ff..b45ffbb 100644
--- a/backend/backend.cabal
+++ b/backend/backend.cabal
@@ -54,6 +54,7 @@ executable backend
         common,
         containers,
         directory,
+        exceptions,
         filepath,
         gitlib,
         gitlib-libgit2,
diff --git a/common/src/Version.hs b/common/src/Version.hs
index cb568e6..6970968 100644
--- a/common/src/Version.hs
+++ b/common/src/Version.hs
@@ -8,16 +8,24 @@ where
 
 import Data.Aeson qualified as A
 import Data.Aeson.Types qualified as A
+import Data.Function (on)
 import Data.List
 import Data.List.Split
+import Data.Maybe (fromMaybe)
+import Data.String (IsString (..))
 import Data.Text qualified as T
 
 data Version = Version Int Int Int
   deriving (Show, Eq)
 
+instance Ord Version where
+  compare = compare `on` toTriple
+
+toTriple :: Version -> (Int, Int, Int)
+toTriple (Version major minor patch) = (major, minor, patch)
+
 instance A.ToJSON Version where
-  toJSON =
-    A.toJSON . versionToString
+  toJSON = A.toJSON . versionToString
 
 instance A.FromJSON Version where
   parseJSON (A.String (versionFromText -> Just version)) = pure version
@@ -34,3 +42,6 @@ versionFromString _ = Nothing
 
 versionFromText :: T.Text -> Maybe Version
 versionFromText = versionFromString . T.unpack
+
+instance IsString Version where
+  fromString = fromMaybe (error "") . versionFromString