diff options
Diffstat (limited to 'backend/app')
| -rw-r--r-- | backend/app/Main.hs | 102 |
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 |