From ce0bd6f82a9e0f9a458e6748576dd878a39609a7 Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Tue, 24 Oct 2023 13:08:20 +0300 Subject: [PATCH] Debug new route finder --- Makefile | 2 +- examples/mig-example-apps/RouteArgs/Main.hs | 2 +- .../mig-example-apps/mig-example-apps.cabal | 16 ++--- examples/mig-example-apps/package.yaml | 2 +- mig-server/src/Mig/Server/Warp.hs | 2 +- mig-wai/src/Mig/Server/Wai.hs | 27 ++++++--- mig/src/Mig/Core/Api.hs | 6 +- mig/src/Mig/Core/Api/NormalForm/TreeApi.hs | 59 ++++++++++++++----- mig/src/Mig/Core/Server.hs | 41 ++++++++++--- 9 files changed, 111 insertions(+), 46 deletions(-) diff --git a/Makefile b/Makefile index 60e83d7..41f2137 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ .PHONY: build test run docs build: - stack build mig + stack build test: stack test diff --git a/examples/mig-example-apps/RouteArgs/Main.hs b/examples/mig-example-apps/RouteArgs/Main.hs index 7af5e1a..a1ee66b 100644 --- a/examples/mig-example-apps/RouteArgs/Main.hs +++ b/examples/mig-example-apps/RouteArgs/Main.hs @@ -13,7 +13,7 @@ import Mig.Json.IO main :: IO () main = do putStrLn ("The route args server listens on port: " <> show port) - runServer port (withSwagger def routeArgs) + runServer port routeArgs where port = 8085 diff --git a/examples/mig-example-apps/mig-example-apps.cabal b/examples/mig-example-apps/mig-example-apps.cabal index 1eee4d9..a9cd9ab 100644 --- a/examples/mig-example-apps/mig-example-apps.cabal +++ b/examples/mig-example-apps/mig-example-apps.cabal @@ -76,7 +76,7 @@ executable counter-client-mig-example-app , mig-swagger-ui , mtl , openapi3 - , pretty-show + , pretty-simple , random , safe , text @@ -127,7 +127,7 @@ executable counter-mig-example-app , mig-swagger-ui , mtl , openapi3 - , pretty-show + , pretty-simple , random , safe , text @@ -178,7 +178,7 @@ executable hello-world-client-mig-example-app , mig-server , mig-swagger-ui , openapi3 - , pretty-show + , pretty-simple , random , safe , text @@ -228,7 +228,7 @@ executable hello-world-mig-example-app , mig-server , mig-swagger-ui , openapi3 - , pretty-show + , pretty-simple , random , safe , text @@ -291,7 +291,7 @@ executable html-mig-example-app , mig-server , mig-swagger-ui , openapi3 - , pretty-show + , pretty-simple , random , safe , text @@ -351,7 +351,7 @@ executable json-api-mig-example-app , mig-server , mig-swagger-ui , openapi3 - , pretty-show + , pretty-simple , random , safe , text @@ -403,7 +403,7 @@ executable route-args-client-mig-example-app , mig-server , mig-swagger-ui , openapi3 - , pretty-show + , pretty-simple , random , safe , text @@ -453,7 +453,7 @@ executable route-args-mig-example-app , mig-server , mig-swagger-ui , openapi3 - , pretty-show + , pretty-simple , random , safe , text diff --git a/examples/mig-example-apps/package.yaml b/examples/mig-example-apps/package.yaml index eef16d2..c8cfaf3 100644 --- a/examples/mig-example-apps/package.yaml +++ b/examples/mig-example-apps/package.yaml @@ -66,7 +66,7 @@ dependencies: - aeson - random - time - - pretty-show + - pretty-simple - openapi3 - safe - containers diff --git a/mig-server/src/Mig/Server/Warp.hs b/mig-server/src/Mig/Server/Warp.hs index 2caf54b..4dff573 100644 --- a/mig-server/src/Mig/Server/Warp.hs +++ b/mig-server/src/Mig/Server/Warp.hs @@ -14,7 +14,7 @@ import Network.Wai.Handler.Warp qualified as Warp runServer :: Int -> Server IO -> IO () runServer port server = Warp.run port (toApplication config server) where - config = ServerConfig{maxBodySize = Nothing, cache = Nothing} + config = ServerConfig{maxBodySize = Nothing, cache = Nothing, findRoute = TreeFinder} runServer' :: ServerConfig -> Int -> Server IO -> IO () runServer' config port server = Warp.run port (toApplication config server) diff --git a/mig-wai/src/Mig/Server/Wai.hs b/mig-wai/src/Mig/Server/Wai.hs index 322a2e3..8dd9e33 100644 --- a/mig-wai/src/Mig/Server/Wai.hs +++ b/mig-wai/src/Mig/Server/Wai.hs @@ -1,6 +1,7 @@ -- | Converts mig server to WAI-application. module Mig.Server.Wai ( ServerConfig (..), + FindRouteType (..), Kilobytes, toApplication, ) where @@ -28,17 +29,27 @@ data ServerConfig = ServerConfig { maxBodySize :: Maybe Kilobytes -- ^ limit the request body size. By default it is unlimited. , cache :: Maybe CacheConfig + , findRoute :: FindRouteType } +-- | Algorithm to find route handlers by path +data FindRouteType = TreeFinder | PlainFinder + toApplication :: ServerConfig -> Server IO -> Wai.Application toApplication config = case config.cache of - Just cacheConfig -> toApplicationWithCache cacheConfig config - Nothing -> toApplicationNoCache config + Just cacheConfig -> + case config.findRoute of + TreeFinder -> toApplicationWithCache cacheConfig config treeApiStrategy + PlainFinder -> toApplicationWithCache cacheConfig config plainApiStrategy + Nothing -> + case config.findRoute of + TreeFinder -> toApplicationNoCache config treeApiStrategy + PlainFinder -> toApplicationNoCache config plainApiStrategy -- | Convert server to WAI-application -toApplicationNoCache :: ServerConfig -> Server IO -> Wai.Application -toApplicationNoCache config server req procResponse = do - mResp <- handleError onErr (fromServer server) =<< fromRequest config.maxBodySize req +toApplicationNoCache :: ServerConfig -> FindRoute nf IO -> Server IO -> Wai.Application +toApplicationNoCache config findRoute server req procResponse = do + mResp <- handleError onErr (fromServer findRoute server) =<< fromRequest config.maxBodySize req procResponse $ toWaiResponse $ fromMaybe noResult mResp where noResult = badRequest @Text ("Server produces nothing" :: Text) @@ -47,10 +58,10 @@ toApplicationNoCache config server req procResponse = do onErr err = const $ pure $ Just $ badRequest @Text $ "Error: Exception has happened: " <> toText (show err) -- | Convert server to WAI-application -toApplicationWithCache :: CacheConfig -> ServerConfig -> Server IO -> Wai.Application -toApplicationWithCache cacheConfig config server req procResponse = do +toApplicationWithCache :: CacheConfig -> ServerConfig -> FindRoute nf IO -> Server IO -> Wai.Application +toApplicationWithCache cacheConfig config findRoute server req procResponse = do cache <- newRouteCache cacheConfig - mResp <- handleError onErr (fromServerWithCache cache server) =<< fromRequest config.maxBodySize req + mResp <- handleError onErr (fromServerWithCache findRoute cache server) =<< fromRequest config.maxBodySize req procResponse $ toWaiResponse $ fromMaybe noResult mResp where noResult = badRequest @Text ("Server produces nothing" :: Text) diff --git a/mig/src/Mig/Core/Api.hs b/mig/src/Mig/Core/Api.hs index db07f9d..5c13652 100644 --- a/mig/src/Mig/Core/Api.hs +++ b/mig/src/Mig/Core/Api.hs @@ -67,7 +67,7 @@ filterApi check = \case rec = filterApi check -- | converts API to efficient representation to fetch the route handlers by path -toNormalApi :: forall m. Api (Route.Route m) -> ApiNormal (Route.Route m) +toNormalApi :: forall m. Api (Route.Route m) -> ApiNormal (Api (Route.Route m)) toNormalApi api = ApiNormal $ fmap (fmap toInputMediaMap . toOutputMediaMap) (toMethodMap api) where filterEmpty :: Map key (Api val) -> Map key (Api val) @@ -105,14 +105,14 @@ toNormalApi api = ApiNormal $ fmap (fmap toInputMediaMap . toOutputMediaMap) (to filterAnyCases = filter (("*/*" /=) . fst) -- | Read sub-api by HTTP method, accept-type and content-type -fromNormalApi :: Method -> ByteString -> ByteString -> ApiNormal a -> Maybe (Api a) +fromNormalApi :: Method -> ByteString -> ByteString -> ApiNormal a -> Maybe a fromNormalApi method outputAccept inputContentType (ApiNormal methodMap) = do OutputMediaMap outputMediaMap <- Map.lookup method methodMap InputMediaMap inputMediaMap <- lookupMediaMapBy mapAcceptMedia outputMediaMap outputAccept lookupMediaMapBy mapContentMedia inputMediaMap inputContentType -- | Efficient representation of API to fetch routes -newtype ApiNormal a = ApiNormal (MethodMap (OutputMediaMap (InputMediaMap (Api a)))) +newtype ApiNormal a = ApiNormal (MethodMap (OutputMediaMap (InputMediaMap a))) deriving (Show, Eq, Functor) -- | Mthod map diff --git a/mig/src/Mig/Core/Api/NormalForm/TreeApi.hs b/mig/src/Mig/Core/Api/NormalForm/TreeApi.hs index cb757ca..edf6575 100644 --- a/mig/src/Mig/Core/Api/NormalForm/TreeApi.hs +++ b/mig/src/Mig/Core/Api/NormalForm/TreeApi.hs @@ -12,8 +12,9 @@ import Data.List qualified as List import Data.List.Extra qualified as List import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map -import Data.Maybe (mapMaybe) +import Data.Maybe (isNothing, mapMaybe) import Data.Text (Text) +import Data.Text qualified as Text import Mig.Core.Api (Api (..), Path (..), PathItem (..)) @@ -23,22 +24,24 @@ data TreeApi a = WithStaticPath [Text] (TreeApi a) | WithCapturePath [Text] (TreeApi a) | SwitchApi (Maybe a) (Map Text (TreeApi a)) (Maybe (CaptureCase a)) + deriving (Eq, Show, Functor) data CaptureCase a = CaptureCase { name :: Text , api :: TreeApi a } + deriving (Eq, Show, Functor) -- | Get a route by path, also extracts capture map -getPath :: [Text] -> TreeApi a -> Maybe (CaptureMap, a) -getPath = go mempty +getPath :: [Text] -> TreeApi a -> Maybe (a, CaptureMap) +getPath mainPath = go mempty (filter (not . Text.null) mainPath) where - go :: CaptureMap -> [Text] -> TreeApi a -> Maybe (CaptureMap, a) + go :: CaptureMap -> [Text] -> TreeApi a -> Maybe (a, CaptureMap) go !captures !path !api = case path of [] -> case api of - SwitchApi (Just result) _ _ -> Just (captures, result) + SwitchApi (Just result) _ _ -> Just (result, captures) _ -> Nothing headPath : tailPath -> case api of @@ -81,15 +84,26 @@ accumCapture !captures !names !path = -- convert to normal form toTreeApi :: Api a -> TreeApi a -toTreeApi = \case - Empty -> SwitchApi Nothing mempty Nothing - WithPath path subApi -> case fromPathPrefix path of - Nothing -> toTreeApi subApi - Just prefix -> case prefix of - StaticPrefix ps rest -> WithStaticPath ps (toTreeApi $ WithPath rest subApi) - CapturePrefix ps rest -> WithCapturePath ps (toTreeApi $ WithPath rest subApi) - HandleRoute a -> SwitchApi (Just a) mempty Nothing - Append a b -> fromAlts $ orderAppends (collectAppends a <> collectAppends b) +toTreeApi = + joinPaths . \case + Empty -> SwitchApi Nothing mempty Nothing + WithPath path subApi -> case fromPathPrefix path of + Nothing -> toTreeApi subApi + Just prefix -> case prefix of + StaticPrefix ps rest -> WithStaticPath ps (toTreeApi $ WithPath rest subApi) + CapturePrefix ps rest -> WithCapturePath ps (toTreeApi $ WithPath rest subApi) + HandleRoute a -> SwitchApi (Just a) mempty Nothing + Append a b -> fromAlts $ orderAppends (collectAppends a <> collectAppends b) + +joinPaths :: TreeApi a -> TreeApi a +joinPaths = \case + SwitchApi mRoute alts mCapture -> SwitchApi mRoute (fmap joinPaths alts) (fmap joinCapturePaths mCapture) + WithStaticPath pathA (WithStaticPath pathB subApi) -> joinPaths (WithStaticPath (pathA ++ pathB) subApi) + WithCapturePath namesA (WithCapturePath namesB subApi) -> joinPaths (WithCapturePath (namesA ++ namesB) subApi) + WithStaticPath path subApi -> WithStaticPath path (joinPaths subApi) + WithCapturePath names subApi -> WithCapturePath names (joinPaths subApi) + where + joinCapturePaths x = x{api = joinPaths x.api} data Alts a = Alts { appends :: [(Text, Api a)] @@ -136,10 +150,25 @@ orderAppends items = fromAlts :: Alts a -> TreeApi a fromAlts alts = - SwitchApi alts.route (fmap toTreeApi $ Map.fromList alts.appends) (fmap toCaptureCase alts.capture) + case getStaticSingleton of + Just (path, subApi) -> WithStaticPath [path] (toTreeApi subApi) + Nothing -> + case getCaptureSingleton of + Just (names, subApi) -> WithCapturePath [names] (toTreeApi subApi) + Nothing -> SwitchApi alts.route (fmap toTreeApi $ Map.fromList alts.appends) (fmap toCaptureCase alts.capture) where toCaptureCase (name, api) = CaptureCase name (toTreeApi api) + getStaticSingleton = + case alts.appends of + [(path, subApi)] | isNothing alts.route && isNothing alts.capture -> Just (path, subApi) + _ -> Nothing + + getCaptureSingleton = + case alts.capture of + Just (name, subApi) | isNothing alts.route && null alts.appends -> Just (name, subApi) + _ -> Nothing + data PathPrefix = StaticPrefix [Text] Path | CapturePrefix [Text] Path diff --git a/mig/src/Mig/Core/Server.hs b/mig/src/Mig/Core/Server.hs index c7428f4..a7a5491 100644 --- a/mig/src/Mig/Core/Server.hs +++ b/mig/src/Mig/Core/Server.hs @@ -3,6 +3,9 @@ -- | Server definition module Mig.Core.Server ( Server (..), + FindRoute, + treeApiStrategy, + plainApiStrategy, mapServerFun, mapResponse, fromServer, @@ -38,6 +41,7 @@ import Web.HttpApiData import Mig.Core.Api (Api, fromNormalApi, toNormalApi) import Mig.Core.Api qualified as Api +import Mig.Core.Api.NormalForm.TreeApi qualified as TreeApi import Mig.Core.Class.MediaType import Mig.Core.Class.Response (IsResp (..), Resp (..)) import Mig.Core.Class.Route @@ -100,20 +104,41 @@ mapServerFun f (Server server) = Server $ fmap (\x -> Route x.info (f x.run)) se mapResponse :: (Functor m) => (Response -> Response) -> Server m -> Server m mapResponse f = mapServerFun $ \fun -> fmap (fmap f) . fun +data FindRoute nf m = FindRoute + { toNormalForm :: Api (Route m) -> nf (Route m) + , getPath :: [Text] -> nf (Route m) -> Maybe (Route m, Api.CaptureMap) + } + +-- | Use TreeApi normal form +treeApiStrategy :: FindRoute TreeApi.TreeApi m +treeApiStrategy = + FindRoute + { toNormalForm = TreeApi.toTreeApi + , getPath = TreeApi.getPath + } + +-- | Use plain api type +plainApiStrategy :: FindRoute Api.Api m +plainApiStrategy = + FindRoute + { toNormalForm = id + , getPath = Api.getPath + } + {-| Converts server to server function. Server function can be used to implement low-level handlers in various server-libraries. -} -fromServer :: (Monad m) => Server m -> ServerFun m -fromServer (Server server) = \req -> do +fromServer :: forall m nf. (Monad m) => FindRoute nf m -> Server m -> ServerFun m +fromServer strategy (Server server) = \req -> do case getRoute req of Just (routes, captureMap) -> routes.run req{capture = captureMap} Nothing -> pure Nothing where - serverNormal = toNormalApi (fillCaptures server) + serverNormal = fmap strategy.toNormalForm $ toNormalApi (fillCaptures server) getRoute req = do api <- fromNormalApi req.method (getMediaType "Accept" req) (getMediaType "Content-Type" req) serverNormal - Api.getPath req.path api + strategy.getPath req.path api getMediaType name req = fromMaybe "*/*" $ Map.lookup name req.headers @@ -121,19 +146,19 @@ fromServer (Server server) = \req -> do in various server-libraries. This function also uses LRU-cache to cache fetching of the routes -} -fromServerWithCache :: forall m. (MonadIO m) => RouteCache m -> Server m -> ServerFun m -fromServerWithCache cache (Server server) = \req -> do +fromServerWithCache :: forall m nf. (MonadIO m) => FindRoute nf m -> RouteCache m -> Server m -> ServerFun m +fromServerWithCache strategy cache (Server server) = \req -> do mRoute <- liftIO $ withCache cache getRouteCache (getCacheKey req) case mRoute of Just (CacheValue captureMap routes) -> routes.run req{capture = captureMap} Nothing -> pure Nothing where - serverNormal = toNormalApi (fillCaptures server) + serverNormal = fmap strategy.toNormalForm $ toNormalApi (fillCaptures server) getRouteCache :: CacheKey -> Maybe (CacheValue m) getRouteCache key = do api <- fromNormalApi key.method key.outputType key.inputType serverNormal - uncurry (flip CacheValue) <$> Api.getPath key.path api + uncurry (flip CacheValue) <$> strategy.getPath key.path api getCacheKey :: Request -> CacheKey getCacheKey req =