Merge pull request #52 from anton-k/api-tree-normal-form

Api tree normal form
anton-k · Oct 24, 2023 · e8978fd · e8978fd
2 parents 1c7ac5a + 8c30d45
commit e8978fd
Show file tree

Hide file tree

Showing 13 changed files with 288 additions and 48 deletions.
diff --git a/Makefile b/Makefile
@@ -1,7 +1,7 @@
 .PHONY: build test run docs
 
 build:
-	stack build
+	stack build 
 
 test:
 	stack test

diff --git 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
@@ -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
@@ -66,7 +66,7 @@ dependencies:
   - aeson
   - random
   - time
-  - pretty-show
+  - pretty-simple
   - openapi3
   - safe
   - containers

diff --git 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
@@ -3,6 +3,7 @@ module Mig.Server.Warp (
   runServer,
   runServer',
   ServerConfig (..),
+  FindRouteType (..),
   CacheConfig (..),
 ) where
 
@@ -14,7 +15,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/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 <https://github.com/githubuser/mig-wai#readme>
+description:
+  Please see the README on GitHub at <https://github.com/githubuser/mig-wai#readme>
+
 category:           Web
 homepage:           https://github.com/githubuser/mig-wai#readme
 bug-reports:        https://github.com/githubuser/mig-wai/issues
@@ -16,32 +18,36 @@ maintainer:         [email protected]
 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
@@ -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
@@ -1,13 +1,15 @@
 -- | Converts mig server to WAI-application.
 module Mig.Server.Wai (
   ServerConfig (..),
+  FindRouteType (..),
   Kilobytes,
   toApplication,
 ) where
 
 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
@@ -28,17 +30,30 @@ data ServerConfig = ServerConfig
   { maxBodySize :: Maybe Kilobytes
   -- ^ limit the request body size. By default it is unlimited.
   , cache :: Maybe CacheConfig
+  , findRoute :: FindRouteType
   }
 
+instance Default ServerConfig where
+  def = ServerConfig Nothing Nothing TreeFinder
+
+-- | 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 +62,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/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.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