Debug new route finder

Makefile

@@ -1,7 +1,7 @@
 .PHONY: build test run docs
 
 build:
-	stack build mig
+	stack build 
 
 test:
 	stack test

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
 

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

examples/mig-example-apps/package.yaml

@@ -66,7 +66,7 @@ dependencies:
   - aeson
   - random
   - time
-  - pretty-show
+  - pretty-simple
   - openapi3
   - safe
   - containers

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)

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)

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

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

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,40 +104,61 @@ 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
 
 {-| Converts server to server function. Server function can be used to implement low-level handlers
 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 =