From 96358a0a461a779cce606e2207516453c907af38 Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Tue, 24 Oct 2023 11:38:02 +0300 Subject: [PATCH 1/4] Implement TreeApi normal form --- Makefile | 2 +- mig/mig.cabal | 1 + mig/src/Mig/Core/Api/NormalForm/TreeApi.hs | 161 +++++++++++++++++++++ 3 files changed, 163 insertions(+), 1 deletion(-) create mode 100644 mig/src/Mig/Core/Api/NormalForm/TreeApi.hs diff --git a/Makefile b/Makefile index f599f5c..60e83d7 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ .PHONY: build test run docs build: - stack build + stack build mig test: stack test diff --git a/mig/mig.cabal b/mig/mig.cabal index 4625070..2e6f6ad 100644 --- a/mig/mig.cabal +++ b/mig/mig.cabal @@ -37,6 +37,7 @@ library exposed-modules: Mig.Core Mig.Core.Api + Mig.Core.Api.NormalForm.TreeApi Mig.Core.Class Mig.Core.Class.MediaType Mig.Core.Class.Monad diff --git a/mig/src/Mig/Core/Api/NormalForm/TreeApi.hs b/mig/src/Mig/Core/Api/NormalForm/TreeApi.hs new file mode 100644 index 0000000..cb757ca --- /dev/null +++ b/mig/src/Mig/Core/Api/NormalForm/TreeApi.hs @@ -0,0 +1,161 @@ +{-| Normal form where on handler search API is +traversed in tree like facion without retraversal of the paths. +-} +module Mig.Core.Api.NormalForm.TreeApi ( + TreeApi (..), + CaptureCase (..), + getPath, + toTreeApi, +) where + +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.Text (Text) + +import Mig.Core.Api (Api (..), Path (..), PathItem (..)) + +type CaptureMap = Map Text Text + +data TreeApi a + = WithStaticPath [Text] (TreeApi a) + | WithCapturePath [Text] (TreeApi a) + | SwitchApi (Maybe a) (Map Text (TreeApi a)) (Maybe (CaptureCase a)) + +data CaptureCase a = CaptureCase + { name :: Text + , api :: TreeApi a + } + +-- | Get a route by path, also extracts capture map +getPath :: [Text] -> TreeApi a -> Maybe (CaptureMap, a) +getPath = go mempty + where + go :: CaptureMap -> [Text] -> TreeApi a -> Maybe (CaptureMap, a) + go !captures !path !api = + case path of + [] -> + case api of + SwitchApi (Just result) _ _ -> Just (captures, result) + _ -> Nothing + headPath : tailPath -> + case api of + WithStaticPath static subApi -> onStaticPath captures (headPath : tailPath) static subApi + WithCapturePath names subApi -> onCapturePath captures (headPath : tailPath) names subApi + SwitchApi _ alternatives mCapture -> onSwitch captures headPath tailPath alternatives mCapture + + onStaticPath captures pathQuery staticPath subApi = do + rest <- checkPrefix staticPath pathQuery + go captures rest subApi + + onCapturePath captures pathQuery names subApi = do + (nextCaptures, nextPath) <- accumCapture captures names pathQuery + go nextCaptures nextPath subApi + + onSwitch captures headPath tailPath alternatives mCapture = + case Map.lookup headPath alternatives of + Just subApi -> go captures tailPath subApi + Nothing -> do + captureCase <- mCapture + go (Map.insert captureCase.name headPath captures) tailPath captureCase.api + +checkPrefix :: (Eq a) => [a] -> [a] -> Maybe [a] +checkPrefix (a : as) (b : bs) + | a == b = checkPrefix as bs + | otherwise = Nothing +checkPrefix [] b = Just b +checkPrefix _ _ = Nothing + +accumCapture :: CaptureMap -> [Text] -> [Text] -> Maybe (CaptureMap, [Text]) +accumCapture !captures !names !path = + case names of + [] -> Just (captures, path) + name : rest -> + case path of + pathHead : pathTail -> accumCapture (Map.insert name pathHead captures) rest pathTail + [] -> Nothing + +------------------------------------------------------------------------------------- +-- 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) + +data Alts a = Alts + { appends :: [(Text, Api a)] + , capture :: Maybe (Text, Api a) + , route :: Maybe a + } + +data AppendItem a + = StaticAppend Text (Api a) + | RouteAppend a + | CaptureAppend Text (Api a) + +collectAppends :: Api a -> [AppendItem a] +collectAppends = \case + Empty -> [] + HandleRoute a -> [RouteAppend a] + Append a b -> collectAppends a <> collectAppends b + WithPath (Path items) subApi -> case items of + [] -> collectAppends subApi + StaticPath item : [] -> pure $ StaticAppend item subApi + StaticPath item : rest -> pure $ StaticAppend item (WithPath (Path rest) subApi) + CapturePath item : [] -> pure $ CaptureAppend item subApi + CapturePath item : rest -> pure $ CaptureAppend item (WithPath (Path rest) subApi) + +orderAppends :: [AppendItem a] -> Alts a +orderAppends items = + Alts + { appends = mapMaybe toAppend items + , capture = List.firstJust toCapture items + , route = List.firstJust toRoute items + } + where + toAppend = \case + StaticAppend name api -> Just (name, api) + _ -> Nothing + + toCapture = \case + CaptureAppend name api -> Just (name, api) + _ -> Nothing + + toRoute = \case + RouteAppend route -> Just route + _ -> Nothing + +fromAlts :: Alts a -> TreeApi a +fromAlts alts = + SwitchApi alts.route (fmap toTreeApi $ Map.fromList alts.appends) (fmap toCaptureCase alts.capture) + where + toCaptureCase (name, api) = CaptureCase name (toTreeApi api) + +data PathPrefix + = StaticPrefix [Text] Path + | CapturePrefix [Text] Path + +fromPathPrefix :: Path -> Maybe PathPrefix +fromPathPrefix (Path items) = case items of + [] -> Nothing + StaticPath item : rest -> Just (accumStatics [item] rest) + CapturePath item : rest -> Just (accumCaptures [item] rest) + where + accumStatics res rest = + case rest of + StaticPath item : nextRest -> accumStatics (item : res) nextRest + _ -> StaticPrefix (List.reverse res) (Path rest) + + accumCaptures res rest = + case rest of + CapturePath item : nextRest -> accumCaptures (item : res) nextRest + _ -> CapturePrefix (List.reverse res) (Path rest) From ce0bd6f82a9e0f9a458e6748576dd878a39609a7 Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Tue, 24 Oct 2023 13:08:20 +0300 Subject: [PATCH 2/4] 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 = From d7089f6d3b59f2a89ab63033048db7e2d4afb17e Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Tue, 24 Oct 2023 13:19:24 +0300 Subject: [PATCH 3/4] Re-export find route algorithm --- mig-server/src/Mig.hs | 1 + mig-server/src/Mig/Server/Warp.hs | 1 + 2 files changed, 2 insertions(+) diff --git a/mig-server/src/Mig.hs b/mig-server/src/Mig.hs index b46eec6..1d37290 100644 --- a/mig-server/src/Mig.hs +++ b/mig-server/src/Mig.hs @@ -111,6 +111,7 @@ module Mig ( runServer, runServer', ServerConfig (..), + FindRouteType (..), CacheConfig (..), toApplication, diff --git a/mig-server/src/Mig/Server/Warp.hs b/mig-server/src/Mig/Server/Warp.hs index 4dff573..05fddf7 100644 --- a/mig-server/src/Mig/Server/Warp.hs +++ b/mig-server/src/Mig/Server/Warp.hs @@ -3,6 +3,7 @@ module Mig.Server.Warp ( runServer, runServer', ServerConfig (..), + FindRouteType (..), CacheConfig (..), ) where From 8c30d45757ce2f4191016b1403b5fc05bb8f55c5 Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Tue, 24 Oct 2023 13:23:24 +0300 Subject: [PATCH 4/4] Instance default for ServerConfig --- mig-wai/mig-wai.cabal | 40 ++++++++++++++++++++--------------- mig-wai/package.yaml | 1 + mig-wai/src/Mig/Server/Wai.hs | 4 ++++ 3 files changed, 28 insertions(+), 17 deletions(-) diff --git a/mig-wai/mig-wai.cabal b/mig-wai/mig-wai.cabal index f6c7c20..8668901 100644 --- a/mig-wai/mig-wai.cabal +++ b/mig-wai/mig-wai.cabal @@ -1,4 +1,4 @@ -cabal-version: 1.12 +cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.35.2. -- @@ -7,7 +7,9 @@ cabal-version: 1.12 name: mig-wai version: 0.1.0.0 synopsis: Render mig-servers as wai-applications -description: Please see the README on GitHub at +description: + Please see the README on GitHub at + category: Web homepage: https://github.com/githubuser/mig-wai#readme bug-reports: https://github.com/githubuser/mig-wai/issues @@ -16,32 +18,36 @@ maintainer: example@example.com copyright: 2023 Author name here license: BSD3 build-type: Simple -extra-source-files: - README.md +extra-source-files: README.md source-repository head - type: git + type: git location: https://github.com/githubuser/mig-wai library - exposed-modules: - Mig.Server.Wai - other-modules: - Paths_mig_wai - hs-source-dirs: - src + exposed-modules: Mig.Server.Wai + other-modules: Paths_mig_wai + hs-source-dirs: src default-extensions: - OverloadedRecordDot - DuplicateRecordFields - OverloadedStrings - LambdaCase - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wunused-packages + DuplicateRecordFields + LambdaCase + OverloadedRecordDot + OverloadedStrings + + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wmissing-export-lists + -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + -Wunused-packages + build-depends: base >=4.7 && <5 , bytestring , containers + , data-default , exceptions , mig , text , wai - default-language: GHC2021 + + default-language: GHC2021 diff --git a/mig-wai/package.yaml b/mig-wai/package.yaml index e0f3078..ed0d541 100644 --- a/mig-wai/package.yaml +++ b/mig-wai/package.yaml @@ -34,6 +34,7 @@ dependencies: - text - wai - exceptions +- data-default ghc-options: - -Wall diff --git a/mig-wai/src/Mig/Server/Wai.hs b/mig-wai/src/Mig/Server/Wai.hs index 8dd9e33..5852745 100644 --- a/mig-wai/src/Mig/Server/Wai.hs +++ b/mig-wai/src/Mig/Server/Wai.hs @@ -9,6 +9,7 @@ module Mig.Server.Wai ( import Control.Monad.Catch import Data.ByteString qualified as B import Data.ByteString.Lazy qualified as BL +import Data.Default import Data.Foldable import Data.IORef import Data.Map.Strict qualified as Map @@ -32,6 +33,9 @@ data ServerConfig = ServerConfig , findRoute :: FindRouteType } +instance Default ServerConfig where + def = ServerConfig Nothing Nothing TreeFinder + -- | Algorithm to find route handlers by path data FindRouteType = TreeFinder | PlainFinder