aboutsummaryrefslogtreecommitdiffstats
path: root/backend/app/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'backend/app/Main.hs')
-rw-r--r--backend/app/Main.hs102
1 files changed, 65 insertions, 37 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
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-23 09:50:50 +0000