1f7fe08 · roboservant · git.iko.soy

git.iko.soy/roboservant

on master help sign in

break up Types into modules

1f7fe08Mark Wotton6 years ago

roboservant.cabal+6−1

compare with master

unifiedsplit

@@ -4,7 +4,7 @@ cabal-version: 1.12

4--

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

6--

7−-- hash: c6f561e011d580d9e17888decc01e0d8d54c8508b04d3dfff3cfcb7f37e5f2e1

7+-- hash: 4f60e8b535f448b3d09b5f49b6851d27412b133b35f4381078d9693228b977cb

9name: roboservant

10version: 0.1.0.2

@@ -30,8 +30,12 @@ source-repository head

30library

31 exposed-modules:

32 Roboservant

33+ Roboservant.Hedgehog

33 Roboservant.StateMachine

34 Roboservant.StateMachine

34 Roboservant.Types

35 Roboservant.Types

36+ Roboservant.Types.Breakdown

37+ Roboservant.Types.FlattenServer

38+ Roboservant.Types.ReifiedApi

35 other-modules:

39 other-modules:

36 Paths_roboservant

40 Paths_roboservant

37 hs-source-dirs:

41 hs-source-dirs:

@@ -56,6 +60,7 @@ test-suite roboservant-test

56 other-modules:

60 other-modules:

57 Foo

61 Foo

58 Headers

62 Headers

63+ Seeded

59 UnsafeIO

64 UnsafeIO

60 Paths_roboservant

65 Paths_roboservant

61 hs-source-dirs:

66 hs-source-dirs:

src/Roboservant/Hedgehog.hsnew file+10

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

1+{-# LANGUAGE LambdaCase #-}

3+module Roboservant.Hedgehog where

4+import Hedgehog

5+import qualified Hedgehog.Gen as Gen

7+elementOrFail :: MonadGen m => [a] -> m a

8+elementOrFail = \case

9+ [] -> Gen.discard

10+ x -> Gen.element x

src/Roboservant/StateMachine.hs+10−13

@@ -36,9 +36,10 @@ import Servant

36import Type.Reflection (SomeTypeRep)

38import Roboservant.Types

39+import Roboservant.Hedgehog

40callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> [Dynamic] -> Command n m State

41callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> [Dynamic] -> Command n m State

41−callEndpoint staticRoutes seed =

42+callEndpoint staticRoutes _seed =

42 let gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic))

43 let gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic))

43 gen State {..}

44 gen State {..}

44 | any null options = Nothing

45 | any null options = Nothing

@@ -56,8 +57,8 @@ callEndpoint staticRoutes seed =

56 [(TypeRep, Var (Opaque (IORef Dynamic)) Symbolic)]

57 [(TypeRep, Var (Opaque (IORef Dynamic)) Symbolic)]

57 )

58 )

58 chooseOne opts = do

59 chooseOne opts = do

59− (offset, args) <- Gen.element opts

60+ (offset, args) <- elementOrFail opts

60− (offset,) <$> mapM (\(tr, argOpts) -> (tr,) <$> Gen.element argOpts) args

61+ (offset,) <$> mapM (\(tr, argOpts) -> (tr,) <$> elementOrFail argOpts) args

61 options :: [(ApiOffset, [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])])]

62 options :: [(ApiOffset, [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])])]

62 options =

63 options =

63 mapMaybe

64 mapMaybe

@@ -71,12 +72,9 @@ callEndpoint staticRoutes seed =

71 (MonadIO m) =>

72 (MonadIO m) =>

72 Op Concrete ->

73 Op Concrete ->

73 m (Opaque (IORef Dynamic))

74 m (Opaque (IORef Dynamic))

74− execute (Preload tr v) = fmap Opaque . liftIO $ do

75+ execute (Preload _tr v) = fmap Opaque . liftIO $ do

75 newIORef . concrete $ v

76 newIORef . concrete $ v

76− --fmap Opaque . liftIO $

77−-- _ v

78 execute (Op (ApiOffset offset) args) = do

77 execute (Op (ApiOffset offset) args) = do

79− -- traceM (show (offset, args))

80 fmap Opaque . liftIO $ do

78 fmap Opaque . liftIO $ do

81 realArgs <- mapM (\(_tr, v) -> readIORef (opaque v)) args

79 realArgs <- mapM (\(_tr, v) -> readIORef (opaque v)) args

82 let (_offset, _staticArgs, _ret, endpoint) = staticRoutes !! offset

80 let (_offset, _staticArgs, _ret, endpoint) = staticRoutes !! offset

@@ -97,7 +95,7 @@ callEndpoint staticRoutes seed =

97 execute

95 execute

98 [ Update $ \s@State {..} op o' ->

96 [ Update $ \s@State {..} op o' ->

99 case op of

97 case op of

100− Preload tr v -> s { stateRefs =

98+ Preload tr _v -> s { stateRefs =

101 Map.insertWith (<>) tr (pure o') stateRefs }

99 Map.insertWith (<>) tr (pure o') stateRefs }

102 (Op (ApiOffset offset) _args) ->

100 (Op (ApiOffset offset) _args) ->

103 s

101 s

@@ -115,7 +113,6 @@ callEndpoint staticRoutes seed =

115prop_sequential :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()

113prop_sequential :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()

116prop_sequential server seed = do

114prop_sequential server seed = do

117 let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))

115 let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))

118− -- refs <- Map.fromList <$> mapM (\d -> (dynTypeRep d,) <$> newIORef d) seed

119

116

120 actions <-

117 actions <-

121 forAll $ do

118 forAll $ do

@@ -124,10 +121,10 @@ prop_sequential server seed = do

124 (State mempty)

121 (State mempty)

125 [callEndpoint reifiedApi seed]

122 [callEndpoint reifiedApi seed]

126

123

127− executeSequential (undefined) actions

124+ executeSequential (State mempty) actions

128

125

129−prop_concurrent :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> PropertyT IO ()

126+prop_concurrent :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api)) => Server api -> [Dynamic] -> PropertyT IO ()

130−prop_concurrent server =

127+prop_concurrent server seed =

131 let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api)) in

128 let reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api)) in

132 let initialState = State mempty

129 let initialState = State mempty

133 in do

130 in do

@@ -137,6 +134,6 @@ prop_concurrent server =

137 (Range.linear 1 50)

134 (Range.linear 1 50)

138 (Range.linear 1 10)

135 (Range.linear 1 10)

139 initialState

136 initialState

140− [callEndpoint reifiedApi []]

137+ [callEndpoint reifiedApi seed]

141 test $

138 test $

142 executeParallel initialState actions

139 executeParallel initialState actions

src/Roboservant/Types.hs+16−155

@@ -2,7 +2,6 @@

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DerivingStrategies #-}

4{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE GADTs #-}

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7{-# LANGUAGE LambdaCase #-}

6{-# LANGUAGE LambdaCase #-}

8{-# LANGUAGE PolyKinds #-}

7{-# LANGUAGE PolyKinds #-}

@@ -14,172 +13,34 @@

14{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE TypeOperators #-}

15{-# LANGUAGE UndecidableInstances #-}

14{-# LANGUAGE UndecidableInstances #-}

17−module Roboservant.Types where

16+module Roboservant.Types

17+ ( module Roboservant.Types,

18+ FlattenServer (..),

19+ ToReifiedApi (..),

20+ ReifiedApi,

21+ ApiOffset (..),

22+ )

23+where

19−import Control.Monad.Except (runExceptT)

20−import Data.Dynamic (Dynamic, toDyn)

25+import Data.Dynamic (Dynamic)

21−import Data.Function ((&))

22import Data.IORef (IORef)

26import Data.IORef (IORef)

23import Data.List.NonEmpty (NonEmpty)

27import Data.List.NonEmpty (NonEmpty)

24import Data.Map.Strict (Map)

28import Data.Map.Strict (Map)

25−import Data.Typeable (TypeRep, Typeable, typeRep)

29+import Data.Typeable (TypeRep)

26−import GHC.TypeLits (Symbol)

27−import Hedgehog

30+import Hedgehog (HTraversable (..), Opaque, Symbolic, Var)

28−import Servant

31+import Roboservant.Types.FlattenServer

29−import Servant.API.Modifiers

32+import Roboservant.Types.ReifiedApi

31data State v

34data State v

32 = State

35 = State

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

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

34 }

37 }

36−class FlattenServer api where

37− flattenServer :: Server api -> Bundled (Endpoints api)

38−

39−instance

40− ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api),

41− Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api),

42− FlattenServer api

43− ) =>

44− FlattenServer (endpoint :<|> api)

45− where

46− flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server

47−

48−instance

49− ( HasServer (x :> api) '[],

50− Endpoints (x :> api) ~ '[x :> api]

51− ) =>

52− FlattenServer (x :> api)

53− where

54− flattenServer server = server `AnEndpoint` NoEndpoints

55−

56−instance

57− ( HasServer (Verb method statusCode contentTypes responseType) '[],

58− Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType]

59− ) =>

60− FlattenServer (Verb method statusCode contentTypes responseType)

61− where

62− flattenServer server = server `AnEndpoint` NoEndpoints

63−

64−type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)

65−

66−type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]

67−

68−data Bundled endpoints where

69− AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)

70− NoEndpoints :: Bundled '[]

71−

72−class ToReifiedApi (endpoints :: [*]) where

73− toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi

74−

75−class ToReifiedEndpoint (endpoint :: *) where

76− toReifiedEndpoint :: Dynamic -> Proxy endpoint -> ReifiedEndpoint

77−

78−instance ToReifiedApi '[] where

79− toReifiedApi NoEndpoints _ = []

80−

81−instance

82− (Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)) =>

83− ToReifiedApi (endpoint : endpoints)

84− where

85− toReifiedApi (endpoint `AnEndpoint` endpoints) _ =

86− withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))

87− : map

88− (\(n, x, y, z) -> (n + 1, x, y, z))

89− (toReifiedApi endpoints (Proxy @endpoints))

90− where

91− withOffset (x, y, z) = (0, x, y, z)

92−

93−class NormalizeFunction m where

94− type Normal m

95− normalize :: m -> Normal m

96−

97−instance NormalizeFunction x => NormalizeFunction (r -> x) where

98− type Normal (r -> x) = r -> Normal x

99− normalize = fmap normalize

100−

101−instance Typeable x => NormalizeFunction (Handler x) where

102− type Normal (Handler x) = IO (Either ServerError (TypeRep, Dynamic))

103− normalize handler = (runExceptT . runHandler') handler >>= \case

104− Left serverError -> pure (Left serverError)

105− Right x -> pure (Right (typeRep (Proxy @x), toDyn x))

106−

107−instance

108− Typeable responseType =>

109− ToReifiedEndpoint (Verb method statusCode contentTypes responseType)

110− where

111− toReifiedEndpoint endpoint _ =

112− ([], typeRep (Proxy @responseType), endpoint)

113−

114−instance

115− (ToReifiedEndpoint endpoint) =>

116− ToReifiedEndpoint ((x :: Symbol) :> endpoint)

117− where

118− toReifiedEndpoint endpoint _ =

119− toReifiedEndpoint endpoint (Proxy @endpoint)

120−

121−instance

122− (ToReifiedEndpoint endpoint) =>

123− ToReifiedEndpoint (Description s :> endpoint)

124− where

125− toReifiedEndpoint endpoint _ =

126− toReifiedEndpoint endpoint (Proxy @endpoint)

127−

128−instance

129− (ToReifiedEndpoint endpoint) =>

130− ToReifiedEndpoint (Summary s :> endpoint)

131− where

132− toReifiedEndpoint endpoint _ =

133− toReifiedEndpoint endpoint (Proxy @endpoint)

134−

135−instance

136− (Typeable requestType, ToReifiedEndpoint endpoint) =>

137− ToReifiedEndpoint (QueryFlag name :> endpoint)

138− where

139− toReifiedEndpoint endpoint _ =

140− toReifiedEndpoint endpoint (Proxy @endpoint)

141− & \(args, result, typeRepMap) -> (typeRep (Proxy @Bool) : args, result, typeRepMap)

142−

143−instance

144− (Typeable (If (FoldRequired mods) paramType (Maybe paramType)), ToReifiedEndpoint endpoint, SBoolI (FoldRequired mods)) =>

145− ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)

146− where

147− toReifiedEndpoint endpoint _ =

148− toReifiedEndpoint endpoint (Proxy @endpoint)

149− & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldRequired mods) paramType (Maybe paramType))) : args, result, typeRepMap)

150−

151−instance

152− (Typeable (If (FoldRequired mods) headerType (Maybe headerType)), ToReifiedEndpoint endpoint, SBoolI (FoldRequired mods)) =>

153− ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)

154− where

155− toReifiedEndpoint endpoint _ =

156− toReifiedEndpoint endpoint (Proxy @endpoint)

157− & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldRequired mods) headerType (Maybe headerType))) : args, result, typeRepMap)

158−

159−instance

160− (Typeable captureType, ToReifiedEndpoint endpoint) =>

161− ToReifiedEndpoint (Capture' mods name captureType :> endpoint)

162− where

163− toReifiedEndpoint endpoint _ =

164− toReifiedEndpoint endpoint (Proxy @endpoint)

165− & \(args, result, typeRepMap) -> (typeRep (Proxy @captureType) : args, result, typeRepMap)

166−

167−instance

168− (Typeable (If (FoldLenient mods) (Either String requestType) requestType), ToReifiedEndpoint endpoint, SBoolI (FoldLenient mods)) =>

169− ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)

170− where

171− toReifiedEndpoint endpoint _ =

172− toReifiedEndpoint endpoint (Proxy @endpoint)

173− & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldLenient mods) (Either String requestType) requestType)) : args, result, typeRepMap)

174−

175−newtype ApiOffset = ApiOffset Int

176− deriving (Eq, Show)

177− deriving newtype (Enum, Num)

178−

179-- | we need to specify an offset because it's entirely possible to have two

39-- | we need to specify an offset because it's entirely possible to have two

180-- functions with the same arguments that do different things.

40-- functions with the same arguments that do different things.

41+data Op (v :: * -> *)

181−data Op (v :: * -> *) = Op ApiOffset [(TypeRep, Var (Opaque (IORef Dynamic)) v)]

42+ = Op ApiOffset [(TypeRep, Var (Opaque (IORef Dynamic)) v)]

182− | Preload TypeRep (Var Dynamic v)

43+ | Preload TypeRep (Var Dynamic v)

183

184deriving instance Show (Op Symbolic)

45deriving instance Show (Op Symbolic)

185

src/Roboservant/Types/Breakdown.hsnew file+62

@@ -0,0 +1,62 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DefaultSignatures #-}

4+{-# LANGUAGE DerivingStrategies #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8+{-# LANGUAGE LambdaCase #-}

9+{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE StandaloneDeriving #-}

12+{-# LANGUAGE TupleSections #-}

13+{-# LANGUAGE TypeApplications #-}

14+{-# LANGUAGE TypeFamilies #-}

15+{-# LANGUAGE TypeOperators #-}

16+{-# LANGUAGE UndecidableInstances #-}

17+

18+module Roboservant.Types.Breakdown where

19+

20+import Data.Dynamic (Dynamic, dynTypeRep, fromDynamic, toDyn)

21+import Data.List.NonEmpty (NonEmpty)

22+import qualified Data.List.NonEmpty as NEL

23+import qualified Data.Map.Strict as Map

24+import Data.Map.Strict (Map)

25+import Data.Maybe (fromMaybe)

26+import Data.Proxy (Proxy (..))

27+import Data.Typeable (TypeRep, Typeable, typeRep)

28+import Hedgehog (Gen)

29+import qualified Hedgehog.Gen as Gen

30+

31+class Typeable x => BuildFrom x where

32+ buildFrom :: Map TypeRep (NonEmpty Dynamic) -> [x]

33+ default buildFrom :: Map TypeRep (NonEmpty Dynamic) -> [x]

34+ buildFrom = maybe [] (fmap promisedDyn . NEL.toList) . Map.lookup (typeRep (Proxy @x))

35+

36+instance BuildFrom x => BuildFrom (Maybe x) where

37+ buildFrom dict = Nothing : fmap Just (buildFrom dict)

38+

39+class Breakdown x where

40+ breakdown :: x -> Map TypeRep (NonEmpty Dynamic)

41+

42+-- | Can't break it down any further -- stuck in your teeth, maybe.

43+newtype Chewy x = Chewy x

44+

45+instance Typeable x => Breakdown (Chewy x) where

46+ breakdown x = let d = toDyn x in Map.fromList [(dynTypeRep d, pure d)]

47+

48+-- instance (Typeable x, Generic x) => Breakdown x where

49+-- breakdown = Map.fromListWith (<>) . fmap ((dynTypeRep &&& (\x -> NEL.fromList [x])) . toDyn . Generics.to) . _ . Generics.from

50+

51+class Create x where

52+ create :: Map TypeRep (NonEmpty Dynamic) -> Maybe (Gen x)

53+

54+instance Typeable x => Create x where

55+ create mmm =

56+ (fmap Gen.element) $

57+ fmap promisedDyn . NEL.toList

58+ <$> Map.lookup (typeRep (Proxy @x)) mmm

59+

60+-- | only use this when we are using the internal typerep map.

61+promisedDyn :: Typeable a => Dynamic -> a

62+promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . fromDynamic

src/Roboservant/Types/FlattenServer.hsnew file+45

@@ -0,0 +1,45 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE PolyKinds #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE TypeApplications #-}

7+{-# LANGUAGE TypeOperators #-}

8+{-# LANGUAGE UndecidableInstances #-}

10+module Roboservant.Types.FlattenServer where

11+

12+import Servant

13+

14+

15+data Bundled endpoints where

16+ AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)

17+ NoEndpoints :: Bundled '[]

18+

19+class FlattenServer api where

20+ flattenServer :: Server api -> Bundled (Endpoints api)

21+

22+instance

23+ ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api),

24+ Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api),

25+ FlattenServer api

26+ ) =>

27+ FlattenServer (endpoint :<|> api)

28+ where

29+ flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server

30+

31+instance

32+ ( HasServer (x :> api) '[],

33+ Endpoints (x :> api) ~ '[x :> api]

34+ ) =>

35+ FlattenServer (x :> api)

36+ where

37+ flattenServer server = server `AnEndpoint` NoEndpoints

38+

39+instance

40+ ( HasServer (Verb method statusCode contentTypes responseType) '[],

41+ Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType]

42+ ) =>

43+ FlattenServer (Verb method statusCode contentTypes responseType)

44+ where

45+ flattenServer server = server `AnEndpoint` NoEndpoints

src/Roboservant/Types/ReifiedApi.hsnew file+140

@@ -0,0 +1,140 @@

2+{-# LANGUAGE AllowAmbiguousTypes #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE DerivingStrategies #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7+{-# LANGUAGE LambdaCase #-}

8+{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE StandaloneDeriving #-}

11+{-# LANGUAGE TupleSections #-}

12+{-# LANGUAGE TypeApplications #-}

13+{-# LANGUAGE TypeFamilies #-}

14+{-# LANGUAGE TypeOperators #-}

15+{-# LANGUAGE UndecidableInstances #-}

16+

17+module Roboservant.Types.ReifiedApi where

18+

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)

25+import Servant

26+import Servant.API.Modifiers(FoldRequired,FoldLenient)

27+import Roboservant.Types.FlattenServer

28+

29+

30+newtype ApiOffset = ApiOffset Int

31+ deriving (Eq, Show)

32+ deriving newtype (Enum, Num)

33+

34+type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)

35+

36+type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]

37+

38+

39+class ToReifiedApi (endpoints :: [*]) where

40+ toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi

41+

42+class ToReifiedEndpoint (endpoint :: *) where

43+ toReifiedEndpoint :: Dynamic -> Proxy endpoint -> ReifiedEndpoint

44+

45+instance ToReifiedApi '[] where

46+ toReifiedApi NoEndpoints _ = []

47+

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

73+

74+instance

75+ Typeable responseType =>

76+ ToReifiedEndpoint (Verb method statusCode contentTypes responseType)

77+ where

78+ toReifiedEndpoint endpoint _ =

79+ ([], typeRep (Proxy @responseType), endpoint)

80+

81+instance

82+ (ToReifiedEndpoint endpoint) =>

83+ ToReifiedEndpoint ((x :: Symbol) :> endpoint)

84+ where

85+ toReifiedEndpoint endpoint _ =

86+ toReifiedEndpoint endpoint (Proxy @endpoint)

87+

88+instance

89+ (ToReifiedEndpoint endpoint) =>

90+ ToReifiedEndpoint (Description s :> endpoint)

91+ where

92+ toReifiedEndpoint endpoint _ =

93+ toReifiedEndpoint endpoint (Proxy @endpoint)

94+

95+instance

96+ (ToReifiedEndpoint endpoint) =>

97+ ToReifiedEndpoint (Summary s :> endpoint)

98+ where

99+ toReifiedEndpoint endpoint _ =

100+ toReifiedEndpoint endpoint (Proxy @endpoint)

101+

102+instance

103+ (Typeable requestType, ToReifiedEndpoint endpoint) =>

104+ ToReifiedEndpoint (QueryFlag name :> endpoint)

105+ where

106+ toReifiedEndpoint endpoint _ =

107+ toReifiedEndpoint endpoint (Proxy @endpoint)

108+ & \(args, result, typeRepMap) -> (typeRep (Proxy @Bool) : args, result, typeRepMap)

109+

110+instance

111+ (Typeable (If (FoldRequired mods) paramType (Maybe paramType)), ToReifiedEndpoint endpoint, SBoolI (FoldRequired mods)) =>

112+ ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)

113+ where

114+ toReifiedEndpoint endpoint _ =

115+ toReifiedEndpoint endpoint (Proxy @endpoint)

116+ & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldRequired mods) paramType (Maybe paramType))) : args, result, typeRepMap)

117+

118+instance

119+ (Typeable (If (FoldRequired mods) headerType (Maybe headerType)), ToReifiedEndpoint endpoint, SBoolI (FoldRequired mods)) =>

120+ ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)

121+ where

122+ toReifiedEndpoint endpoint _ =

123+ toReifiedEndpoint endpoint (Proxy @endpoint)

124+ & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldRequired mods) headerType (Maybe headerType))) : args, result, typeRepMap)

125+

126+instance

127+ (Typeable captureType, ToReifiedEndpoint endpoint) =>

128+ ToReifiedEndpoint (Capture' mods name captureType :> endpoint)

129+ where

130+ toReifiedEndpoint endpoint _ =

131+ toReifiedEndpoint endpoint (Proxy @endpoint)

132+ & \(args, result, typeRepMap) -> (typeRep (Proxy @captureType) : args, result, typeRepMap)

133+

134+instance

135+ (Typeable (If (FoldLenient mods) (Either String requestType) requestType), ToReifiedEndpoint endpoint, SBoolI (FoldLenient mods)) =>

136+ ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)

137+ 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)

test/Foo.hs+3−3

@@ -20,7 +20,7 @@ instance ToJSON Foo

21instance FromJSON Foo

23−type FooApi =

23+type Api =

24 "item" :> Get '[JSON] Foo

25 :<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo

26 :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()

@@ -36,8 +36,8 @@ eliminate (Foo a)

36 | a > 10 = throwError $ err500 {errBody = "eliminate blew up, oh no!"}

37 | otherwise = pure ()

39−fooServer :: Server FooApi

39+server :: Server Api

40−fooServer =

40+server =

41 intro

42 :<|> combine

43 :<|> eliminate

test/Spec.hs+26−24

@@ -1,46 +1,48 @@

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE TypeApplications #-}

3{-# LANGUAGE TypeApplications #-}

4import qualified Foo

5import qualified Foo

6+import qualified Seeded

5import qualified Headers

7import qualified Headers

6−import Hedgehog (Group (..), checkSequential, withTests)

7−import qualified Roboservant as RS

8import qualified UnsafeIO

9−import Control.Monad(when)

9+import qualified Roboservant as RS

10+

10import Test.Hspec.Hedgehog

11import Test.Hspec.Hedgehog

11import Test.Hspec

12import Test.Hspec

12import Test.Hspec.Core.Spec(shouldFail)

13import Test.Hspec.Core.Spec(shouldFail)

13−import Control.Monad.Trans (MonadIO(liftIO))

15−-- -- | this is pretty bad. hopefully Jacob knows a better way of doing this.

15+import Data.Dynamic(toDyn)

16−-- -- https://twitter.com/mwotton/status/1305189249646460933

17−-- assert :: String -> Bool -> IO ()

18−-- assert _ True = pure ()

19−-- assert err False = ioError $ userError err

17+main :: IO ()

21main = hspec spec

18main = hspec spec

23spec :: Spec

20spec :: Spec

24spec = do

21spec = do

25− describe "Foo" $ do

22+ describe "Basic usage" $ do

26− --

23+ describe "seeded" $ do

24+ shouldFail $

25+ it "finds an error using information passed in" $

26+ hedgehog $ RS.prop_sequential @Seeded.Api Seeded.server [toDyn $ Seeded.Seed 1]

27+

27− shouldFail $ it "finds an error" $

28+ shouldFail $ it "finds an error in a basic app" $

28− (hedgehog $ RS.prop_sequential @Foo.FooApi Foo.fooServer [])

29+ hedgehog $ RS.prop_sequential @Foo.Api Foo.server []

30 describe "Headers" $ do

31 describe "Headers" $ do

31 shouldFail $ it "should find a failure that's dependent on using header info" $ do

32 shouldFail $ it "should find a failure that's dependent on using header info" $ do

32− liftIO $ pendingWith "doesn't yet work"

33− (hedgehog $ RS.prop_sequential @Headers.Api Headers.server [])

33+ let _ = hedgehog $ RS.prop_sequential @Headers.Api Headers.server []

34+ pending

35 -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it

36 -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it

36 -- -- could: it's mostly here to show how to test for concurrency problems.

37 -- -- could: it's mostly here to show how to test for concurrency problems.

38+ describe "concurrency bugs" $ do

37− before UnsafeIO.makeServer $ do

39+ before UnsafeIO.makeServer $ do

38− describe "sequential checking" $ do

40+ describe "sequential checking" $ do

39− it "safe use" $ \unsafeServer -> do

41+ it "safe use" $ \unsafeServer -> do

40− hedgehog $ RS.prop_sequential @UnsafeIO.UnsafeApi unsafeServer []

42+ hedgehog $ RS.prop_sequential @UnsafeIO.UnsafeApi unsafeServer []

42− modifyMaxSuccess (const 10000) $

44+ modifyMaxSuccess (const 10000) $

43− shouldFail $

45+ shouldFail $

44− describe "concurrent" $ do

46+ describe "concurrent" $ do

45− it "concurrent, dangerous use" $ \unsafeServer -> do

47+ it "concurrent, dangerous use" $ \unsafeServer -> do

46− RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer

48+ RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer []