diff options
Diffstat (limited to 'backend/app/Main.hs')
| -rw-r--r-- | backend/app/Main.hs | 65 |
1 files changed, 43 insertions, 22 deletions
diff --git a/backend/app/Main.hs b/backend/app/Main.hs index ec98a9a..eac9701 100644 --- a/backend/app/Main.hs +++ b/backend/app/Main.hs @@ -21,12 +21,13 @@ 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.Function (on, (&)) import Data.List (find) 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 (..)) +import Data.Tagged (Tagged (..), untag) import Data.Text qualified as T import Data.UUID qualified as U import Data.UUID.V4 qualified as U @@ -90,6 +91,9 @@ data Commit = Commit } deriving (Show) +sameCommit :: Commit -> Commit -> Bool +sameCommit = (==) `on` (G.renderOid . untag . (.id)) + data Collection = Collection { path :: FilePath, files :: [FilePath], @@ -242,18 +246,29 @@ main = do logStderr ("Serving " ++ contentRepositoryPath' ++ " on port " ++ show serverPort ++ ".") - W.runEnv serverPort . restApi root ref repoT $ - ( \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 - resp . W.responseLBS W.status200 [] $ J.encode r - (traceShowId -> !_) -> - resp $ W.responseLBS W.status200 [] "not implemented" + stopM <- newEmptyMVar + mapM_ + ( \hostPref -> flip forkFinally (either throwIO (putMVar stopM)) do + W.runSettings + ( W.defaultSettings + & W.setPort serverPort + & W.setHost hostPref + ) + . restApi root ref repoT + $ ( \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 + resp . W.responseLBS W.status200 [] $ J.encode r + (traceShowId -> !_) -> + resp $ W.responseLBS W.status200 [] "not implemented" + ) ) + ["!4", "::1"] -- XXX note !6 does not work.. + takeMVar stopM data InvalidSchemaVersion = InvalidSchemaVersion String deriving (Show) @@ -271,24 +286,26 @@ restApi root ref repoT app req resp = do Just v -> pure (Just v) Nothing -> throwIO (InvalidSchemaVersion v) repo <- atomically (readTMVar repoT) - let lastCommit = lastCompatible schemaVersion repo.commits - rev = lastCommit.id + let lastCompatibleCommit = lastCompatible schemaVersion repo.commits + rev = lastCompatibleCommit.id + lastCommit = last repo.commits case drop 1 (B.split '/' (W.rawPathInfo req)) of ("api" : "rest" : rs) -> case (W.requestMethod req, rs) of ("GET", ["schemaVersion"]) -> do resp . W.responseLBS W.status200 [] $ - J.encode lastCommit.schemaVersion + J.encode lastCompatibleCommit.schemaVersion ("GET", ["collection"]) -> do resp . W.responseLBS W.status200 [] $ - J.encode (map (.path) lastCommit.collections) + J.encode (map (.path) lastCompatibleCommit.collections) ("GET", ["collection", B.toString -> c, "schema"]) -> do - let [collection] = filter ((== c) . (.path)) lastCommit.collections + let [collection] = filter ((== c) . (.path)) lastCompatibleCommit.collections resp . W.responseLBS W.status200 [] $ J.encode (fromAutoTypes c collection.schema) ("POST", ["collection"]) -> do + when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" Right collection <- J.eitherDecode <$> W.lazyRequestBody req - Q.withStore root ref $ Q.withCommit rev do + Q.withStore root ref do Q.writeFile (collection </> ".gitkeep") "" Q.commit resp $ W.responseLBS W.status200 [] "{}" @@ -303,21 +320,25 @@ restApi root ref repoT app req resp = 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 + when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" o <- J.throwDecode @J.Object =<< W.lazyRequestBody req resp . W.responseLBS W.status200 [] . J.encode - =<< ( Q.withStore root ref $ Q.withCommit rev do + =<< ( 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)) ) ("POST", ["collection", B.toString -> c]) -> do + when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" i <- ((<> ".json") . U.toText) <$> getUUID o <- J.throwDecode @J.Object =<< W.lazyRequestBody req resp . W.responseLBS W.status200 [] . J.encode - =<< ( Q.withStore root ref $ Q.withCommit rev do + =<< ( 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)) + headMay <$> Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i)) ) ("DELETE", ["collection", B.toString -> c, B.toString -> i]) -> do + when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" resp . W.responseLBS W.status200 [] . J.encode - =<< ( Q.withStore root ref $ Q.withCommit rev do + =<< ( Q.withStore root ref 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." @@ -330,4 +351,4 @@ lastCompatible (Just v) commits | otherwise = lastCompatible (Just v) (init commits) isCompatible :: Version -> Commit -> Bool -isCompatible v c = c.schemaVersion <= traceShowId v +isCompatible v c = c.schemaVersion <= v |