@@ -0,0 +1,204 @@
1+{-# LANGUAGE RankNTypes #-}
2+{-# LANGUAGE TypeApplications #-}
3+{-# LANGUAGE PolyKinds #-}
4+{-# LANGUAGE AllowAmbiguousTypes #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE LambdaCase #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE RecordWildCards #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TupleSections #-}
13+{-# LANGUAGE TypeApplications #-}
14+{-# LANGUAGE TypeFamilies #-}
15+{-# LANGUAGE UndecidableInstances #-}
16+{-# LANGUAGE CPP #-}
17+{-# LANGUAGE DataKinds #-}
18+{-# LANGUAGE TypeOperators #-}
19+{-# LANGUAGE FlexibleInstances #-}
20+module Roboservant.Types.ReifiedApi.Server where
21+
22+import Servant
23+import Servant.API.Modifiers(FoldRequired,FoldLenient)
24+
25+import Control.Monad.Except (runExceptT)
26+import Data.Bifunctor
27+import Data.Dynamic (Dynamic)
28+import Data.Kind
29+import Data.List.NonEmpty (NonEmpty)
30+import Data.Typeable (Typeable)
31+import GHC.TypeLits (Symbol)
32+import Roboservant.Types.Breakdown
33+import Roboservant.Types.BuildFrom
34+import Roboservant.Types.FlattenServer
35+import Roboservant.Types.ReifiedApi
36+
37+import qualified Data.Text as T
38+import qualified Data.Vinyl as V
39+import qualified Data.Vinyl.Curry as V
40+import Data.Hashable(Hashable)
41+
42+
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
51+
52+ reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)
53+
54+instance ToReifiedApi '[] where
55+ toReifiedApi NoEndpoints _ = []
56+
57+instance
58+ ( Typeable (EndpointRes endpoint)
59+
60+ , NormalizeFunction (ServerT endpoint Handler)
61+ , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either InteractionError (NonEmpty (Dynamic,Int))))
62+ , ToReifiedEndpoint endpoint
63+ , ToReifiedApi endpoints
64+ ) =>
65+ ToReifiedApi (endpoint : endpoints)
66+ where
67+ toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
68+ (0, ReifiedEndpoint
69+ { reArguments = reifiedEndpointArguments @endpoint
70+ , reEndpointFunc = normalize endpoint
71+ }
72+ )
73+ : (map . first) (+1)
74+ (toReifiedApi endpoints (Proxy @endpoints))
75+
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
83+
84+instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (Handler x) where
85+ type Normal (Handler x) = IO (Either InteractionError (NonEmpty (Dynamic,Int)))
86+ normalize handler = (runExceptT . runHandler') handler >>= \case
87+ Left serverError -> pure (Left (renderServerError serverError))
88+ where
89+ -- | TODO improve this
90+ renderServerError :: ServerError -> InteractionError
91+ renderServerError = InteractionError . T.pack . show
92+ Right x -> pure $ Right $ breakdown x
93+
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
117+
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
125+
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
135+
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)
139+
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
151+
152+instance
153+ ( BuildFrom (IfRequiredLenient T.Text mods headerType)
154+ , ToReifiedEndpoint endpoint
155+ ) =>
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)
169+ 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
176+instance
177+ ( BuildFrom captureType
178+ , ToReifiedEndpoint endpoint) =>
179+ ToReifiedEndpoint (Capture' mods name captureType :> endpoint)
180+ 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
188+
189+instance
190+ ( BuildFrom (IfLenient String mods requestType)
191+ , ToReifiedEndpoint endpoint) =>
192+ ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)
193+ 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
199+
200+
201+-- case errHTTPCode serverError of
202+-- 500 -> throw serverError
203+-- _ ->
204+-- liftIO . logInfo . show $ ("ignoring non-500 error", serverError)