Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Api tree normal form #52

Merged
merged 4 commits into from
Oct 24, 2023
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion Makefile
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
.PHONY: build test run docs

build:
stack build
stack build

test:
stack test
Expand Down
2 changes: 1 addition & 1 deletion examples/mig-example-apps/RouteArgs/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
16 changes: 8 additions & 8 deletions examples/mig-example-apps/mig-example-apps.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -76,7 +76,7 @@ executable counter-client-mig-example-app
, mig-swagger-ui
, mtl
, openapi3
, pretty-show
, pretty-simple
, random
, safe
, text
Expand Down Expand Up @@ -127,7 +127,7 @@ executable counter-mig-example-app
, mig-swagger-ui
, mtl
, openapi3
, pretty-show
, pretty-simple
, random
, safe
, text
Expand Down Expand Up @@ -178,7 +178,7 @@ executable hello-world-client-mig-example-app
, mig-server
, mig-swagger-ui
, openapi3
, pretty-show
, pretty-simple
, random
, safe
, text
Expand Down Expand Up @@ -228,7 +228,7 @@ executable hello-world-mig-example-app
, mig-server
, mig-swagger-ui
, openapi3
, pretty-show
, pretty-simple
, random
, safe
, text
Expand Down Expand Up @@ -291,7 +291,7 @@ executable html-mig-example-app
, mig-server
, mig-swagger-ui
, openapi3
, pretty-show
, pretty-simple
, random
, safe
, text
Expand Down Expand Up @@ -351,7 +351,7 @@ executable json-api-mig-example-app
, mig-server
, mig-swagger-ui
, openapi3
, pretty-show
, pretty-simple
, random
, safe
, text
Expand Down Expand Up @@ -403,7 +403,7 @@ executable route-args-client-mig-example-app
, mig-server
, mig-swagger-ui
, openapi3
, pretty-show
, pretty-simple
, random
, safe
, text
Expand Down Expand Up @@ -453,7 +453,7 @@ executable route-args-mig-example-app
, mig-server
, mig-swagger-ui
, openapi3
, pretty-show
, pretty-simple
, random
, safe
, text
Expand Down
2 changes: 1 addition & 1 deletion examples/mig-example-apps/package.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -66,7 +66,7 @@ dependencies:
- aeson
- random
- time
- pretty-show
- pretty-simple
- openapi3
- safe
- containers
Expand Down
1 change: 1 addition & 0 deletions mig-server/src/Mig.hs
Original file line number Diff line number Diff line change
Expand Up @@ -111,6 +111,7 @@ module Mig (
runServer,
runServer',
ServerConfig (..),
FindRouteType (..),
CacheConfig (..),
toApplication,

Expand Down
3 changes: 2 additions & 1 deletion mig-server/src/Mig/Server/Warp.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@ module Mig.Server.Warp (
runServer,
runServer',
ServerConfig (..),
FindRouteType (..),
CacheConfig (..),
) where

Expand All @@ -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)
40 changes: 23 additions & 17 deletions mig-wai/mig-wai.cabal
Original file line number Diff line number Diff line change
@@ -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.
--
Expand All @@ -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
Expand All @@ -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
1 change: 1 addition & 0 deletions mig-wai/package.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -34,6 +34,7 @@ dependencies:
- text
- wai
- exceptions
- data-default

ghc-options:
- -Wall
Expand Down
31 changes: 23 additions & 8 deletions mig-wai/src/Mig/Server/Wai.hs
Original file line number Diff line number Diff line change
@@ -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
Expand All @@ -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)
Expand All @@ -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)
Expand Down
1 change: 1 addition & 0 deletions mig/mig.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
6 changes: 3 additions & 3 deletions mig/src/Mig/Core/Api.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down
Loading