@@ -1,140 +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−
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
2939
3040newtype ApiOffset = ApiOffset Int
31− deriving (Eq, Show)
41+ deriving (Eq, Show, Ord)
3242 deriving newtype (Enum, Num)
3343
34−type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)
44+type TypedF = (:*:) R.TypeRep
3545
36−type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]
46+newtype Argument a = Argument
47+ { getArgument :: Stash -> Maybe (StashValue a)
48+ }
3749
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+ }
3854
39−class ToReifiedApi (endpoints :: [*]) where
40− toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
55+instance Show ReifiedEndpoint where
56+ show _ = "lol"
4157
42−class ToReifiedEndpoint (endpoint :: *) where
43− 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
63+
64+ reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)
65+
66+
67+tagType :: Typeable a => f a -> TypedF f a
68+tagType = (R.typeRep :*:)
69+
70+data InteractionError = InteractionError
71+ { errorMessage :: T.Text
72+ , fatalError :: Bool
73+ }
74+ deriving Show
75+instance Exception InteractionError
4476
45−instance ToReifiedApi '[] where
46− toReifiedApi NoEndpoints _ = []
4777
48−instance
49− (Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)) =>
50− ToReifiedApi (endpoint : endpoints)
51− where
52− toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
53− withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))
54− : map
55− (\(n, x, y, z) -> (n + 1, x, y, z))
56− (toReifiedApi endpoints (Proxy @endpoints))
57− where
58− withOffset (x, y, z) = (0, x, y, z)
59−
60−class NormalizeFunction m where
61− type Normal m
62− normalize :: m -> Normal m
63−
64−instance NormalizeFunction x => NormalizeFunction (r -> x) where
65− type Normal (r -> x) = r -> Normal x
66− normalize = fmap normalize
67−
68−instance Typeable x => NormalizeFunction (Handler x) where
69− type Normal (Handler x) = IO (Either ServerError (TypeRep, Dynamic))
70− normalize handler = (runExceptT . runHandler') handler >>= \case
71− Left serverError -> pure (Left serverError)
72− Right x -> pure (Right (typeRep (Proxy @x), toDyn x))
7378
7479instance
75− Typeable responseType =>
80+ (Typeable responseType, Breakdown responseType) =>
7681 ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
7782 where
78− toReifiedEndpoint endpoint _ =
79− ([], typeRep (Proxy @responseType), 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
8092
8193instance
8294 (ToReifiedEndpoint endpoint) =>
8395 ToReifiedEndpoint ((x :: Symbol) :> endpoint)
8496 where
85− toReifiedEndpoint endpoint _ =
86− 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+
87110
88111instance
89112 (ToReifiedEndpoint endpoint) =>
90113 ToReifiedEndpoint (Description s :> endpoint)
91114 where
92− toReifiedEndpoint endpoint _ =
93− toReifiedEndpoint endpoint (Proxy @endpoint)
115+ type EndpointArgs (Description s :> endpoint) = EndpointArgs endpoint
116+ type EndpointRes (Description s :> endpoint) = EndpointRes endpoint
117+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint
94118
95119instance
96120 (ToReifiedEndpoint endpoint) =>
97121 ToReifiedEndpoint (Summary s :> endpoint)
98122 where
99− toReifiedEndpoint endpoint _ =
100− toReifiedEndpoint endpoint (Proxy @endpoint)
123+ type EndpointArgs (Summary s :> endpoint) = EndpointArgs endpoint
124+ type EndpointRes (Summary s :> endpoint) = EndpointRes endpoint
125+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint
101126
102127instance
103− (Typeable requestType, ToReifiedEndpoint endpoint) =>
128+ (Typeable requestType
129+ ,BuildFrom requestType
130+ ,ToReifiedEndpoint endpoint) =>
104131 ToReifiedEndpoint (QueryFlag name :> endpoint)
105132 where
106− toReifiedEndpoint endpoint _ =
107− toReifiedEndpoint endpoint (Proxy @endpoint)
108− & \(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)
109140
110141instance
111− (Typeable (If (FoldRequired mods) paramType (Maybe paramType)), ToReifiedEndpoint endpoint, SBoolI (FoldRequired mods)) =>
142+ ( BuildFrom (IfRequiredLenient T.Text mods paramType)
143+ , ToReifiedEndpoint endpoint
144+ ) =>
112145 ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)
113146 where
114− toReifiedEndpoint endpoint _ =
115− toReifiedEndpoint endpoint (Proxy @endpoint)
116− & \(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+
117153
118154instance
119− (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+ ) =>
120175 ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)
121176 where
122− toReifiedEndpoint endpoint _ =
123− toReifiedEndpoint endpoint (Proxy @endpoint)
124− & \(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
125182
183+#if MIN_VERSION_servant(0,17,0)
126184instance
127− (Typeable captureType, ToReifiedEndpoint endpoint) =>
185+ ( BuildFrom (IfLenient String mods captureType)
186+ , ToReifiedEndpoint endpoint) =>
128187 ToReifiedEndpoint (Capture' mods name captureType :> endpoint)
129188 where
130− toReifiedEndpoint endpoint _ =
131− toReifiedEndpoint endpoint (Proxy @endpoint)
132− & \(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
133207
134208instance
135− (Typeable (If (FoldLenient mods) (Either String requestType) requestType), ToReifiedEndpoint endpoint, SBoolI (FoldLenient mods)) =>
209+ ( BuildFrom (IfLenient String mods requestType)
210+ , ToReifiedEndpoint endpoint) =>
136211 ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)
137212 where
138− toReifiedEndpoint endpoint _ =
139− toReifiedEndpoint endpoint (Proxy @endpoint)
140− & \(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