@@ -17,47 +17,34 @@
1717{-# LANGUAGE DataKinds #-}
1818{-# LANGUAGE TypeOperators #-}
1919{-# LANGUAGE FlexibleInstances #-}
20−module Roboservant.Types.ReifiedApi.Server where
20+{-# LANGUAGE MultiParamTypeClasses #-}
21+module Roboservant.Types.ReifiedApi.Server(module Roboservant.Types.ReifiedApi.Server) where
2122
2223import Servant
23−import Servant.API.Modifiers(FoldRequired,FoldLenient)
2424
2525import Control.Monad.Except (runExceptT)
2626import Data.Bifunctor
2727import Data.Dynamic (Dynamic)
28−import Data.Kind
2928import Data.List.NonEmpty (NonEmpty)
3029import Data.Typeable (Typeable)
31−import GHC.TypeLits (Symbol)
3230import Roboservant.Types.Breakdown
33−import Roboservant.Types.BuildFrom
34−import Roboservant.Types.FlattenServer
3531import Roboservant.Types.ReifiedApi
3632
3733import qualified Data.Text as T
38−import qualified Data.Vinyl as V
3934import qualified Data.Vinyl.Curry as V
4035import Data.Hashable(Hashable)
4136
37+type ReifiedApi = [(ApiOffset, ReifiedEndpoint )]
4238
43−class ToReifiedApi (endpoints ) where
44− toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
45−
46−class ( V.RecordToList (EndpointArgs endpoint)
47− , V.RMap (EndpointArgs endpoint)
48− ) => ToReifiedEndpoint (endpoint :: *) where
49− type EndpointArgs endpoint :: [Type]
50− type EndpointRes endpoint :: Type
5139
52− reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)
40+class ToReifiedApi endpoints where
41+ toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
5342
5443instance ToReifiedApi '[] where
5544 toReifiedApi NoEndpoints _ = []
5645
5746instance
58− ( Typeable (EndpointRes endpoint)
59−
60− , NormalizeFunction (ServerT endpoint Handler)
47+ ( NormalizeFunction (ServerT endpoint Handler)
6148 , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either InteractionError (NonEmpty (Dynamic,Int))))
6249 , ToReifiedEndpoint endpoint
6350 , ToReifiedApi endpoints
@@ -73,13 +60,6 @@ instance
7360 : (map . first) (+1)
7461 (toReifiedApi endpoints (Proxy @endpoints))
7562
76−class NormalizeFunction m where
77− type Normal m
78− normalize :: m -> Normal m
79−
80−instance NormalizeFunction x => NormalizeFunction (r -> x) where
81− type Normal (r -> x) = r -> Normal x
82− normalize = fmap normalize
8363
8464instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (Handler x) where
8565 type Normal (Handler x) = IO (Either InteractionError (NonEmpty (Dynamic,Int)))
@@ -91,114 +71,45 @@ instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (Handler x)
9171 renderServerError = InteractionError . T.pack . show
9272 Right x -> pure $ Right $ breakdown x
9373
94−instance
95− (Typeable responseType, Breakdown responseType) =>
96− ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
97− where
98− type EndpointArgs (Verb method statusCode contentTypes responseType) = '[]
99− type EndpointRes (Verb method statusCode contentTypes responseType) = responseType
100− reifiedEndpointArguments = V.RNil
101−
102−instance
103− (ToReifiedEndpoint endpoint) =>
104− ToReifiedEndpoint ((x :: Symbol) :> endpoint)
105− where
106− type EndpointArgs ((x :: Symbol) :> endpoint) = EndpointArgs endpoint
107− type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint
108− reifiedEndpointArguments = reifiedEndpointArguments @endpoint
109−
110−instance
111− (ToReifiedEndpoint endpoint) =>
112− ToReifiedEndpoint (Description s :> endpoint)
113− where
114− type EndpointArgs (Description s :> endpoint) = EndpointArgs endpoint
115− type EndpointRes (Description s :> endpoint) = EndpointRes endpoint
116− reifiedEndpointArguments = reifiedEndpointArguments @endpoint
11774
118−instance
119− (ToReifiedEndpoint endpoint) =>
120− ToReifiedEndpoint (Summary s :> endpoint)
121− where
122− type EndpointArgs (Summary s :> endpoint) = EndpointArgs endpoint
123− type EndpointRes (Summary s :> endpoint) = EndpointRes endpoint
124− reifiedEndpointArguments = reifiedEndpointArguments @endpoint
75+-- case errHTTPCode serverError of
76+-- 500 -> throw serverError
77+-- _ ->
78+-- liftIO . logInfo . show $ ("ignoring non-500 error", serverError)
12579
126−instance
127− (Typeable requestType
128− ,BuildFrom requestType
129− ,ToReifiedEndpoint endpoint) =>
130− ToReifiedEndpoint (QueryFlag name :> endpoint)
131− where
132− type EndpointArgs (QueryFlag name :> endpoint) = Bool ': EndpointArgs endpoint
133− type EndpointRes (QueryFlag name :> endpoint) = EndpointRes endpoint
134− reifiedEndpointArguments = tagType (Argument (buildFrom @Bool)) V.:& reifiedEndpointArguments @endpoint
13580
136−type IfLenient s mods t = If (FoldLenient mods) (Either s t) t
137−type IfRequired mods t = If (FoldRequired mods) t (Maybe t)
138−type IfRequiredLenient s mods t = IfRequired mods (IfLenient s mods t)
81+data Bundled endpoints where
82+ -- AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
83+ AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
84+ NoEndpoints :: Bundled '[]
13985
140−instance
141− ( BuildFrom (IfRequiredLenient T.Text mods paramType)
142− , ToReifiedEndpoint endpoint
143− ) =>
144− ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)
145− where
146− type EndpointArgs (QueryParam' mods name paramType :> endpoint) = IfRequiredLenient T.Text mods paramType ': EndpointArgs endpoint
147− type EndpointRes (QueryParam' mods name paramType :> endpoint) = EndpointRes endpoint
148− reifiedEndpointArguments =
149− tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods paramType)))
150− V.:& reifiedEndpointArguments @endpoint
86+class FlattenServer api where
87+ flattenServer :: Server api -> Bundled (Endpoints api)
15188
15289instance
153− ( BuildFrom (IfRequiredLenient T.Text mods headerType)
154− , ToReifiedEndpoint endpoint
90+ ( FlattenServer api,
91+ Endpoints endpoint ~ '[endpoint]
15592 ) =>
156− ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)
157− where
158− type EndpointArgs (Header' mods headerName headerType :> endpoint) = IfRequiredLenient T.Text mods headerType ': EndpointArgs endpoint
159− type EndpointRes (Header' mods headerName headerType :> endpoint) = EndpointRes endpoint
160− reifiedEndpointArguments =
161− tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))
162− V.:& reifiedEndpointArguments @endpoint
163−
164−#if MIN_VERSION_servant(0,17,0)
165−instance
166− ( BuildFrom (IfLenient String mods captureType)
167− , ToReifiedEndpoint endpoint) =>
168− ToReifiedEndpoint (Capture' mods name captureType :> endpoint)
93+ FlattenServer (endpoint :<|> api)
16994 where
170− type EndpointArgs (Capture' mods name captureType :> endpoint) = IfLenient String mods captureType ': EndpointArgs endpoint
171− type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint
172− reifiedEndpointArguments =
173− tagType (Argument (buildFrom @(IfLenient String mods captureType)))
174− V.:& reifiedEndpointArguments @endpoint
175−#else
95+ flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
96+
17697instance
177− ( BuildFrom captureType
178− , ToReifiedEndpoint endpoint) =>
179− ToReifiedEndpoint (Capture' mods name captureType :> endpoint)
98+ (
99+ Endpoints api ~ '[api]
100+ ) =>
101+ FlattenServer (x :> api)
180102 where
181− type EndpointArgs (Capture' mods name captureType :> endpoint) = captureType ': EndpointArgs endpoint
182− type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint
183− reifiedEndpointArguments =
184− tagType (Argument (buildFrom @(captureType)))
185− V.:& reifiedEndpointArguments @endpoint
186−
187−#endif
103+ flattenServer server = server `AnEndpoint` NoEndpoints
188104
189−instance
190− ( BuildFrom (IfLenient String mods requestType)
191− , ToReifiedEndpoint endpoint) =>
192− ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)
105+instance FlattenServer (Verb method statusCode contentTypes responseType)
193106 where
194− type EndpointArgs (ReqBody' mods contentTypes requestType :> endpoint) = IfLenient String mods requestType ': EndpointArgs endpoint
195− type EndpointRes (ReqBody' mods contentTypes requestType :> endpoint) = EndpointRes endpoint
196− reifiedEndpointArguments =
197− tagType (Argument (buildFrom @(IfLenient String mods requestType)))
198− V.:& reifiedEndpointArguments @endpoint
107+ flattenServer server = server `AnEndpoint` NoEndpoints
199108
109+class NormalizeFunction m where
110+ type Normal m
111+ normalize :: m -> Normal m
200112
201−-- case errHTTPCode serverError of
202−-- 500 -> throw serverError
203−-- _ ->
204−-- liftIO . logInfo . show $ ("ignoring non-500 error", serverError)
113+instance NormalizeFunction x => NormalizeFunction (r -> x) where
114+ type Normal (r -> x) = r -> Normal x
115+ normalize = fmap normalize