@@ -1,142 +1,217 @@
1+-- | Description: ways to build a reified api from a servant description.
2+--
3+-- arguably this could be more general and be abstracted away from even relying on servant
4+-- but that's future work.
15
26{-# LANGUAGE AllowAmbiguousTypes #-}
37{-# LANGUAGE DataKinds #-}
48{-# LANGUAGE DerivingStrategies #-}
9+{-# LANGUAGE FlexibleContexts #-}
510{-# LANGUAGE FlexibleInstances #-}
11+{-# LANGUAGE GADTs #-}
612{-# LANGUAGE GeneralizedNewtypeDeriving #-}
713{-# LANGUAGE LambdaCase #-}
814{-# LANGUAGE PolyKinds #-}
915{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE StandaloneDeriving #-}
11−{-# LANGUAGE TupleSections #-}
1216{-# LANGUAGE TypeApplications #-}
1317{-# LANGUAGE TypeFamilies #-}
1418{-# LANGUAGE TypeOperators #-}
1519{-# LANGUAGE UndecidableInstances #-}
16−
20+{-# LANGUAGE CPP #-}
1721module Roboservant.Types.ReifiedApi where
1822
19−
20−import Control.Monad.Except (runExceptT)
21−import Data.Dynamic (Dynamic, toDyn)
22−import Data.Function ((&))
23−import Data.Typeable (TypeRep, Typeable, typeRep)
24−import GHC.TypeLits (Symbol)
23+import Data.Dynamic (Dynamic)
24+import Control.Exception(Exception)
25+import Data.List.NonEmpty (NonEmpty)
26+import Data.Typeable (Typeable)
27+import GHC.Generics ((:*:)(..))
28+import Roboservant.Types.Internal
29+import Roboservant.Types.Breakdown
30+import Roboservant.Types.BuildFrom
31+import Data.Kind(Type)
2532import Servant
2633import Servant.API.Modifiers(FoldRequired,FoldLenient)
27−import Roboservant.Types.FlattenServer
28−import Roboservant.Types.Breakdown
29−import Data.List.NonEmpty (NonEmpty)
30−
34+import GHC.TypeLits (Symbol)
35+import qualified Data.Text as T
36+import qualified Data.Vinyl as V
37+import qualified Data.Vinyl.Curry as V
38+import qualified Type.Reflection as R
3139
3240newtype ApiOffset = ApiOffset Int
33− deriving (Eq, Show)
41+ deriving (Eq, Show, Ord)
3442 deriving newtype (Enum, Num)
3543
36−type ReifiedEndpoint = ([TypeRep], NonEmpty Dynamic)
44+type TypedF = (:*:) R.TypeRep
3745
38−type ReifiedApi = [(ApiOffset, ReifiedEndpoint)]
46+newtype Argument a = Argument
47+ { getArgument :: Stash -> Maybe (StashValue a)
48+ }
3949
50+data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint
51+ { reArguments :: V.Rec (TypedF Argument) as
52+ , reEndpointFunc :: V.Curried as (IO (Either InteractionError (NonEmpty (Dynamic,Int))))
53+ }
4054
41−class ToReifiedApi (endpoints :: [*]) where
42− toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
55+instance Show ReifiedEndpoint where
56+ show _ = "lol"
4357
44−class ToReifiedEndpoint (endpoint :: *) where
45− toReifiedEndpoint :: Dynamic -> Proxy endpoint -> ReifiedEndpoint
58+class ( V.RecordToList (EndpointArgs endpoint)
59+ , V.RMap (EndpointArgs endpoint)
60+ ) => ToReifiedEndpoint (endpoint :: Type) where
61+ type EndpointArgs endpoint :: [Type]
62+ type EndpointRes endpoint :: Type
4663
47−instance ToReifiedApi '[] where
48− toReifiedApi NoEndpoints _ = []
64+ reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)
4965
50−instance
51− (Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)) =>
52− ToReifiedApi (endpoint : endpoints)
53− where
54− toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
55− (0,) (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))
56− : map
57− (\(n, x) -> (n + 1, x))
58− (toReifiedApi endpoints (Proxy @endpoints))
5966
60−class NormalizeFunction m where
61− type Normal m
62− normalize :: m -> Normal m
67+tagType :: Typeable a => f a -> TypedF f a
68+tagType = (R.typeRep :*:)
6369
64−instance NormalizeFunction x => NormalizeFunction (r -> x) where
65− type Normal (r -> x) = r -> Normal x
66− normalize = fmap normalize
70+data InteractionError = InteractionError
71+ { errorMessage :: T.Text
72+ , fatalError :: Bool
73+ }
74+ deriving Show
75+instance Exception InteractionError
6776
68−instance (Typeable x, Breakdown x) => NormalizeFunction (Handler x) where
69− type Normal (Handler x) = IO (Either ServerError (NonEmpty Dynamic))
70− normalize handler = (runExceptT . runHandler') handler >>= \case
71− Left serverError -> pure (Left serverError)
72− Right x -> pure $ Right $ breakdown x
7377
74−-- pure (Right (typeRep (Proxy @x), toDyn x))
7578
7679instance
7780 (Typeable responseType, Breakdown responseType) =>
7881 ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
7982 where
80− toReifiedEndpoint endpoint _ = id
81− ([], _ endpoint)
83+ type EndpointArgs (Verb method statusCode contentTypes responseType) = '[]
84+ type EndpointRes (Verb method statusCode contentTypes responseType) = responseType
85+ reifiedEndpointArguments = V.RNil
86+
87+instance ToReifiedEndpoint (NoContentVerb method)
88+ where
89+ type EndpointArgs (NoContentVerb method) = '[]
90+ type EndpointRes (NoContentVerb method) = NoContent
91+ reifiedEndpointArguments = V.RNil
8292
8393instance
8494 (ToReifiedEndpoint endpoint) =>
8595 ToReifiedEndpoint ((x :: Symbol) :> endpoint)
8696 where
87− toReifiedEndpoint endpoint _ =
88− toReifiedEndpoint endpoint (Proxy @endpoint)
97+ type EndpointArgs ((x :: Symbol) :> endpoint) = EndpointArgs endpoint
98+ type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint
99+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint
100+
101+instance
102+ (ToReifiedEndpoint endpoint) =>
103+ ToReifiedEndpoint (RemoteHost :> endpoint)
104+ where
105+ type EndpointArgs (RemoteHost :> endpoint) = EndpointArgs endpoint
106+ type EndpointRes (RemoteHost :> endpoint) = EndpointRes endpoint
107+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint
108+
109+
89110
90111instance
91112 (ToReifiedEndpoint endpoint) =>
92113 ToReifiedEndpoint (Description s :> endpoint)
93114 where
94− toReifiedEndpoint endpoint _ =
95− toReifiedEndpoint endpoint (Proxy @endpoint)
115+ type EndpointArgs (Description s :> endpoint) = EndpointArgs endpoint
116+ type EndpointRes (Description s :> endpoint) = EndpointRes endpoint
117+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint
96118
97119instance
98120 (ToReifiedEndpoint endpoint) =>
99121 ToReifiedEndpoint (Summary s :> endpoint)
100122 where
101− toReifiedEndpoint endpoint _ =
102− toReifiedEndpoint endpoint (Proxy @endpoint)
123+ type EndpointArgs (Summary s :> endpoint) = EndpointArgs endpoint
124+ type EndpointRes (Summary s :> endpoint) = EndpointRes endpoint
125+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint
103126
104127instance
105− (Typeable requestType, ToReifiedEndpoint endpoint) =>
128+ (Typeable requestType
129+ ,BuildFrom requestType
130+ ,ToReifiedEndpoint endpoint) =>
106131 ToReifiedEndpoint (QueryFlag name :> endpoint)
107132 where
108− toReifiedEndpoint endpoint _ =
109− toReifiedEndpoint endpoint (Proxy @endpoint)
110− & \(args, result, typeRepMap) -> (typeRep (Proxy @Bool) : args, result, typeRepMap)
133+ type EndpointArgs (QueryFlag name :> endpoint) = Bool ': EndpointArgs endpoint
134+ type EndpointRes (QueryFlag name :> endpoint) = EndpointRes endpoint
135+ reifiedEndpointArguments = tagType (Argument (buildFrom @Bool)) V.:& reifiedEndpointArguments @endpoint
136+
137+type IfLenient s mods t = If (FoldLenient mods) (Either s t) t
138+type IfRequired mods t = If (FoldRequired mods) t (Maybe t)
139+type IfRequiredLenient s mods t = IfRequired mods (IfLenient s mods t)
111140
112141instance
113− (Typeable (If (FoldRequired mods) paramType (Maybe paramType)), ToReifiedEndpoint endpoint, SBoolI (FoldRequired mods)) =>
142+ ( BuildFrom (IfRequiredLenient T.Text mods paramType)
143+ , ToReifiedEndpoint endpoint
144+ ) =>
114145 ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)
115146 where
116− toReifiedEndpoint endpoint _ =
117− toReifiedEndpoint endpoint (Proxy @endpoint)
118− & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldRequired mods) paramType (Maybe paramType))) : args, result, typeRepMap)
147+ type EndpointArgs (QueryParam' mods name paramType :> endpoint) = IfRequiredLenient T.Text mods paramType ': EndpointArgs endpoint
148+ type EndpointRes (QueryParam' mods name paramType :> endpoint) = EndpointRes endpoint
149+ reifiedEndpointArguments =
150+ tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods paramType)))
151+ V.:& reifiedEndpointArguments @endpoint
152+
119153
120154instance
121− (Typeable (If (FoldRequired mods) headerType (Maybe headerType)), ToReifiedEndpoint endpoint, SBoolI (FoldRequired mods)) =>
155+ ( BuildFrom paramType
156+ , ToReifiedEndpoint endpoint
157+ , Show paramType
158+ , Eq paramType
159+ ) =>
160+ ToReifiedEndpoint (QueryParams name paramType :> endpoint)
161+ where
162+ type EndpointArgs (QueryParams name paramType :> endpoint) = [paramType] ': EndpointArgs endpoint
163+ type EndpointRes (QueryParams name paramType :> endpoint) = EndpointRes endpoint
164+ reifiedEndpointArguments =
165+ tagType (Argument (buildFrom @[paramType]))
166+ V.:& reifiedEndpointArguments @endpoint
167+
168+
169+
170+
171+instance
172+ ( BuildFrom (IfRequiredLenient T.Text mods headerType)
173+ , ToReifiedEndpoint endpoint
174+ ) =>
122175 ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)
123176 where
124− toReifiedEndpoint endpoint _ =
125− toReifiedEndpoint endpoint (Proxy @endpoint)
126− & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldRequired mods) headerType (Maybe headerType))) : args, result, typeRepMap)
177+ type EndpointArgs (Header' mods headerName headerType :> endpoint) = IfRequiredLenient T.Text mods headerType ': EndpointArgs endpoint
178+ type EndpointRes (Header' mods headerName headerType :> endpoint) = EndpointRes endpoint
179+ reifiedEndpointArguments =
180+ tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))
181+ V.:& reifiedEndpointArguments @endpoint
127182
183+#if MIN_VERSION_servant(0,17,0)
128184instance
129− (Typeable captureType, ToReifiedEndpoint endpoint) =>
185+ ( BuildFrom (IfLenient String mods captureType)
186+ , ToReifiedEndpoint endpoint) =>
130187 ToReifiedEndpoint (Capture' mods name captureType :> endpoint)
131188 where
132− toReifiedEndpoint endpoint _ =
133− toReifiedEndpoint endpoint (Proxy @endpoint)
134− & \(args, result, typeRepMap) -> (typeRep (Proxy @captureType) : args, result, typeRepMap)
189+ type EndpointArgs (Capture' mods name captureType :> endpoint) = IfLenient String mods captureType ': EndpointArgs endpoint
190+ type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint
191+ reifiedEndpointArguments =
192+ tagType (Argument (buildFrom @(IfLenient String mods captureType)))
193+ V.:& reifiedEndpointArguments @endpoint
194+#else
195+instance
196+ ( BuildFrom captureType
197+ , ToReifiedEndpoint endpoint) =>
198+ ToReifiedEndpoint (Capture' mods name captureType :> endpoint)
199+ where
200+ type EndpointArgs (Capture' mods name captureType :> endpoint) = captureType ': EndpointArgs endpoint
201+ type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint
202+ reifiedEndpointArguments =
203+ tagType (Argument (buildFrom @(captureType)))
204+ V.:& reifiedEndpointArguments @endpoint
205+
206+#endif
135207
136208instance
137− (Typeable (If (FoldLenient mods) (Either String requestType) requestType), ToReifiedEndpoint endpoint, SBoolI (FoldLenient mods)) =>
209+ ( BuildFrom (IfLenient String mods requestType)
210+ , ToReifiedEndpoint endpoint) =>
138211 ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)
139212 where
140− toReifiedEndpoint endpoint _ =
141− toReifiedEndpoint endpoint (Proxy @endpoint)
142− & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldLenient mods) (Either String requestType) requestType)) : args, result, typeRepMap)
213+ type EndpointArgs (ReqBody' mods contentTypes requestType :> endpoint) = IfLenient String mods requestType ': EndpointArgs endpoint
214+ type EndpointRes (ReqBody' mods contentTypes requestType :> endpoint) = EndpointRes endpoint
215+ reifiedEndpointArguments =
216+ tagType (Argument (buildFrom @(IfLenient String mods requestType)))
217+ V.:& reifiedEndpointArguments @endpoint