diff options
Diffstat (limited to 'backend/app/Main.hs')
| -rw-r--r-- | backend/app/Main.hs | 57 |
1 files changed, 34 insertions, 23 deletions
diff --git a/backend/app/Main.hs b/backend/app/Main.hs index eac9701..3fda813 100644 --- a/backend/app/Main.hs +++ b/backend/app/Main.hs @@ -17,8 +17,6 @@ import Control.Monad.Catch (Exception) import Control.Monad.Trans (liftIO) import Data.Aeson qualified as J import Data.Aeson.KeyMap qualified as JM -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, (&)) @@ -31,14 +29,12 @@ import Data.Tagged (Tagged (..), untag) import Data.Text qualified as T import Data.UUID qualified as U import Data.UUID.V4 qualified as U -import Debug.Trace import Git qualified as G import Git.Libgit2 qualified as GB 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 Route qualified as R import Safe import Store qualified as Q import System.Directory (doesDirectoryExist, makeAbsolute, setCurrentDirectory) @@ -255,17 +251,8 @@ main = do & 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" - ) + . queryApi root ref repoT + $ (\_ resp -> resp (W.responseLBS W.status404 [] "Not found")) ) ["!4", "::1"] -- XXX note !6 does not work.. takeMVar stopM @@ -275,6 +262,30 @@ data InvalidSchemaVersion = InvalidSchemaVersion String instance Exception InvalidSchemaVersion +queryApi :: FilePath -> T.Text -> TMVar Repo -> W.Middleware +queryApi 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 lastCompatibleCommit = lastCompatible schemaVersion repo.commits + lastCommit = last repo.commits + case W.pathInfo req of + ["api", "query"] -> + case W.requestMethod req of + "POST" -> do + when (not (sameCommit lastCompatibleCommit lastCommit)) $ + error "not implemented" + q <- fromString @Q.Query . LB.toString <$> W.lazyRequestBody req + resp . W.responseLBS W.status200 [] . J.encode + =<< Q.withStore root ref do Q.query q + _ -> app req resp + restApi :: FilePath -> T.Text -> TMVar Repo -> W.Middleware restApi root ref repoT app req resp = do schemaVersion <- @@ -289,7 +300,7 @@ restApi root ref repoT app req resp = do let lastCompatibleCommit = lastCompatible schemaVersion repo.commits rev = lastCompatibleCommit.id lastCommit = last repo.commits - case drop 1 (B.split '/' (W.rawPathInfo req)) of + case W.pathInfo req of ("api" : "rest" : rs) -> case (W.requestMethod req, rs) of ("GET", ["schemaVersion"]) -> do @@ -298,7 +309,7 @@ restApi root ref repoT app req resp = do ("GET", ["collection"]) -> do resp . W.responseLBS W.status200 [] $ J.encode (map (.path) lastCompatibleCommit.collections) - ("GET", ["collection", B.toString -> c, "schema"]) -> do + ("GET", ["collection", T.unpack -> c, "schema"]) -> do let [collection] = filter ((== c) . (.path)) lastCompatibleCommit.collections resp . W.responseLBS W.status200 [] $ J.encode (fromAutoTypes c collection.schema) @@ -309,33 +320,33 @@ restApi root ref repoT app req resp = do Q.writeFile (collection </> ".gitkeep") "" Q.commit resp $ W.responseLBS W.status200 [] "{}" - ("GET", ["collection", B.toString -> c]) -> do + ("GET", ["collection", c]) -> do 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 + ("GET", ["collection", c, i]) -> do 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 + ("PUT", ["collection", c, 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 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 + ("POST", ["collection", 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 do - Q.query (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (JM.insert "$fileName" (J.String i) o))) c)) + _ <- 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 + ("DELETE", ["collection", c, i]) -> do when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" resp . W.responseLBS W.status200 [] . J.encode =<< ( Q.withStore root ref do |