From 4df427f2f39d12f637509755132e134baf32300d Mon Sep 17 00:00:00 2001 From: ambroslins Date: Tue, 17 Oct 2023 22:27:02 +0200 Subject: [PATCH 1/2] Replace most ToServer instances with a single overlappable instance We can construct a server from every route. However this requires `UndecidableInstances` and a `OVERLAPPABLE` pragma. --- mig/src/Mig/Core/Class/Server.hs | 31 ++++--------------------------- 1 file changed, 4 insertions(+), 27 deletions(-) diff --git a/mig/src/Mig/Core/Class/Server.hs b/mig/src/Mig/Core/Class/Server.hs index 1a6ff50..a79b1fb 100644 --- a/mig/src/Mig/Core/Class/Server.hs +++ b/mig/src/Mig/Core/Class/Server.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE UndecidableInstances #-} + -- | To server class module Mig.Core.Class.Server ( (/.), @@ -11,18 +13,13 @@ module Mig.Core.Class.Server ( import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.Reader import Data.Kind -import Data.OpenApi (ToParamSchema, ToSchema) import Data.Text (Text) -import GHC.TypeLits import Mig.Core.Api qualified as Api -import Mig.Core.Class.MediaType (FromReqBody (..)) import Mig.Core.Class.Monad -import Mig.Core.Class.Response (IsResp) import Mig.Core.Class.Route import Mig.Core.Server (Server (..), mapServerFun) import Mig.Core.ServerFun (ServerFun) import Mig.Core.Types -import Web.HttpApiData infixr 4 /. @@ -66,28 +63,8 @@ instance ToServer (Server m) where instance (ToServer a) => ToServer [a] where toServer = foldMap toServer --- outputs -instance (MonadIO m, IsResp a, IsMethod method) => ToServer (Send method m a) where - toServer a = Server $ Api.HandleRoute (toRoute a) - --- inputs - -instance (ToSchema a, FromReqBody media a, ToRoute b) => ToServer (Body media a -> b) where - toServer a = Server $ Api.HandleRoute (toRoute a) - -instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToServer (Query sym a -> b) where - toServer a = Server $ Api.HandleRoute (toRoute a) - -instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToServer (Optional sym a -> b) where - toServer a = Server $ Api.HandleRoute (toRoute a) - -instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToServer (Capture sym a -> b) where - toServer a = Server $ Api.HandleRoute (toRoute a) - -instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToServer (Header sym a -> b) where - toServer a = Server $ Api.HandleRoute (toRoute a) - -instance (ToRoute b) => ToServer (PathInfo -> b) where +-- routes +instance {-# OVERLAPPABLE #-} (ToRoute a) => ToServer a where toServer a = Server $ Api.HandleRoute (toRoute a) ------------------------------------------------------------------------------------- From 601f2b8085daad791e2cbe99d48ee637737fc12a Mon Sep 17 00:00:00 2001 From: ambroslins Date: Thu, 19 Oct 2023 13:13:06 +0200 Subject: [PATCH 2/2] Remove `ToServer` instance for json body --- mig-extra/src/Mig/Extra/Server/Json.hs | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/mig-extra/src/Mig/Extra/Server/Json.hs b/mig-extra/src/Mig/Extra/Server/Json.hs index 212d43e..a37647c 100644 --- a/mig-extra/src/Mig/Extra/Server/Json.hs +++ b/mig-extra/src/Mig/Extra/Server/Json.hs @@ -21,7 +21,8 @@ module Mig.Extra.Server.Json ( -- * re-exports module X, -) where +) +where import Mig.Client (FromClient (..), ToClient (..)) import Mig.Core ( @@ -57,11 +58,6 @@ instance (ToSchema a, FromJSON a, ToRoute b) => ToRoute (Body a -> b) where (toRouteFun :: ((Core.Body Json a -> b) -> ServerFun (Core.MonadOf b))) (\(Core.Body a) -> f (Body a)) -instance (ToSchema a, FromJSON a, ToRoute b) => ToServer (Body a -> b) where - toServer f = - (toServer :: ((Core.Body Json a -> b) -> Server (Core.MonadOf b))) - (\(Core.Body a) -> f (Body a)) - instance (FromJSON a, ToSchema a, ToPlugin b) => ToPlugin (Body a -> b) where toPluginInfo = toPluginInfo @(Core.Body Json a -> b)