From 80a6150610182eefa0deb1f0932d3b780456ca09 Mon Sep 17 00:00:00 2001 From: Alexander Foremny Date: Fri, 11 Oct 2024 23:30:56 +0200 Subject: use backend REST library for frontend --- backend/app/Main.hs | 113 +++++++++++++++++++++----------- backend/app/Route.hs | 14 +--- backend/backend.cabal | 43 +++++------- backend/lib/ACMS/API/REST.hs | 75 +++++++++++++++++++++ backend/lib/ACMS/API/REST/Collection.hs | 87 +++++++++++------------- 5 files changed, 211 insertions(+), 121 deletions(-) create mode 100644 backend/lib/ACMS/API/REST.hs (limited to 'backend') diff --git a/backend/app/Main.hs b/backend/app/Main.hs index a81d769..445b3d1 100644 --- a/backend/app/Main.hs +++ b/backend/app/Main.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ApplicativeDo #-} + module Main where import AutoTypes qualified as U @@ -11,13 +13,19 @@ import Control.Concurrent.STM import Control.Monad import Control.Monad.Trans (liftIO) import Data.Aeson qualified as J +import Data.Aeson.KeyMap qualified as JM import Data.Attoparsec.Char8 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.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.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 @@ -29,11 +37,12 @@ import Options.Applicative qualified as A import Route qualified as R import Safe import Store qualified as Q -import System.Directory (setCurrentDirectory, doesDirectoryExist, makeAbsolute) +import System.Directory (doesDirectoryExist, makeAbsolute, setCurrentDirectory) import System.Exit import System.FilePath import System.INotify import System.IO qualified as IO +import Text.Printf (printf) import Version data Args = Args @@ -44,8 +53,8 @@ args :: A.Parser Args args = Args <$> cmd' data Cmd = Serve - { serverPort :: Int - , contentRepositoryPath :: FilePath + { serverPort :: Int, + contentRepositoryPath :: FilePath } cmd' :: A.Parser Cmd @@ -222,36 +231,66 @@ main = do logStderr ("Serving " ++ contentRepositoryPath' ++ " on port " ++ show serverPort ++ ".") - W.runEnv serverPort $ \req respond -> do - case P.parseOnly R.parser (W.rawPathInfo req) of - Right (R.SchemaJson path) -> do - repo <- atomically (readTMVar repoT) - let [c] = filter ((== path) . (.path)) (last repo.commits).collections - respond . W.responseLBS W.status200 [] $ - J.encode (fromAutoTypes path c.schema) - 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 - Right R.SchemaVersion -> do - repo <- atomically (readTMVar repoT) - respond $ - W.responseLBS W.status200 [] $ - J.encode (last repo.commits).schemaVersion - Right R.Collections -> do - if - | W.requestMethod req == "POST" -> do - Right collection <- J.eitherDecode <$> W.lazyRequestBody req - Q.withStore root ref do - Q.writeFile (collection ".gitkeep") "" - Q.commit - respond $ W.responseLBS W.status200 [] "{}" - | W.requestMethod req == "GET" -> do - repo <- atomically (readTMVar repoT) - respond $ - W.responseLBS W.status200 [] $ - J.encode (map (.path) (last repo.commits).collections) - (traceShowId -> !_) -> - respond $ W.responseLBS W.status200 [] "not implemented" + W.runEnv serverPort . restApi root ref repoT $ + ( \req respond -> 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 + (traceShowId -> !_) -> + respond $ 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 + ("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 + ("GET", ["collection"]) -> do + repo <- atomically (readTMVar repoT) + respond $ + W.responseLBS W.status200 [] $ + J.encode (map (.path) (last repo.commits).collections) + ("POST", ["collection"]) -> do + Right collection <- J.eitherDecode <$> W.lazyRequestBody req + Q.withStore root ref do + Q.writeFile (collection ".gitkeep") "" + Q.commit + respond $ 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, 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)) + ("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)) + ("POST", ["collection", B.toString -> c]) -> do + i <- ((<> ".json") . U.toText) <$> U.nextRandom + 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)) + ("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)) + ("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) + _ -> app req respond diff --git a/backend/app/Route.hs b/backend/app/Route.hs index 61fa699..59c5342 100644 --- a/backend/app/Route.hs +++ b/backend/app/Route.hs @@ -3,19 +3,11 @@ module Route (Route (..), parser) where import Data.Attoparsec.Char8 qualified as P data Route - = SchemaJson String - | Query - | SchemaVersion - | Collections + = Query deriving (Show) parser :: P.Parser Route parser = - ( P.choice - [ pure Collections <* P.string "/collections", - pure SchemaVersion <* P.string "/schemaVersion", - SchemaJson <$> (P.string "/" *> P.manyTill P.anyChar (P.string ".schema.json")), - pure Query <* P.string "/" - ] - ) + pure Query + <* P.string "/" <* P.endOfInput diff --git a/backend/backend.cabal b/backend/backend.cabal index f92dd46..b2ca82b 100644 --- a/backend/backend.cabal +++ b/backend/backend.cabal @@ -8,42 +8,31 @@ author: Alexander Foremny build-type: Simple library - exposed-modules: ACMS.API.REST.Collection + exposed-modules: + ACMS.API.REST + ACMS.API.REST.Collection + hs-source-dirs: lib default-language: GHC2021 default-extensions: - BlockArguments LambdaCase OverloadedStrings ViewPatterns + CPP BlockArguments LambdaCase OverloadedStrings ViewPatterns OverloadedRecordDot NoFieldSelectors MultiWayIf ghc-options: -Wall -threaded build-depends: aeson, - astore, - attoparsec, - autotypes, base, bytestring, - common, - containers, - directory, - filepath, - gitlib, - gitlib-libgit2, - hinotify, - hlibgit2, - http-conduit, - http-types, - mtl, - optparse-applicative, - safe, - split, - stm, - tagged, + exceptions, + miso, text, - utf8-string, - uuid, - wai, - warp + utf8-string + + if arch(javascript) + build-depends: ghcjs-base + + else + build-depends: http-conduit executable backend main-is: Main.hs @@ -79,5 +68,9 @@ executable backend tagged, text, utf8-string, + uuid, wai, warp + + if arch(javascript) + buildable: False diff --git a/backend/lib/ACMS/API/REST.hs b/backend/lib/ACMS/API/REST.hs new file mode 100644 index 0000000..6aca780 --- /dev/null +++ b/backend/lib/ACMS/API/REST.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ACMS.API.REST where + +#ifndef ghcjs_HOST_OS +import Network.HTTP.Simple +#else +import Data.ByteString.Char8 qualified as B +import Data.Maybe +import Data.String +import JavaScript.Web.XMLHttpRequest +import Miso.String qualified as J +#endif +import Control.Monad.Catch (MonadThrow) +import Data.Aeson qualified as A +import Data.ByteString.Lazy.Char8 qualified as LB +import Data.ByteString.Lazy.UTF8 qualified as LB +import Data.Function ((&)) +import Miso (JSM) +import Miso.String (MisoString) + +schemaVersion :: (APIMonad m, A.FromJSON a) => m a +schemaVersion = + "http://localhost:8081/api/rest/schemaVersion" + & fetch + >>= A.throwDecode + +listCollections :: (APIMonad m) => m [MisoString] +listCollections = + "http://localhost:8081/api/rest/collection" + & fetch + >>= A.throwDecode + +createCollection :: (APIMonad m) => MisoString -> m () +createCollection collection = + "http://localhost:8081/api/rest/collections" + & setRequestMethod "POST" + & setRequestBodyLBS (A.encode (A.toJSON collection)) + & fetch + >>= A.throwDecode + +class (MonadThrow m) => APIMonad m where + fetch :: Request -> m LB.ByteString + +instance APIMonad JSM where + fetch req = LB.fromStrict . getResponseBody <$> httpBS req + +#ifdef ghcjs_HOST_OS + +httpBS :: Request -> JSM (Response B.ByteString) +httpBS req = xhrByteString req + +instance IsString Request where + fromString uri = + Request + { reqMethod = GET, + reqURI = J.pack uri, + reqLogin = Nothing, + reqHeaders = [], + reqWithCredentials = False, + reqData = NoData + } + +setRequestMethod :: B.ByteString -> Request -> Request +setRequestMethod "POST" req = req {reqMethod = POST} + +setRequestBodyLBS :: LB.ByteString -> Request -> Request +setRequestBodyLBS body req = req {reqData = StringData (J.pack (LB.toString body))} + +getResponseBody :: Response B.ByteString -> B.ByteString +getResponseBody = fromMaybe "" . contents +#else +instance APIMonad IO where + fetch req = LB.fromStrict . getResponseBody <$> httpBS req +#endif diff --git a/backend/lib/ACMS/API/REST/Collection.hs b/backend/lib/ACMS/API/REST/Collection.hs index c22b6ba..e0df21b 100644 --- a/backend/lib/ACMS/API/REST/Collection.hs +++ b/backend/lib/ACMS/API/REST/Collection.hs @@ -2,68 +2,59 @@ module ACMS.API.REST.Collection where +#ifndef ghcjs_HOST_OS +import Network.HTTP.Simple +#else +import ACMS.API.REST (setRequestMethod, setRequestBodyLBS, getResponseBody) +import Data.ByteString.Char8 qualified as B +import Data.Maybe +import JavaScript.Web.XMLHttpRequest +import Miso.String qualified as J +#endif +import ACMS.API.REST (APIMonad, fetch) import Data.Aeson qualified as A -import Data.Aeson.KeyMap qualified as AM -import Data.ByteString.Lazy.UTF8 qualified as LB import Data.Function ((&)) import Data.String (fromString) -import Data.Text qualified as T -import Network.HTTP.Simple +import Miso.String (MisoString) import Text.Printf (printf) -import Data.UUID qualified as U -import Data.UUID.V4 qualified as U -type CollectionName = T.Text - -list :: T.Text -> IO [A.Object] +list :: (APIMonad m) => MisoString -> m [A.Object] list c = - "http://localhost:8081" - & setRequestMethod "POST" - & setRequestBodyLBS (LB.fromString (printf "SELECT %s FROM %s" c c)) - & httpLBS - >>= A.throwDecode . getResponseBody + fromString (printf "http://localhost:8081/api/rest/collection/%s" c) + & fetch + >>= A.throwDecode -read :: T.Text -> T.Text -> IO [A.Object] +read :: (APIMonad m) => MisoString -> MisoString -> m [A.Object] read c i = - "http://localhost:8081" - & setRequestMethod "POST" - & setRequestBodyLBS - (LB.fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i)) - & httpLBS - >>= A.throwDecode . getResponseBody + fromString (printf "http://localhost:8081/api/rest/collection/%s/%s" c i) + & fetch + >>= A.throwDecode -update :: T.Text -> T.Text -> A.Object -> IO () +update :: (APIMonad m) => MisoString -> MisoString -> A.Object -> m () update c i o = - "http://localhost:8081" - & setRequestMethod "POST" - & setRequestBodyLBS - (LB.fromString (printf "UPDATE %s SET %s WHERE %s.$fileName == \"%s\"" c (LB.toString (A.encode o)) c i)) - & httpLBS - >>= A.throwDecode . getResponseBody + fromString (printf "http://localhost:8081/api/rest/collection/%s/%s" c i) + & setRequestMethod "PUT" + & setRequestBodyLBS (A.encode o) + & fetch + >>= A.throwDecode -create :: T.Text -> A.Object -> IO U.UUID +create :: (APIMonad m) => MisoString -> A.Object -> m A.Object create c o = do - uuid <- U.nextRandom - let i = U.toText uuid <> ".json" - response <- "http://localhost:8081" + fromString (printf "http://localhost:8081/api/rest/collection/%s" c) & setRequestMethod "POST" - & setRequestBodyLBS - (LB.fromString (printf "INSERT %s INTO %s" (LB.toString (A.encode (AM.insert "$fileName" (A.String i) o))) c)) - & httpLBS - uuid <$ A.throwDecode @() (getResponseBody response) + & setRequestBodyLBS (A.encode o) + & fetch + >>= A.throwDecode -delete :: T.Text -> T.Text -> IO [A.Object] +delete :: (APIMonad m) => MisoString -> MisoString -> m [A.Object] delete c i = - "http://localhost:8081" - & setRequestMethod "POST" - & setRequestBodyLBS - (LB.fromString (printf "DELETE FROM %s WHERE %s.$fileName == \"%s\"" c c i)) - & httpLBS - >>= A.throwDecode . getResponseBody + fromString (printf "http://localhost:8081/api/rest/collection/%s/%s" c i) + & setRequestMethod "DELETE" + & fetch + >>= A.throwDecode -schema :: T.Text -> IO A.Value +schema :: (APIMonad m) => (A.FromJSON a) => MisoString -> m a schema c = - fromString (printf "http://localhost:8081/%s.schema.json" c) - & setRequestMethod "POST" - & httpLBS - >>= A.throwDecode . getResponseBody + fromString (printf "http://localhost:8081/api/rest/collection/%s/schema" c) + & fetch + >>= A.throwDecode -- cgit v1.2.3