aboutsummaryrefslogtreecommitdiffstats
path: root/backend
diff options
context:
space:
mode:
Diffstat (limited to 'backend')
-rw-r--r--backend/app/Main.hs57
-rw-r--r--backend/app/Route.hs13
-rw-r--r--backend/backend.cabal1
3 files changed, 34 insertions, 37 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
diff --git a/backend/app/Route.hs b/backend/app/Route.hs
deleted file mode 100644
index 59c5342..0000000
--- a/backend/app/Route.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module Route (Route (..), parser) where
-
-import Data.Attoparsec.Char8 qualified as P
-
-data Route
- = Query
- deriving (Show)
-
-parser :: P.Parser Route
-parser =
- pure Query
- <* P.string "/"
- <* P.endOfInput
diff --git a/backend/backend.cabal b/backend/backend.cabal
index b45ffbb..ac82e25 100644
--- a/backend/backend.cabal
+++ b/backend/backend.cabal
@@ -37,7 +37,6 @@ library
executable backend
main-is: Main.hs
hs-source-dirs: app
- other-modules: Route
default-language: GHC2021
default-extensions:
BlockArguments LambdaCase OverloadedStrings ViewPatterns
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-23 21:47:22 +0000