@@ -1,3 +1,9 @@
1+{-# LANGUAGE UndecidableInstances #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE PolyKinds #-}
5+{-# LANGUAGE TypeApplications #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
17{-# LANGUAGE AllowAmbiguousTypes #-}
28{-# LANGUAGE DataKinds #-}
39{-# LANGUAGE DeriveAnyClass #-}
@@ -29,6 +35,10 @@ import Control.Arrow (second)
2935--import Test.QuickCheck (Property)
3036-- import Test.StateMachine
3137
38+import Type.Reflection (SomeTypeRep)
39+import Servant.API.Flatten (Flat)
40+import GHC.TypeLits (Nat, Symbol)
41+import Data.Function ((&))
3242import Control.Concurrent (forkIO)
3343import Control.Monad ((<=<))
3444import Control.Monad.IO.Class
@@ -47,6 +57,7 @@ import Debug.Trace (traceM, traceShowM)
4757import GHC.Generics (Generic)
4858import GHC.Generics
4959import GHC.IORef (readIORef)
60+import Control.Monad.Except (runExceptT)
5061import Hedgehog
5162import Hedgehog
5263import qualified Hedgehog.Gen as Gen
@@ -94,8 +105,95 @@ data State v
94105 { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v))
95106 }
96107
108+class FlattenServer api where
109+ flattenServer :: Server api -> Bundled (Endpoints api)
110+
111+instance
112+ ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api)
113+ , Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api)
114+ , FlattenServer api
115+ ) => FlattenServer (endpoint :<|> api) where
116+ flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
117+
118+instance
119+ ( HasServer (x :> api) '[]
120+ , Endpoints (x :> api) ~ '[x :> api]
121+ ) => FlattenServer (x :> api) where
122+ flattenServer server = server `AnEndpoint` NoEndpoints
123+
124+instance
125+ ( HasServer (Verb method statusCode contentTypes responseType) '[],
126+ Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType]
127+ ) => FlattenServer (Verb method statusCode contentTypes responseType) where
128+ flattenServer server = server `AnEndpoint` NoEndpoints
129+
130+type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)
131+
97132type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]
98133
134+data Bundled endpoints where
135+ AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
136+ NoEndpoints :: Bundled '[]
137+
138+class ToReifiedApi (endpoints :: [*]) where
139+ toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
140+
141+class ToReifiedEndpoint (endpoint :: *) where
142+ toReifiedEndpoint :: Dynamic -> Proxy endpoint -> ReifiedEndpoint
143+
144+instance ToReifiedApi '[] where
145+ toReifiedApi NoEndpoints _ = []
146+
147+instance (Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler))
148+ => ToReifiedApi (endpoint : endpoints)
149+ where
150+ toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
151+ withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))
152+ : map (\(n, x, y, z) -> (n + 1, x, y, z))
153+ (toReifiedApi endpoints (Proxy @endpoints))
154+ where
155+ withOffset (x, y, z) = (0, x, y, z)
156+
157+class NormalizeFunction m where
158+ type Normal m
159+ normalize :: m -> Normal m
160+
161+instance NormalizeFunction x => NormalizeFunction (r -> x) where
162+ type Normal (r -> x) = r -> Normal x
163+ normalize = fmap normalize
164+
165+instance Typeable x => NormalizeFunction (Handler x) where
166+ type Normal (Handler x) = IO (Either ServerError (TypeRep, Dynamic))
167+ normalize handler = (runExceptT . runHandler') handler >>= \case
168+ Left serverError -> pure (Left serverError)
169+ Right x -> pure (Right (typeRep (Proxy @x), toDyn x))
170+
171+instance Typeable responseType
172+ => ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
173+ where
174+ toReifiedEndpoint endpoint _ =
175+ ([], typeRep (Proxy @responseType), endpoint)
176+
177+instance (ToReifiedEndpoint endpoint)
178+ => ToReifiedEndpoint ((x :: Symbol) :> endpoint)
179+ where
180+ toReifiedEndpoint endpoint _ =
181+ toReifiedEndpoint endpoint (Proxy @endpoint)
182+
183+instance (Typeable requestType, ToReifiedEndpoint endpoint)
184+ => ToReifiedEndpoint (Capture name requestType :> endpoint)
185+ where
186+ toReifiedEndpoint endpoint _ =
187+ toReifiedEndpoint endpoint (Proxy @endpoint)
188+ & \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
189+
190+instance (Typeable requestType, ToReifiedEndpoint endpoint)
191+ => ToReifiedEndpoint (ReqBody contentTypes requestType :> endpoint)
192+ where
193+ toReifiedEndpoint endpoint _ =
194+ toReifiedEndpoint endpoint (Proxy @endpoint)
195+ & \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
196+
99197newtype ApiOffset = ApiOffset Int
100198 deriving (Eq, Show)
101199 deriving newtype (Enum, Num)
@@ -156,8 +254,10 @@ callEndpoint staticRoutes =
156254 Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
157255 Just (f') -> do
158256 case fromDynamic f' of
159− Nothing -> error "failed on casting final function"
160− Just f -> liftIO f >>= newIORef -- >>= either (const $ error "blah") pure
257+ Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
258+ Just f -> liftIO f >>= \case
259+ Left (serverError :: ServerError) -> error (show serverError)
260+ Right (typeRep :: SomeTypeRep, (dyn :: Dynamic)) -> newIORef dyn
161261 in Command
162262 gen
163263 execute
@@ -190,7 +290,7 @@ prop_sm_sequential reifiedApi = do
190290 executeSequential initialState actions
191291
192292newtype Foo = Foo Int
193− deriving (Generic, Eq, Show)
293+ deriving (Generic, Eq, Show, Typeable)
194294 deriving newtype (FromHttpApiData, ToHttpApiData)
195295
196296instance ToJSON Foo
@@ -219,6 +319,9 @@ fooServer =
219319 :<|> combine
220320 :<|> eliminate
221321
322+bundledFooServer :: Bundled (Endpoints FooApi)
323+bundledFooServer = flattenServer @FooApi fooServer
324+
222325runServer :: IO ()
223326runServer = do
224327 let port = 3000
@@ -235,44 +338,5 @@ introC :<|> combineC :<|> eliminateC = Servant.Client.client fooApi
235338
236339tests :: IO Bool
237340tests = do
238− withServantServer fooApi (pure fooServer) $ \burl -> do
239− manager <- newManager defaultManagerSettings
240− let clientEnv = mkClientEnv manager burl
241− -- faking this out for now.
242− footype = typeOf Foo
243− handleError :: forall a b m. (Show b, Applicative m) => (Either b a) -> m a
244− handleError = either (error . show) pure
245− reifiedApi =
246− [ (ApiOffset 0, [], footype, toDyn $ toDyn <$> (runClientM introC clientEnv >>= handleError)),
247− (ApiOffset 1, [footype, footype], footype, toDyn $ \f1 f2 -> toDyn <$> (runClientM (combineC f1 f2) clientEnv >>= handleError)),
248− (ApiOffset 2, [footype], (typeOf ()), toDyn $ \f -> toDyn <$> (runClientM (eliminateC f) clientEnv >>= handleError))
249− ]
250− -- type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]
251− checkParallel $ Group "props" [("aprop", prop_sm_sequential reifiedApi)]
252−
253−-- | Start a servant application on an open port, run the provided function,
254−-- then stop the application.
255−--
256−-- /Since 0.0.0.0/
257−withServantServer ::
258− HasServer a '[] =>
259− Proxy a ->
260− IO (Server a) ->
261− (BaseUrl -> IO r) ->
262− IO r
263−withServantServer api = withServantServerAndContext api EmptyContext
264−
265−-- | Like 'withServantServer', but allows passing in a 'Context' to the
266−-- application.
267−--
268−-- /Since 0.0.0.0/
269−withServantServerAndContext ::
270− (HasServer a ctx) =>
271− Proxy a ->
272− Context ctx ->
273− IO (Server a) ->
274− (BaseUrl -> IO r) ->
275− IO r
276−withServantServerAndContext api ctx server t =
277− withApplication (return . serveWithContext api ctx =<< server) $ \port ->
278− t (BaseUrl Http "localhost" port "")
341+ let reifiedApi = toReifiedApi (flattenServer @FooApi fooServer) (Proxy @(Endpoints FooApi))
342+ checkParallel $ Group "props" [("aprop", prop_sm_sequential reifiedApi)]