56f705f · roboservant · git.iko.soy

git.iko.soy/roboservant

on master help sign in

rigged it up to work with the server

56f705fSamuel Schlesinger6 years ago

package.yaml+1

compare with master

unifiedsplit

@@ -31,6 +31,7 @@ dependencies:

31- http-media

32- QuickCheck

33- quickcheck-state-machine >= 0.7

34+- mtl

34- servant >= 0.17

35- servant >= 0.17

35- servant-client >= 0.17

36- servant-client >= 0.17

36- servant-flatten

37- servant-flatten

roboservant.cabal+4−2

@@ -1,10 +1,10 @@

1cabal-version: 1.12

3−-- This file has been generated from package.yaml by hpack version 0.33.0.

3+-- This file has been generated from package.yaml by hpack version 0.31.2.

4--

5-- see: https://github.com/sol/hpack

6--

7−-- hash: bc1746c1053b1f6bf66cc30046bb205fefd129303feff615f0d885999eace809

7+-- hash: 9d15f4554f9f8ea8913a6766643b63ee6633016374fc98164e81058799204a87

9name: roboservant

10version: 0.1.0.0

@@ -46,6 +46,7 @@ library

46 , hspec

47 , http-client

48 , http-media

49+ , mtl

49 , quickcheck-state-machine >=0.7

50 , quickcheck-state-machine >=0.7

50 , servant >=0.17

51 , servant >=0.17

51 , servant-client >=0.17

52 , servant-client >=0.17

@@ -75,6 +76,7 @@ test-suite roboservant-test

75 , hspec

76 , hspec

76 , http-client

77 , http-client

77 , http-media

78 , http-media

79+ , mtl

78 , quickcheck-state-machine >=0.7

80 , quickcheck-state-machine >=0.7

79 , roboservant

81 , roboservant

80 , servant >=0.17

82 , servant >=0.17

src/Roboservant/StateMachine.hs+108−44

@@ -1,3 +1,9 @@

1+{-# LANGUAGE UndecidableInstances #-}

2+{-# LANGUAGE TypeFamilies #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE PolyKinds #-}

5+{-# LANGUAGE TypeApplications #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

1{-# LANGUAGE AllowAmbiguousTypes #-}

7{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE DataKinds #-}

8{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DeriveAnyClass #-}

9{-# LANGUAGE DeriveAnyClass #-}

@@ -29,6 +35,10 @@ import Control.Arrow (second)

29--import Test.QuickCheck (Property)

35--import Test.QuickCheck (Property)

30-- import Test.StateMachine

36-- import Test.StateMachine

38+import Type.Reflection (SomeTypeRep)

39+import Servant.API.Flatten (Flat)

40+import GHC.TypeLits (Nat, Symbol)

41+import Data.Function ((&))

32import Control.Concurrent (forkIO)

42import Control.Concurrent (forkIO)

33import Control.Monad ((<=<))

43import Control.Monad ((<=<))

34import Control.Monad.IO.Class

44import Control.Monad.IO.Class

@@ -47,6 +57,7 @@ import Debug.Trace (traceM, traceShowM)

47import GHC.Generics (Generic)

57import GHC.Generics (Generic)

48import GHC.Generics

58import GHC.Generics

49import GHC.IORef (readIORef)

59import GHC.IORef (readIORef)

60+import Control.Monad.Except (runExceptT)

50import Hedgehog

61import Hedgehog

51import Hedgehog

62import Hedgehog

52import qualified Hedgehog.Gen as Gen

63import qualified Hedgehog.Gen as Gen

@@ -94,8 +105,95 @@ data State v

94 { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v))

105 { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v))

95 }

106 }

107

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+

97type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]

132type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]

133

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+

99newtype ApiOffset = ApiOffset Int

197newtype ApiOffset = ApiOffset Int

100 deriving (Eq, Show)

198 deriving (Eq, Show)

101 deriving newtype (Enum, Num)

199 deriving newtype (Enum, Num)

@@ -156,8 +254,10 @@ callEndpoint staticRoutes =

156 Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)

254 Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)

157 Just (f') -> do

255 Just (f') -> do

158 case fromDynamic f' of

256 case fromDynamic f' of

159− Nothing -> error "failed on casting final function"

257+ Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)

160− Just f -> liftIO f >>= newIORef -- >>= either (const $ error "blah") pure

258+ Just f -> liftIO f >>= \case

259+ Left (serverError :: ServerError) -> error (show serverError)

260+ Right (typeRep :: SomeTypeRep, (dyn :: Dynamic)) -> newIORef dyn

161 in Command

261 in Command

162 gen

262 gen

163 execute

263 execute

@@ -190,7 +290,7 @@ prop_sm_sequential reifiedApi = do

190 executeSequential initialState actions

290 executeSequential initialState actions

191

291

192newtype Foo = Foo Int

292newtype Foo = Foo Int

193− deriving (Generic, Eq, Show)

293+ deriving (Generic, Eq, Show, Typeable)

194 deriving newtype (FromHttpApiData, ToHttpApiData)

294 deriving newtype (FromHttpApiData, ToHttpApiData)

195

295

196instance ToJSON Foo

296instance ToJSON Foo

@@ -219,6 +319,9 @@ fooServer =

219 :<|> combine

319 :<|> combine

220 :<|> eliminate

320 :<|> eliminate

221

321

322+bundledFooServer :: Bundled (Endpoints FooApi)

323+bundledFooServer = flattenServer @FooApi fooServer

324+

222runServer :: IO ()

325runServer :: IO ()

223runServer = do

326runServer = do

224 let port = 3000

327 let port = 3000

@@ -235,44 +338,5 @@ introC :<|> combineC :<|> eliminateC = Servant.Client.client fooApi

235

338

236tests :: IO Bool

339tests :: IO Bool

237tests = do

340tests = do

238− withServantServer fooApi (pure fooServer) $ \burl -> do

341+ let reifiedApi = toReifiedApi (flattenServer @FooApi fooServer) (Proxy @(Endpoints FooApi))

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)]

342+ 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 "")