ec36997 · roboservant · git.iko.soy

git.iko.soy/roboservant

on master help sign in

Merge branch 'master' into morecoverage

ec36997Mark Wotton6 years ago

package.yaml+4−2

compare with master

unifiedsplit

@@ -2,8 +2,6 @@ name: roboservant

2version: 0.1.0.2

3github: "mwotton/roboservant"

4license: BSD3

5−author: "Mark Wotton, Samuel Schlesinger"

6−maintainer: "mwotton@gmail.com"

7copyright: "2020 Mark Wotton, Samuel Schlesinger"

5copyright: "2020 Mark Wotton, Samuel Schlesinger"

8synopsis: Automatic session-aware servant testing

6synopsis: Automatic session-aware servant testing

9category: Web

7category: Web

@@ -27,6 +25,10 @@ dependencies:

27- servant-flatten

25- servant-flatten

28- servant-server # >= 0.17

26- servant-server # >= 0.17

29- string-conversions

27- string-conversions

28+- vinyl

29+- dependent-sum

30+- dependent-map

31+- text

30- time

32- time

32ghc-options:

34ghc-options:

roboservant.cabal+9−3

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

4--

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

6--

7−-- hash: 4774250c208a2100460b0df7518257286ca38d8612b517ddcbf3e37678b598cf

7+-- hash: 134cfee817f86824342ecabc02ca2b48ec67539b75581c1954b95a9f9128e5a4

9name: roboservant

10version: 0.1.0.2

@@ -13,8 +13,6 @@ description: Please see the README on GitHub at <https://github.com/mwotton/r

13category: Web

14homepage: https://github.com/mwotton/roboservant#readme

15bug-reports: https://github.com/mwotton/roboservant/issues

16−author: Mark Wotton, Samuel Schlesinger

17−maintainer: mwotton@gmail.com

18copyright: 2020 Mark Wotton, Samuel Schlesinger

16copyright: 2020 Mark Wotton, Samuel Schlesinger

19license: BSD3

17license: BSD3

20license-file: LICENSE

18license-file: LICENSE

@@ -44,6 +42,8 @@ library

44 base >=4.7 && <5

42 base >=4.7 && <5

45 , bytestring

43 , bytestring

46 , containers

44 , containers

45+ , dependent-map

46+ , dependent-sum

47 , lifted-base

48 , monad-control

49 , mtl

@@ -53,7 +53,9 @@ library

53 , servant-flatten

54 , servant-server

55 , string-conversions

56+ , text

56 , time

57 , time

58+ , vinyl

57 default-language: Haskell2010

59 default-language: Haskell2010

59test-suite roboservant-test

61test-suite roboservant-test

@@ -76,6 +78,8 @@ test-suite roboservant-test

76 , base >=4.7 && <5

78 , base >=4.7 && <5

77 , bytestring

79 , bytestring

78 , containers

80 , containers

81+ , dependent-map

82+ , dependent-sum

79 , hspec

83 , hspec

80 , hspec-core

84 , hspec-core

81 , http-api-data

85 , http-api-data

@@ -89,5 +93,7 @@ test-suite roboservant-test

89 , servant-flatten

93 , servant-flatten

90 , servant-server

94 , servant-server

91 , string-conversions

95 , string-conversions

96+ , text

92 , time

97 , time

98+ , vinyl

93 default-language: Haskell2010

99 default-language: Haskell2010

src/Roboservant/Direct.hs+113−70

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

6{-# LANGUAGE GADTs #-}

7{-# LANGUAGE LambdaCase #-}

8{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE RecordWildCards #-}

10{-# LANGUAGE RecordWildCards #-}

10{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE TupleSections #-}

12{-# LANGUAGE TupleSections #-}

@@ -18,14 +19,20 @@ module Roboservant.Direct

18 ( fuzz, Config(..)

19 ( fuzz, Config(..)

20 -- TODO come up with something smarter than exporting all this, we should

21 -- TODO come up with something smarter than exporting all this, we should

21− -- have some nice error-display functions

22+ -- have some nice error-display functions

22 , RoboservantException(..), FuzzState(..), FuzzOp(..), FailureType(..), Report(..)

23 , RoboservantException(..), FuzzState(..), FuzzOp(..), FailureType(..), Report(..)

23 )

24 )

24where

25where

26import Control.Exception.Lifted(throw,handle,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)

27import Control.Exception.Lifted(throw,handle,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)

27import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,runStateT)

28import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,runStateT)

29+import Control.Exception.Lifted(throw,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)

30+import Control.Monad(void,replicateM,forM_)

31+import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,execStateT)

32+import Control.Monad.Trans.Control(MonadBaseControl)

33+import Data.Dependent.Map (DMap)

28−import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)

34+import Data.Dynamic (Dynamic(..), dynApply, dynTypeRep, fromDynamic)

35+import Data.List.NonEmpty (NonEmpty(..))

29import Data.Map.Strict(Map)

36import Data.Map.Strict(Map)

30import qualified Data.Set as Set

37import qualified Data.Set as Set

31import Data.Maybe (mapMaybe)

38import Data.Maybe (mapMaybe)

@@ -37,6 +44,16 @@ import qualified Data.Map.Strict as Map

37import Data.Time.Clock

44import Data.Time.Clock

38import Data.List(sortOn)

45import Data.List(sortOn)

39import Control.Arrow(second)

46import Control.Arrow(second)

47+import System.Timeout.Lifted(timeout)

48+import GHC.Generics ((:*:)(..))

49+import qualified Data.Vinyl.Functor as V

50+import qualified Data.Vinyl.Curry as V

51+import qualified Data.Dependent.Map as DM

52+import qualified Data.Vinyl as V

53+import qualified Data.List.NonEmpty as NEL

54+import qualified Data.Map.Strict as Map

55+import Data.Time.Clock

56+import qualified Type.Reflection as R

41import Roboservant.Types.Breakdown

58import Roboservant.Types.Breakdown

42import Roboservant.Types

59import Roboservant.Types

@@ -44,11 +61,19 @@ import Roboservant.Types

44 FlattenServer (..),

61 FlattenServer (..),

45-- ReifiedApi,

62-- ReifiedApi,

46 ToReifiedApi (..),

63 ToReifiedApi (..),

64+

65+ ReifiedEndpoint(..),

66+ Argument(..),

67+ TypedF

68+

47− ))

69+ )

70+

71+

48data RoboservantException

72data RoboservantException

49 = RoboservantException

73 = RoboservantException

50 { failureReason :: FailureType

74 { failureReason :: FailureType

51 , serverException :: Maybe SomeException

75 , serverException :: Maybe SomeException

76+ , something :: Int

52 , fuzzState :: FuzzState

77 , fuzzState :: FuzzState

53 } deriving (Show)

78 } deriving (Show)

@@ -81,7 +106,12 @@ data FuzzState = FuzzState

81 , stash :: Stash

106 , stash :: Stash

82 , currentRng :: StdGen

107 , currentRng :: StdGen

83 }

108 }

84− deriving (Show)

109+ deriving Show

110+

111+data EndpointOption = forall as. (V.RecordToList as, V.RMap as) => EndpointOption

112+ { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))

113+ , eoArgs :: V.Rec (TypedF StashValue) as

114+ }

115

86data StopReason

116data StopReason

87 = TimedOut

117 = TimedOut

@@ -107,9 +137,8 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do

107 deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime

137 deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime

108 (stopreason, fs ) <- runStateT

138 (stopreason, fs ) <- runStateT

109 (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get)) FuzzState{..}

139 (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get)) FuzzState{..}

140+ print stopreason

110 pure Nothing

141 pure Nothing

111− -- mapM_ (print . (\(offset, (args, dyn) ) -> (offset, map fst args, dyn))) reifiedApi

112−

113 where

142 where

114 -- something less terrible later

143 -- something less terrible later

115 formatException :: RoboservantException -> Report

144 formatException :: RoboservantException -> Report

@@ -159,67 +188,77 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do

159 modify' $ \st' -> st' { currentRng = newGen }

188 modify' $ \st' -> st' { currentRng = newGen }

160 pure (l !! index)

189 pure (l !! index)

161

190

162− genOp :: (MonadState FuzzState m, MonadIO m)

191+ withOp :: (MonadState FuzzState m, MonadIO m)

192+ => (forall as. (V.RecordToList as, V.RMap as)

163− => m (FuzzOp, Dynamic, [Dynamic])

193+ => FuzzOp

164− genOp = do -- fs@FuzzState{..} = do

194+ -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))

195+ -> V.Rec (TypedF V.Identity) as -> m r

196+ )

197+ -> m r

198+ withOp callback = do

165 -- choose a call to make, from the endpoints with fillable arguments.

199 -- choose a call to make, from the endpoints with fillable arguments.

166− (offset, dynCall, args) <- elementOrFail . options =<< get

200+ (offset, EndpointOption{..}) <- elementOrFail . options =<< get

201+ r <- V.rtraverse

167− r <- mapM (elementOrFail . zip [0..] . NEL.toList) args

202+ (\(tr :*: StashValue svs) -> elementOrFail $

203+ zipWith (\i xy -> V.Const i :*: tr :*: xy)

204+ [0..]

205+ (NEL.toList svs)

206+ )

207+ eoArgs

168− let pathSegment = FuzzOp offset (map (\(index,(_,dyn) ) -> Provenance (dynTypeRep dyn) index) r)

208+ let pathSegment = FuzzOp offset $

209+ recordToList'

210+ (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)

211+ r

212+ argValues = V.rmap

213+ (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)

214+ r

169 modify' (\f -> f { path = path f <> [pathSegment] })

215 modify' (\f -> f { path = path f <> [pathSegment] })

170− pure (pathSegment, dynCall, fmap (snd . snd) r)

216+ callback pathSegment eoCall argValues

171−

172 where

217 where

173− options :: FuzzState -> [(ApiOffset, Dynamic, [NEL.NonEmpty ([Provenance], Dynamic)])]

218+ options :: FuzzState -> [(ApiOffset, EndpointOption)]

174 options FuzzState{..} =

219 options FuzzState{..} =

175 mapMaybe

220 mapMaybe

176− ( \(offset, (argreps, dynCall)) -> (offset,dynCall,) <$>

221+ ( \(offset, ReifiedEndpoint{..}) -> do

177− mapM (\(_tr,bf) -> bf stash ) argreps

222+ args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments

223+ pure (offset, EndpointOption reEndpointFunc args)

178 )

224 )

179 reifiedApi

225 reifiedApi

180

226

181− execute :: (MonadState FuzzState m, MonadIO m)

227+ execute :: (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as)

182− => (FuzzOp,Dynamic,[Dynamic]) -> m ()

228+ => FuzzOp

229+ -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))

230+ -> V.Rec (TypedF V.Identity) as

231+ -> m ()

183− execute (fuzzop, dyncall, args) = do

232+ execute fuzzop func args = do

184− -- liftIO $ print fuzzop

233+ liftIO $ print fuzzop

185− -- now, magic happens: we apply some dynamic arguments to a dynamic

186− -- function and hopefully something useful pops out the end.

187− let func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just dyncall) (reverse args)

188 st <- get

234 st <- get

189− let showable = unlines $ ("args":map (show . dynTypeRep) args)

235+ let showable = unlines $ ("args":map show argTypes)

190 <> ["fuzzop"

236 <> ["fuzzop"

191 , show fuzzop

237 , show fuzzop

192− ,"dyncall"

238+ -- ,"dyncall"

193− ,show (dynTypeRep dyncall)

239+ -- ,show (dynTypeRep dyncall)

194 ,"state"

240 ,"state"

195 ,show st]

241 ,show st]

196− -- liftIO $ putStrLn showable

242+ liftIO $ putStrLn showable

197−

243+ liftIO (V.runcurry' func argVals) >>= \case

198− case func of

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

200− Just f' -> do

201− -- liftIO $ print

202− case fromDynamic f' of

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

204− Just f -> liftIO f >>= \case

205− -- parameterise this

244+ -- parameterise this

206− Left (serverError :: ServerError) ->

245+ Left (serverError :: ServerError) ->

207− case errHTTPCode serverError of

246+ case errHTTPCode serverError of

208− 500 -> throw serverError

247+ 500 -> throw serverError

209− _ ->

248+ _ -> do

210− liftIO $ print ("ignoring non-500 error" , serverError)

249+ liftIO $ print ("ignoring non-500 error" , serverError)

211−

212− Right (dyn :: NEL.NonEmpty Dynamic) -> do

250+ Right (dyn :: NEL.NonEmpty Dynamic) -> do

213− -- liftIO $ print ("storing", fmap dynTypeRep dyn)

251+ liftIO $ print ("storing", fmap dynTypeRep dyn)

214− modify' (\fs@FuzzState{..} ->

252+ modify' (\fs@FuzzState{..} ->

215− fs { stash = addToStash (NEL.toList dyn) stash } )

253+ fs { stash = addToStash (NEL.toList dyn) stash } )

216− pure ()

254+ where

217−

255+ argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args

256+ argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args

257+

218−-- go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)

258+ go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)

219−-- => m ()

259+ => m ()

220− go = do

260+ go = withOp $ \op func args -> do

221− op <- genOp

222− catches (execute op)

261+ catches (execute op func args)

223 [ Handler (\(e :: SomeAsyncException) -> throw e)

262 [ Handler (\(e :: SomeAsyncException) -> throw e)

224 , Handler (\(e :: SomeException) -> do

263 , Handler (\(e :: SomeException) -> do

225 displayDiagnostics =<< get

264 displayDiagnostics =<< get

@@ -228,25 +267,29 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do

228 catch (liftIO checker)

267 catch (liftIO checker)

229 (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)

268 (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)

230

269

231− -- actions <-

232− -- forAll $ do

233− -- Gen.sequential

234− -- (Range.linear 1 100)

235− -- emptyState

236− -- (fmap preload seed <> [callEndpoint reifiedApi])

237− -- executeSequential emptyState actions

238addToStash :: [Dynamic]

270addToStash :: [Dynamic]

239− -> Map TypeRep (NEL.NonEmpty ([Provenance], Dynamic))

271+ -> Stash

240− -> Map TypeRep (NEL.NonEmpty ([Provenance], Dynamic))

272+ -> Stash

241addToStash result stash =

273addToStash result stash =

242− foldr (\dyn dict -> let tr = dynTypeRep dyn in

274+ foldr (\(Dynamic tr x) (Stash dict) -> Stash $

243− Map.insertWith renumber tr (pure ([Provenance tr 0],dyn)) dict) stash result

275+ DM.insertWith renumber tr (StashValue (([Provenance (R.SomeTypeRep tr) 0],x):|[])) dict

244−-- Map.insertWith (flip (<>)) (dynTypeRep result) (_pure result) stash })

276+ )

277+ stash

278+ result

245 where

279 where

246− renumber :: NEL.NonEmpty ([Provenance],Dynamic)

280+ renumber :: StashValue a

247− -> NEL.NonEmpty ([Provenance],Dynamic)

281+ -> StashValue a

248− -> NEL.NonEmpty ([Provenance],Dynamic)

282+ -> StashValue a

249− renumber singleDyn l = case NEL.toList singleDyn of

283+ renumber (StashValue singleDyn) (StashValue l) = StashValue $ case NEL.toList singleDyn of

250 [([Provenance tr _], dyn)] -> l

284 [([Provenance tr _], dyn)] -> l

251 <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)

285 <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)

252 _ -> error "should be impossible"

286 _ -> error "should be impossible"

287+

288+

289+-- why isn't this in vinyl?

290+recordToList'

291+ :: (V.RecordToList as, V.RMap as)

292+ => (forall x. f x -> a)

293+ -> V.Rec f as

294+ -> [a]

295+recordToList' f = V.recordToList . V.rmap (V.Const . f)

src/Roboservant/Types/Breakdown.hs+40−20

@@ -2,10 +2,16 @@

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DerivingVia #-}

4{-# LANGUAGE StandaloneDeriving #-}

5−

6−

7{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE GADTs #-}

6{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE DefaultSignatures #-}

8+{-# LANGUAGE DeriveFunctor #-}

9+{-# LANGUAGE DerivingStrategies #-}

10+{-# LANGUAGE FlexibleInstances #-}

11+{-# LANGUAGE GADTs #-}

12+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

13+{-# LANGUAGE LambdaCase #-}

14+{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE PolyKinds #-}

15{-# LANGUAGE PolyKinds #-}

10{-# LANGUAGE ScopedTypeVariables #-}

16{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE TypeApplications #-}

17{-# LANGUAGE TypeApplications #-}

@@ -18,30 +24,27 @@ import Data.Dynamic (Dynamic, fromDynamic, toDyn)

18import Data.List.NonEmpty (NonEmpty(..))

24import Data.List.NonEmpty (NonEmpty(..))

19import qualified Data.List.NonEmpty as NEL

25import qualified Data.List.NonEmpty as NEL

20import qualified Data.Map.Strict as Map

26import qualified Data.Map.Strict as Map

21−import Data.Map.Strict (Map)

22import Data.Maybe (fromMaybe)

27import Data.Maybe (fromMaybe)

23import Data.Proxy (Proxy (..))

28import Data.Proxy (Proxy (..))

24import Data.Typeable (TypeRep, Typeable, typeRep)

29import Data.Typeable (TypeRep, Typeable, typeRep)

25import GHC.Generics(Generic)

30import GHC.Generics(Generic)

26import qualified GHC.Generics as Generics

31import qualified GHC.Generics as Generics

32+import Data.Typeable (Typeable)

33+import qualified Data.Dependent.Map as DM

34+import Data.Dependent.Map (DMap)

35+import qualified Type.Reflection as R

36+import Data.Dependent.Sum

37+import Data.Kind

28data Provenance

39data Provenance

29− = Provenance TypeRep Int

40+ = Provenance R.SomeTypeRep Int

30 deriving (Show,Eq)

41 deriving (Show,Eq)

31−type Stash = Map TypeRep (NonEmpty ([Provenance], Dynamic))

32−

34class Breakdown x where

43class Breakdown x where

35 breakdown :: x -> NonEmpty Dynamic

44 breakdown :: x -> NonEmpty Dynamic

36-- default breakdown :: Typeable x => x -> NonEmpty Dynamic

45-- default breakdown :: Typeable x => x -> NonEmpty Dynamic

37-- breakdown = pure . toDyn

46-- breakdown = pure . toDyn

39−class Typeable x => BuildFrom x where

40− buildFrom :: Stash -> Maybe (NonEmpty ([Provenance],Dynamic))

41−

42−-- default buildFrom :: Stash -> Maybe (NonEmpty ([Provenance], Dynamic))

43−-- buildFrom = Map.lookup (typeRep (Proxy @x))

44−

46-- | Can't be built up from parts

49-- | Can't be built up from parts

47newtype Atom x = Atom { unAtom :: x }

50newtype Atom x = Atom { unAtom :: x }

@@ -62,6 +65,22 @@ instance (Typeable x, Generic x) => Breakdown (Compound x) where

62instance Typeable x => BuildFrom (Atom x) where

65instance Typeable x => BuildFrom (Atom x) where

63 buildFrom = Map.lookup (typeRep (Proxy @x))

66 buildFrom = Map.lookup (typeRep (Proxy @x))

68+newtype StashValue a = StashValue { getStashValue :: NonEmpty ([Provenance], a) }

69+ deriving (Functor, Show)

70+

71+-- wrap in newtype to give a custom Show instance, since the normal

72+-- instance for DMap is not happy since StashValue needs Show a to show

73+newtype Stash = Stash { getStash :: DMap R.TypeRep StashValue }

74+ deriving (Semigroup, Monoid)

75+

76+instance Show Stash where

77+ showsPrec i (Stash x) = showsPrec i $

78+ Map.fromList . map (\(tr :=> StashValue vs) -> (R.SomeTypeRep tr, fmap fst vs)) $ DM.toList x

79+

80+class Typeable x => BuildFrom (x :: Type) where

81+ buildFrom :: Stash -> Maybe (StashValue x)

82+ default buildFrom :: Stash -> Maybe (StashValue x)

83+ buildFrom = DM.lookup R.typeRep . getStash

66 -- (fmap promisedDyn . NEL.toList) . Map.lookup (typeRep (Proxy @x))

85 -- (fmap promisedDyn . NEL.toList) . Map.lookup (typeRep (Proxy @x))

@@ -78,18 +97,19 @@ promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . f

78deriving via (Atom Bool) instance BuildFrom Bool

97deriving via (Atom Bool) instance BuildFrom Bool

80instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where

99instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where

81− buildFrom dict = Just $ fmap toDyn <$> options

100+ buildFrom dict = Just options

82− where options :: NonEmpty ([Provenance], Maybe x)

101+ where options :: StashValue (Maybe x)

102+ options = StashValue $

83− options = ([],Nothing) :|

103+ ([],Nothing) :|

84− (maybe [] (NEL.toList . (fmap (fmap (Just . promisedDyn @x))))

104+ (maybe [] (NEL.toList . getStashValue . fmap Just) $ buildFrom @x dict

85− $ buildFrom @x dict)

105+ )

86−

87−instance Typeable a => Breakdown (Atom a) where

88− breakdown = pure . toDyn . unAtom

106

90deriving via (Atom ()) instance Breakdown ()

107deriving via (Atom ()) instance Breakdown ()

91deriving via (Atom Int) instance Breakdown Int

108deriving via (Atom Int) instance Breakdown Int

109

110+instance Typeable a => Breakdown (Atom a) where

111+ breakdown = pure . toDyn . unAtom

112+

113

94instance (Typeable a, Breakdown a) => Breakdown [a] where

114instance (Typeable a, Breakdown a) => Breakdown [a] where

95 breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)

115 breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)

src/Roboservant/Types/ReifiedApi.hs+95−61

@@ -2,10 +2,13 @@

2{-# LANGUAGE AllowAmbiguousTypes #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DerivingStrategies #-}

5+{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE GADTs #-}

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7{-# LANGUAGE LambdaCase #-}

9{-# LANGUAGE LambdaCase #-}

8{-# LANGUAGE PolyKinds #-}

10{-# LANGUAGE PolyKinds #-}

11+{-# LANGUAGE RecordWildCards #-}

9{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE StandaloneDeriving #-}

13{-# LANGUAGE StandaloneDeriving #-}

11{-# LANGUAGE TupleSections #-}

14{-# LANGUAGE TupleSections #-}

@@ -18,45 +21,75 @@ module Roboservant.Types.ReifiedApi where

20import Control.Monad.Except (runExceptT)

23import Control.Monad.Except (runExceptT)

24+import Data.Bifunctor

25+-- import Data.Dependent.Sum

21−import Data.Dynamic (Dynamic, toDyn)

26+import Data.Dynamic (Dynamic)

22−import Data.Function ((&))

27+import Data.Kind

28+import Data.List.NonEmpty (NonEmpty)

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

29+import Data.Typeable (Typeable)

30+import GHC.Generics ((:*:)(..))

24import GHC.TypeLits (Symbol)

31import GHC.TypeLits (Symbol)

32+import Roboservant.Types.Breakdown

33+import Roboservant.Types.FlattenServer

25import Servant

34import Servant

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

35import Servant.API.Modifiers(FoldRequired,FoldLenient)

27−import Roboservant.Types.FlattenServer

36+import qualified Data.Text as T

28−import Roboservant.Types.Breakdown

37+import qualified Data.Vinyl as V

29−import Data.List.NonEmpty (NonEmpty)

38+import qualified Data.Vinyl.Curry as V

39+import qualified Type.Reflection as R

32newtype ApiOffset = ApiOffset Int

42newtype ApiOffset = ApiOffset Int

33 deriving (Eq, Show, Ord)

43 deriving (Eq, Show, Ord)

34 deriving newtype (Enum, Num)

44 deriving newtype (Enum, Num)

36−type ReifiedEndpoint = ([(TypeRep

46+type TypedF = (:*:) R.TypeRep

37− , Stash -> Maybe (NonEmpty ([Provenance], Dynamic)))]

47+

38− , Dynamic)

48+newtype Argument a = Argument

49+ { getArgument :: Stash -> Maybe (StashValue a)

50+ }

51+

52+data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint

53+ { reArguments :: V.Rec (TypedF Argument) as

54+ , reEndpointFunc :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))

55+ }

40type ReifiedApi = [(ApiOffset, ReifiedEndpoint)]

57type ReifiedApi = [(ApiOffset, ReifiedEndpoint)]

59+tagType :: Typeable a => f a -> TypedF f a

60+tagType = (R.typeRep :*:)

43class ToReifiedApi (endpoints :: [*]) where

62class ToReifiedApi (endpoints :: [*]) where

44 toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi

63 toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi

65+class ( V.Curried (EndpointArgs endpoint) (Handler (EndpointRes endpoint)) ~ Server endpoint

66+ , V.RecordToList (EndpointArgs endpoint)

67+ , V.RMap (EndpointArgs endpoint)

46−class ToReifiedEndpoint (endpoint :: *) where

68+ ) => ToReifiedEndpoint (endpoint :: *) where

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

69+ type EndpointArgs endpoint :: [Type]

70+ type EndpointRes endpoint :: Type

71+

72+ reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)

49instance ToReifiedApi '[] where

74instance ToReifiedApi '[] where

50 toReifiedApi NoEndpoints _ = []

75 toReifiedApi NoEndpoints _ = []

52instance

77instance

78+ ( Typeable (EndpointRes endpoint)

79+ , NormalizeFunction (ServerT endpoint Handler)

80+ , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either ServerError (NonEmpty Dynamic)))

81+ , ToReifiedEndpoint endpoint

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

82+ , ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)

83+ ) =>

54 ToReifiedApi (endpoint : endpoints)

84 ToReifiedApi (endpoint : endpoints)

55 where

85 where

56 toReifiedApi (endpoint `AnEndpoint` endpoints) _ =

86 toReifiedApi (endpoint `AnEndpoint` endpoints) _ =

57− (0,) (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))

87+ (0, ReifiedEndpoint

88+ { reArguments = reifiedEndpointArguments @endpoint

89+ , reEndpointFunc = normalize endpoint

90+ }

91+ )

58− : map

92+ : (map . first) (+1)

59− (\(n, x) -> (n + 1, x))

60 (toReifiedApi endpoints (Proxy @endpoints))

93 (toReifiedApi endpoints (Proxy @endpoints))

62class NormalizeFunction m where

95class NormalizeFunction m where

@@ -73,35 +106,37 @@ instance (Typeable x, Breakdown x) => NormalizeFunction (Handler x) where

73 Left serverError -> pure (Left serverError)

106 Left serverError -> pure (Left serverError)

74 Right x -> pure $ Right $ breakdown x

107 Right x -> pure $ Right $ breakdown x

108

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

77−

78instance

109instance

79 (Typeable responseType, Breakdown responseType) =>

110 (Typeable responseType, Breakdown responseType) =>

80 ToReifiedEndpoint (Verb method statusCode contentTypes responseType)

111 ToReifiedEndpoint (Verb method statusCode contentTypes responseType)

81 where

112 where

82− toReifiedEndpoint endpoint _ = id

113+ type EndpointArgs (Verb method statusCode contentTypes responseType) = '[]

83− ([], endpoint)

114+ type EndpointRes (Verb method statusCode contentTypes responseType) = responseType

115+ reifiedEndpointArguments = V.RNil

116

85instance

117instance

86 (ToReifiedEndpoint endpoint) =>

118 (ToReifiedEndpoint endpoint) =>

87 ToReifiedEndpoint ((x :: Symbol) :> endpoint)

119 ToReifiedEndpoint ((x :: Symbol) :> endpoint)

88 where

120 where

89− toReifiedEndpoint endpoint _ =

121+ type EndpointArgs ((x :: Symbol) :> endpoint) = EndpointArgs endpoint

90− toReifiedEndpoint endpoint (Proxy @endpoint)

122+ type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint

123+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint

124

92instance

125instance

93 (ToReifiedEndpoint endpoint) =>

126 (ToReifiedEndpoint endpoint) =>

94 ToReifiedEndpoint (Description s :> endpoint)

127 ToReifiedEndpoint (Description s :> endpoint)

95 where

128 where

96− toReifiedEndpoint endpoint _ =

129+ type EndpointArgs (Description s :> endpoint) = EndpointArgs endpoint

97− toReifiedEndpoint endpoint (Proxy @endpoint)

130+ type EndpointRes (Description s :> endpoint) = EndpointRes endpoint

131+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint

132

99instance

133instance

100 (ToReifiedEndpoint endpoint) =>

134 (ToReifiedEndpoint endpoint) =>

101 ToReifiedEndpoint (Summary s :> endpoint)

135 ToReifiedEndpoint (Summary s :> endpoint)

102 where

136 where

103− toReifiedEndpoint endpoint _ =

137+ type EndpointArgs (Summary s :> endpoint) = EndpointArgs endpoint

104− toReifiedEndpoint endpoint (Proxy @endpoint)

138+ type EndpointRes (Summary s :> endpoint) = EndpointRes endpoint

139+ reifiedEndpointArguments = reifiedEndpointArguments @endpoint

105

140

106instance

141instance

107 (Typeable requestType

142 (Typeable requestType

@@ -109,58 +144,57 @@ instance

109 ,ToReifiedEndpoint endpoint) =>

144 ,ToReifiedEndpoint endpoint) =>

110 ToReifiedEndpoint (QueryFlag name :> endpoint)

145 ToReifiedEndpoint (QueryFlag name :> endpoint)

111 where

146 where

112− toReifiedEndpoint endpoint _ =

147+ type EndpointArgs (QueryFlag name :> endpoint) = Bool ': EndpointArgs endpoint

113− toReifiedEndpoint endpoint (Proxy @endpoint)

148+ type EndpointRes (QueryFlag name :> endpoint) = EndpointRes endpoint

114− & \(args, result) -> ((typeRep (Proxy @Bool),buildFrom @Bool) : args, result)

149+ reifiedEndpointArguments = tagType (Argument (buildFrom @Bool)) V.:& reifiedEndpointArguments @endpoint

150+

151+type IfLenient s mods t = If (FoldLenient mods) (Either s t) t

152+type IfRequired mods t = If (FoldRequired mods) t (Maybe t)

153+type IfRequiredLenient s mods t = IfRequired mods (IfLenient s mods t)

115

154

116instance

155instance

117− ( Typeable (If (FoldRequired mods) paramType (Maybe paramType))

118− , BuildFrom (If (FoldRequired mods) paramType (Maybe paramType))

156+ ( BuildFrom (IfRequiredLenient T.Text mods paramType)

119 , ToReifiedEndpoint endpoint

157 , ToReifiedEndpoint endpoint

120− , SBoolI (FoldRequired mods)) =>

158+ ) =>

121 ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)

159 ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)

122 where

160 where

123− toReifiedEndpoint endpoint _ =

161+ type EndpointArgs (QueryParam' mods name paramType :> endpoint) = IfRequiredLenient T.Text mods paramType ': EndpointArgs endpoint

124− toReifiedEndpoint endpoint (Proxy @endpoint)

162+ type EndpointRes (QueryParam' mods name paramType :> endpoint) = EndpointRes endpoint

125− & \(args, result) ->

163+ reifiedEndpointArguments =

126− ((typeRep (Proxy @(If (FoldRequired mods) paramType (Maybe paramType)))

164+ tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods paramType)))

127− ,buildFrom @(If (FoldRequired mods) paramType (Maybe paramType)))

165+ V.:& reifiedEndpointArguments @endpoint

128− : args, result)

166+

129

167

130instance

168instance

131− ( Typeable (If (FoldRequired mods) headerType (Maybe headerType))

132− , BuildFrom (If (FoldRequired mods) headerType (Maybe headerType))

169+ ( BuildFrom (IfRequiredLenient T.Text mods headerType)

133 , ToReifiedEndpoint endpoint

170 , ToReifiedEndpoint endpoint

134− , SBoolI (FoldRequired mods)) =>

171+ ) =>

135 ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)

172 ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)

136 where

173 where

137− toReifiedEndpoint endpoint _ =

174+ type EndpointArgs (Header' mods headerName headerType :> endpoint) = IfRequiredLenient T.Text mods headerType ': EndpointArgs endpoint

138− toReifiedEndpoint endpoint (Proxy @endpoint)

175+ type EndpointRes (Header' mods headerName headerType :> endpoint) = EndpointRes endpoint

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

176+ reifiedEndpointArguments =

140− ,buildFrom @(If (FoldRequired mods) headerType (Maybe headerType)))

177+ tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))

141−

178+ V.:& reifiedEndpointArguments @endpoint

142− : args, result)

143

179

144instance

180instance

145− ( Typeable captureType

146− , BuildFrom captureType

181+ ( BuildFrom (IfLenient String mods captureType)

147 , ToReifiedEndpoint endpoint) =>

182 , ToReifiedEndpoint endpoint) =>

148 ToReifiedEndpoint (Capture' mods name captureType :> endpoint)

183 ToReifiedEndpoint (Capture' mods name captureType :> endpoint)

149 where

184 where

150− toReifiedEndpoint endpoint _ =

185+ type EndpointArgs (Capture' mods name captureType :> endpoint) = IfLenient String mods captureType ': EndpointArgs endpoint

151− toReifiedEndpoint endpoint (Proxy @endpoint)

186+ type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint

152− & \(args, result) -> ((typeRep (Proxy @captureType)

187+ reifiedEndpointArguments =

153− ,buildFrom @captureType)

188+ tagType (Argument (buildFrom @(IfLenient String mods captureType)))

154− : args, result)

189+ V.:& reifiedEndpointArguments @endpoint

155

190

156instance

191instance

157− ( Typeable (If (FoldLenient mods) (Either String requestType) requestType)

158− , BuildFrom (If (FoldLenient mods) (Either String requestType) requestType)

192+ ( BuildFrom (IfLenient String mods requestType)

159− , ToReifiedEndpoint endpoint, SBoolI (FoldLenient mods)) =>

193+ , ToReifiedEndpoint endpoint) =>

160 ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)

194 ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)

161 where

195 where

162− toReifiedEndpoint endpoint _ =

196+ type EndpointArgs (ReqBody' mods contentTypes requestType :> endpoint) = IfLenient String mods requestType ': EndpointArgs endpoint

163− toReifiedEndpoint endpoint (Proxy @endpoint)

197+ type EndpointRes (ReqBody' mods contentTypes requestType :> endpoint) = EndpointRes endpoint

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

198+ reifiedEndpointArguments =

165− ,buildFrom @(If (FoldLenient mods) (Either String requestType) requestType))

199+ tagType (Argument (buildFrom @(IfLenient String mods requestType)))

166− : args, result)

200+ V.:& reifiedEndpointArguments @endpoint

stack.yaml+4−17

@@ -4,20 +4,7 @@ packages:

5extra-deps:

6- servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234

7−# #- markov-chain-usage-model-0.0.0@sha256:1afa95faeb9213c4d960a669190078b41b89169462b8edd910472980671ba8c0,2112

7+- vinyl-0.13.0

8−# - servant-0.18

8+- dependent-sum-0.7.1.0

9−# - servant-client-0.18

9+- constraints-extras-0.3.0.2

10−# - servant-client-core-0.18

10+- dependent-map-0.4.0.0

11−# - servant-server-0.18

12−# - hspec-hedgehog-0.0.1.2@sha256:aaeeb50a43d2bce8a1850baa3ddf934a964bfe38c64efd59306b0c1421e55b45,1405

13−#- QuickCheck-2.14.1@sha256:01e46d7b0a8d3148288ec977625f62d5516ebb5031a50c63f0453863301b4a79,7736

14−#- random-1.2.0

15−#- splitmix-0.1.0.1@sha256:22f9662e7e8b173421872241edd39350078a9ed4bb9e9f503948c5b483c79276,5253

16−# - git: https://github.com/hedgehogqa/haskell-hedgehog.git

17−# commit: 03714682586e43b5ddf5c00391035471a6e01238

18−# subdirs:

19−# - hedgehog

20−# - git: https://github.com/mwotton/hspec

21−# commit: cd9012414a93cf08f86e409544d4d3a8f282b507

22−# subdirs:

23−# - hspec-core

stack.yaml.lock+60−4

@@ -11,9 +11,65 @@ packages:

11 sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3

12 original:

13 hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234

14+- completed:

15+ hackage: vinyl-0.13.0@sha256:0f247cd3f8682b30881a07de18e6fec52d540646fbcb328420049cc8d63cd407,3724

16+ pantry-tree:

17+ size: 1857

18+ sha256: 860fb95820b595161cdbdec5f376100ebae2d14e5ef0dbe311546202f7525d01

19+ original:

20+ hackage: vinyl-0.13.0

21+- completed:

22+ hackage: dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068

23+ pantry-tree:

24+ size: 290

25+ sha256: 9cbfb32b5a8a782b7a1c941803fd517633cb699159b851c1d82267a9e9391b50

26+ original:

27+ hackage: dependent-sum-0.7.1.0

28+- completed:

29+ hackage: constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853

30+ pantry-tree:

31+ size: 594

32+ sha256: 3ce1012bfb02e4d7def9df19ce80b8cd2b472c691b25b181d9960638673fecd1

33+ original:

34+ hackage: constraints-extras-0.3.0.2

35+- completed:

36+ hackage: dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657

37+ pantry-tree:

38+ size: 551

39+ sha256: 5defa30010904d2ad05a036f3eaf83793506717c93cbeb599f40db1a3632cfc5

40+ original:

41+ hackage: dependent-map-0.4.0.0

42+- completed:

43+ hackage: servant-0.18.2@sha256:f8c9f0e9891a3ada1337a3c0b369333a3b5a2d0909dd3cd09d79bc26adeaca44,5298

44+ pantry-tree:

45+ size: 2662

46+ sha256: e930e814de1aa4d24274bdf18341a50b7ed38604ae4734f730e09238ac5bf7e2

47+ original:

48+ hackage: servant-0.18.2

49+- completed:

50+ hackage: servant-client-0.18.2@sha256:82578ade7468873259bb2fdc9d62290a0f998550900683e1410a237ed4b05410,4591

51+ pantry-tree:

52+ size: 1300

53+ sha256: 6324892c77bedbce32f0d6f1612fc2cb0d82c163d3be39efb951d3cc3792ce4a

54+ original:

55+ hackage: servant-client-0.18.2

56+- completed:

57+ hackage: servant-client-core-0.18.2@sha256:4cac20d0b0d889a5613a95ec18526afd16abcaf0b4b7ba5fed35c7bf85800162,3638

58+ pantry-tree:

59+ size: 1444

60+ sha256: 90279e27ba5a7f8f4f1761e81d0dded343839316fdbf34d395954487701e29df

61+ original:

62+ hackage: servant-client-core-0.18.2

63+- completed:

64+ hackage: servant-server-0.18.2@sha256:56679af62ab8820a2108da6153d9ae9dde37199e62172365bdaea1458c3f7c2d,5482

65+ pantry-tree:

66+ size: 2614

67+ sha256: 3ac7430134439e4b67f0f5333f63b89d0cb7de5e2e07f0af7801c8e223942b9c

68+ original:

69+ hackage: servant-server-0.18.2

14snapshots:

70snapshots:

15- completed:

71- completed:

16− size: 532379

72+ size: 532380

17− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/8.yaml

73+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/16.yaml

18− sha256: 2ad3210d2ad35f3176005d68369a18e4d984517bfaa2caade76f28ed0b2e0521

74+ sha256: d6b004b095fe2a0b8b14fbc30014ee97e58843b9c9362ddb9244273dda62649e

19− original: lts-16.8

75+ original: lts-16.16