ilyakooo0/roboservant
1
0
Fork 0
mirror of https://github.com/ilyakooo0/roboservant.git synced 2024-10-05 12:37:17 +03:00
Code Issues Packages Projects Releases Wiki Activity

polishing interface for 1.0 release

Browse Source
This commit is contained in:
Mark Wotton 2021-01-03 11:38:22 -05:00
parent a96a0ffa0e
commit 4d4858effe
21 changed files with 306 additions and 289 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
EXAMPLE.md
View File

@ -45,35 +45,15 @@ server introduce = introduce :<|> combine :<|> eliminate
| otherwise = pure ()
```
In the test file, we first define the configuration:
```haskell
defaultConfig :: Config
defaultConfig = Config {
-- you can pass extra values in using the seed argument. This can be useful
-- for things that might not be produceable within the api, like auth tokens.
seed = [hashedDyn "blah"]
, maxRuntime = 0.5
-- if we get to 1000 interactions with the api, call it quits.
, maxReps = 1000
-- if you're using this inside quickcheck or hedgehog, you might want to set this
-- from their seed to make sure it stays deterministic
, rngSeed = 0
-- 0 to 100: fail tests if we hit less than this percentage of endpoints.
, coverageThreshold = 0
}
```
and the tests: the faulty server should fail and the good server should pass.
In the test file, we first define the tests: the faulty server should fail and the good server should pass.
```haskell
spec = describe "example" $ do
it "good server should not fail" $ do
fuzz @Api goodServer defaultConfig { coverageThreshold = 0.99 } (pure ())
fuzz @Api goodServer defaultConfig { coverageThreshold = 0.99 }
>>= (`shouldSatisfy` isNothing)
it "bad server should fail" $ do
fuzz @Api badServer defaultConfig { coverageThreshold = 0.99 } (pure ())
fuzz @Api badServer defaultConfig { coverageThreshold = 0.99 }
>>= (`shouldSatisfy` serverFailure)
```

4
roboservant.cabal
View File

@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: 1a4c7ba230ea0cde1208ffe68cfb5433046265dea94f292c81d73644caa87cd6
-- hash: 3eb8db6b6899ba904be853bb6865aba4f208077587e89f5377df3169743034b0
name: roboservant
version: 0.1.0.2
@ -32,6 +32,8 @@ library
Roboservant.Types
Roboservant.Types.Breakdown
Roboservant.Types.BuildFrom
Roboservant.Types.Config
Roboservant.Types.Config.Internal
Roboservant.Types.FlattenServer
Roboservant.Types.Internal
Roboservant.Types.ReifiedApi

7
src/Roboservant.hs
View File

@ -1,5 +1,8 @@
module Roboservant (module Roboservant.Direct
,module Roboservant.Types) where
module Roboservant
( module Roboservant.Direct,
module Roboservant.Types,
)
where
import Roboservant.Direct
import Roboservant.Types

71
src/Roboservant/Direct.hs
View File

@ -2,6 +2,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
@ -9,7 +10,6 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE PolyKinds #-}
module Roboservant.Direct
( fuzz,
@ -25,25 +25,30 @@ module Roboservant.Direct
where
import Control.Exception.Lifted
( SomeException,
throw,
Exception,
SomeAsyncException,
catch,
catches,
handle,
Handler(Handler) )
( Exception,
Handler (Handler),
SomeAsyncException,
SomeException,
catch,
catches,
handle,
throw,
)
import Control.Monad.State.Strict
( MonadIO(..), StateT(runStateT), modify', MonadState(get) )
( MonadIO (..),
MonadState (get),
StateT (runStateT),
modify',
)
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Data.Dependent.Map as DM
import Data.Dynamic ( Dynamic(..) )
import Data.Dynamic (Dynamic (..))
import qualified Data.IntSet as IntSet
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NEL
import Data.Maybe (mapMaybe)
import qualified Data.Set as Set
import Data.Time.Clock ( addUTCTime, getCurrentTime, UTCTime )
import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
import qualified Data.Vinyl as V
import qualified Data.Vinyl.Curry as V
import qualified Data.Vinyl.Functor as V
@ -59,8 +64,9 @@ import Roboservant.Types
ToReifiedApi (..),
TypedF,
)
import Roboservant.Types.Config
import Servant (Endpoints, Proxy (Proxy), Server, ServerError (..))
import System.Random ( mkStdGen, Random(randomR), StdGen )
import System.Random (Random (randomR), StdGen, mkStdGen)
import qualified Type.Reflection as R
data RoboservantException
@ -87,15 +93,6 @@ data FuzzOp
}
deriving (Show, Eq)
data Config
= Config
{ seed :: [(Dynamic, Int)],
maxRuntime :: Double, -- seconds to test for
maxReps :: Integer,
rngSeed :: Int,
coverageThreshold :: Double
}
data FuzzState
= FuzzState
{ path :: [FuzzOp],
@ -129,9 +126,8 @@ fuzz ::
(FlattenServer api, ToReifiedApi (Endpoints api)) =>
Server api ->
Config ->
IO () ->
IO (Maybe Report)
fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
fuzz server Config {..} = handle (pure . Just . formatException) $ do
let path = []
stash = addToStash seed mempty
currentRng = mkStdGen rngSeed
@ -140,7 +136,7 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
runStateT
(untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))
FuzzState {..}
print stopreason
logInfo $ show stopreason
pure Nothing
where
-- something less terrible later
@ -150,12 +146,14 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
(unlines [show failureType, show exception])
r
displayDiagnostics FuzzState {..} = liftIO $ do
putStrLn "api endpoints covered"
mapM_ print (Set.toList $ Set.fromList $ map apiOffset path)
putStrLn ""
putStrLn "types in stash"
DM.forWithKey_ (getStash stash) $ \_k v ->
print (NEL.length $ getStashValue v)
logInfo $ unlines $
["api endpoints covered"]
<> (map show . Set.toList . Set.fromList $ map apiOffset path)
<> ["", "types in stash"]
<> DM.foldrWithKey (\_ v r -> (show . NEL.length . getStashValue $ v) : r) [] (getStash stash)
-- <> (map (show . NEL.length . getStashValue ) $ DM.assocs (getStash stash))
-- $ \_k v ->
-- (show . NEL.length $ getStashValue v))
evaluateCoverage f@FuzzState {..}
| coverage > coverageThreshold = pure ()
@ -237,23 +235,22 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
V.Rec (TypedF V.Identity) as ->
m ()
execute fuzzop func args = do
(liftIO . print . (fuzzop,) . stash) =<< get
(liftIO . logInfo . show . (fuzzop,) . stash) =<< get
liftIO (V.runcurry' func argVals) >>= \case
-- parameterise this
Left (serverError :: ServerError) ->
case errHTTPCode serverError of
500 -> throw serverError
_ ->
liftIO $ print ("ignoring non-500 error", serverError)
liftIO . logInfo . show $ ("ignoring non-500 error", serverError)
Right (dyn :: NEL.NonEmpty (Dynamic, Int)) -> do
-- liftIO $ print ("storing", fmap dynTypeRep dyn)
modify'
( \fs@FuzzState {..} ->
fs {stash = addToStash (NEL.toList dyn) stash}
)
where
argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
-- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
-- argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
go ::
(MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
m ()
@ -263,12 +260,12 @@ fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
[ Handler (\(e :: SomeAsyncException) -> throw e),
Handler
( \(e :: SomeException) -> do
displayDiagnostics =<< get
-- displayDiagnostics =<< get
throw . RoboservantException ServerCrashed (Just e) =<< get
)
]
catch
(liftIO checker)
(liftIO healthCheck)
(\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)
addToStash ::

15
src/Roboservant/Types.hs
View File

@ -8,17 +8,18 @@
{-# LANGUAGE UndecidableInstances #-}
module Roboservant.Types
( module Roboservant.Types.Breakdown
, module Roboservant.Types.BuildFrom
, module Roboservant.Types.FlattenServer
, module Roboservant.Types.ReifiedApi
, module Roboservant.Types.Internal
( module Roboservant.Types.Breakdown,
module Roboservant.Types.BuildFrom,
module Roboservant.Types.FlattenServer,
module Roboservant.Types.ReifiedApi,
module Roboservant.Types.Internal,
module Roboservant.Types.Config,
)
where
import Roboservant.Types.Breakdown
import Roboservant.Types.BuildFrom
import Roboservant.Types.Config
import Roboservant.Types.FlattenServer
import Roboservant.Types.ReifiedApi
import Roboservant.Types.Internal
import Roboservant.Types.ReifiedApi

28
src/Roboservant/Types/Breakdown.hs
View File

@ -15,35 +15,39 @@
module Roboservant.Types.Breakdown where
import Data.Dynamic (Dynamic, toDyn)
import Data.List.NonEmpty (NonEmpty (..))
import GHC.Generics
import Data.Typeable (Typeable)
import Roboservant.Types.Internal
import Data.Hashable
import Data.Kind
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NEL
import Data.Typeable (Typeable)
import GHC.Generics
import Roboservant.Types.Internal
breakdown :: (Hashable x, Typeable x, Breakdown x)
=> x -> NonEmpty (Dynamic, Int)
breakdown ::
(Hashable x, Typeable x, Breakdown x) =>
x ->
NonEmpty (Dynamic, Int)
breakdown x = hashedDyn x :| breakdownExtras x
class Breakdown x where
breakdownExtras :: x -> [(Dynamic,Int)]
breakdownExtras :: x -> [(Dynamic, Int)]
instance (Hashable x, Typeable x) => Breakdown (Atom x) where
breakdownExtras _ = []
deriving via (Atom ()) instance Breakdown ()
deriving via (Atom Int) instance Breakdown Int
deriving via (Atom [Char]) instance Breakdown [Char]
class GBreakdown (f :: k -> *) where
gBreakdownExtras :: f a -> [(Dynamic,Int)]
class GBreakdown (f :: k -> *) where
gBreakdownExtras :: f a -> [(Dynamic, Int)]
instance (Hashable x, Typeable x, Generic x, GBreakdown (Rep x)) => Breakdown (Compound (x::Type)) where
instance (Hashable x, Typeable x, Generic x, GBreakdown (Rep x)) => Breakdown (Compound (x :: Type)) where
breakdownExtras = gBreakdownExtras . from . unCompound
instance GBreakdown f => GBreakdown (M1 S c f ) where
instance GBreakdown f => GBreakdown (M1 S c f) where
gBreakdownExtras (M1 f) = gBreakdownExtras f
instance GBreakdown b => GBreakdown (M1 D a b) where
@ -60,5 +64,5 @@ instance (GBreakdown a, GBreakdown b) => GBreakdown (a :+: b) where
L1 a -> gBreakdownExtras a
R1 a -> gBreakdownExtras a
instance (Hashable a, Typeable a, Breakdown a) => GBreakdown (K1 R a) where
instance (Hashable a, Typeable a, Breakdown a) => GBreakdown (K1 R a) where
gBreakdownExtras (K1 c) = NEL.toList $ breakdown c

87
src/Roboservant/Types/BuildFrom.hs
View File

@ -1,55 +1,52 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Roboservant.Types.BuildFrom where
import Control.Monad(filterM)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NEL
import Data.Typeable (Typeable)
import Control.Monad (filterM)
import qualified Data.Dependent.Map as DM
import qualified Type.Reflection as R
import Data.Kind
import Roboservant.Types.Internal
import Data.Hashable
import qualified Data.IntSet as IntSet
import Data.Kind
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NEL
import Data.Typeable (Typeable)
import GHC.Generics
import Roboservant.Types.Internal
import qualified Type.Reflection as R
buildFrom :: forall x . (Hashable x, BuildFrom x, Typeable x) => Stash -> Maybe (StashValue x)
buildFrom :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> Maybe (StashValue x)
buildFrom = buildStash . buildFrom'
where
buildStash :: [([Provenance], x)] -> Maybe (StashValue x)
buildStash = fmap (foldr1 addStash . fmap promoteToStash) . NEL.nonEmpty
buildStash = fmap (foldr1 addStash . fmap promoteToStash) . NEL.nonEmpty
promoteToStash :: ([Provenance], x) -> StashValue x
promoteToStash (p,x) = StashValue (pure (p,x))
(IntSet.singleton (hash x))
-- | sorta fiddly. looks like (<>), but in general it's not safe to add arbitrary StashValues, because
-- there's no guarantee that they came from the same run, which would invalidate all the provenance stuff.
-- in this context it's safe because we have no access to anything else.
--
-- we _do_ have to check here that the new elements are not already contained, however.
promoteToStash (p, x) =
StashValue
(pure (p, x))
(IntSet.singleton (hash x))
addStash :: StashValue x -> StashValue x -> StashValue x
addStash old (StashValue newVal _)
= let insertableVals = NEL.filter ((`IntSet.notMember` stashHash old) . hash) newVal
in StashValue ( addListToNE (getStashValue old) insertableVals )
(IntSet.union (IntSet.fromList . map hash . fmap snd . NEL.toList $ newVal) (stashHash old))
addStash old (StashValue newVal _) =
let insertableVals = NEL.filter ((`IntSet.notMember` stashHash old) . hash) newVal
in StashValue
(addListToNE (getStashValue old) insertableVals)
(IntSet.union (IntSet.fromList . map hash . fmap snd . NEL.toList $ newVal) (stashHash old))
addListToNE :: NonEmpty a -> [a] -> NonEmpty a
addListToNE ne l = NEL.fromList (NEL.toList ne <> l)
buildFrom' :: forall x . (Hashable x, BuildFrom x, Typeable x) => Stash -> [([Provenance], x)]
buildFrom' stash = maybe [] (NEL.toList . getStashValue) (DM.lookup R.typeRep (getStash stash))
<> extras stash
buildFrom' :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> [([Provenance], x)]
buildFrom' stash =
maybe [] (NEL.toList . getStashValue) (DM.lookup R.typeRep (getStash stash))
<> extras stash
class (Hashable x, Typeable x) => BuildFrom (x :: Type) where
extras :: Stash -> [([Provenance], x)]
@ -64,17 +61,18 @@ deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, BuildFrom x)
-- this isn't wonderful, but we need a hand-rolled instance for recursive datatypes right now.
-- with an arbitrary-ish interface, we could use a size parameter, rng access etc.
instance (BuildFrom x) => BuildFrom [x] where
extras stash = map (\xs -> (concatMap fst xs,map snd xs)) $ powerset $ extras @x stash
extras stash = map (\xs -> (concatMap fst xs, map snd xs)) $ powerset $ extras @x stash
where
powerset xs = filterM (const [True, False]) xs
instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (Compound (x::Type)) where
instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (Compound (x :: Type)) where
extras stash = fmap (Compound . to) <$> gExtras stash
deriving via (Atom Int) instance BuildFrom Int
deriving via (Atom Char) instance BuildFrom Char
class GBuildFrom (f :: k -> *) where
class GBuildFrom (f :: k -> *) where
gExtras :: Stash -> [([Provenance], f a)]
instance GBuildFrom b => GBuildFrom (M1 D a b) where
@ -82,14 +80,15 @@ instance GBuildFrom b => GBuildFrom (M1 D a b) where
-- not recursion safe!
instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :+: b) where
gExtras stash = (fmap L1 <$> gExtras stash)
<> (fmap R1 <$> gExtras stash)
gExtras stash =
(fmap L1 <$> gExtras stash)
<> (fmap R1 <$> gExtras stash)
instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :*: b) where
gExtras stash = [ (pa<>pb, a' :*: b') | (pa,a') <- gExtras stash , (pb,b') <- gExtras stash]
gExtras stash = [(pa <> pb, a' :*: b') | (pa, a') <- gExtras stash, (pb, b') <- gExtras stash]
instance GBuildFrom b => GBuildFrom (M1 C a b) where
gExtras =fmap (fmap M1) . gExtras
gExtras = fmap (fmap M1) . gExtras
instance GBuildFrom b => GBuildFrom (M1 S a b) where
gExtras = fmap (fmap M1) . gExtras
@ -98,4 +97,4 @@ instance BuildFrom a => GBuildFrom (K1 i a) where
gExtras = fmap (fmap K1) . buildFrom'
instance GBuildFrom U1 where
gExtras _ = [([],U1)]
gExtras _ = [([], U1)]

29
src/Roboservant/Types/Config.hs Normal file
View File

@ -0,0 +1,29 @@
module Roboservant.Types.Config where
import Data.Dynamic
data Config
= Config
{ seed :: [(Dynamic, Int)],
maxRuntime :: Double, -- seconds to test for
maxReps :: Integer,
rngSeed :: Int,
coverageThreshold :: Double,
logInfo :: String -> IO (),
healthCheck :: IO ()
}
defaultConfig :: Config
defaultConfig =
Config
{ seed = [],
maxRuntime = 0.5,
maxReps = 1000,
rngSeed = 0,
coverageThreshold = 0,
logInfo = const (pure ()),
healthCheck = pure ()
}
noisyConfig :: Config
noisyConfig = defaultConfig {logInfo = print}

12
src/Roboservant/Types/FlattenServer.hs
View File

@ -6,8 +6,8 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- | terrible name, this really just pulls stuff out where we can fiddle with it.
-- | terrible name, this really just pulls stuff out where we can fiddle with it.
module Roboservant.Types.FlattenServer where
import Servant
@ -19,10 +19,9 @@ data Bundled endpoints where
class FlattenServer api where
flattenServer :: Server api -> Bundled (Endpoints api)
instance
( FlattenServer api
, Endpoints endpoint ~ '[endpoint]
( FlattenServer api,
Endpoints endpoint ~ '[endpoint]
) =>
FlattenServer (endpoint :<|> api)
where
@ -37,9 +36,8 @@ instance
flattenServer server = server `AnEndpoint` NoEndpoints
instance
( Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType],
HasServer (Verb method statusCode contentTypes responseType) '[]
( Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType],
HasServer (Verb method statusCode contentTypes responseType) '[]
) =>
FlattenServer (Verb method statusCode contentTypes responseType)
where

44
src/Roboservant/Types/Internal.hs
View File

@ -1,49 +1,53 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Roboservant.Types.Internal where
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Map.Strict as Map
import qualified Data.Dependent.Map as DM
import Data.Dependent.Map (DMap)
import qualified Type.Reflection as R
import Data.Dependent.Sum
import Data.IntSet(IntSet)
import Data.Hashable(Hashable,hash)
import GHC.Generics(Generic)
import Data.Typeable(Typeable)
import Data.Dynamic(Dynamic,toDyn)
import Data.Dynamic (Dynamic, toDyn)
import Data.Hashable (Hashable, hash)
import Data.IntSet (IntSet)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map.Strict as Map
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import qualified Type.Reflection as R
data Provenance
= Provenance R.SomeTypeRep Int
deriving (Show,Eq,Generic)
deriving (Show, Eq, Generic)
instance Hashable Provenance
data StashValue a = StashValue { getStashValue :: NonEmpty ([Provenance], a)
, stashHash :: IntSet
}
data StashValue a
= StashValue
{ getStashValue :: NonEmpty ([Provenance], a),
stashHash :: IntSet
}
deriving (Functor, Show)
-- wrap in newtype to give a custom Show instance, since the normal
-- instance for DMap is not happy since StashValue needs Show a to show
newtype Stash = Stash { getStash :: DMap R.TypeRep StashValue }
newtype Stash = Stash {getStash :: DMap R.TypeRep StashValue}
deriving (Semigroup, Monoid)
instance Show Stash where
showsPrec i (Stash x) = showsPrec i $
Map.fromList . map (\(tr :=> StashValue vs _) -> (R.SomeTypeRep tr, fmap fst vs)) $ DM.toList x
showsPrec i (Stash x) =
showsPrec i
$ Map.fromList . map (\(tr :=> StashValue vs _) -> (R.SomeTypeRep tr, fmap fst vs))
$ DM.toList x
-- | Can't be built up from parts, can't be broken down further.
newtype Atom x = Atom { unAtom :: x }
deriving newtype (Hashable,Typeable)
newtype Atom x = Atom {unAtom :: x}
deriving newtype (Hashable, Typeable)
-- | can be broken down and built up from generic pieces
newtype Compound x = Compound { unCompound :: x }
deriving newtype (Hashable,Typeable)
newtype Compound x = Compound {unCompound :: x}
deriving newtype (Hashable, Typeable)
hashedDyn :: (Hashable a, Typeable a) => a -> (Dynamic, Int)
hashedDyn a = (toDyn a, hash a)

2
stack.yaml
View File

@ -1,6 +1,6 @@
resolver: lts-16.27
# bit faster on ReifiedApi stuff which is unfortunately terribly slow.
compiler: ghc-8.10.3
# compiler: ghc-8.10.3
packages:
- .

22
test/Breakdown.hs
View File

@ -8,29 +8,32 @@
module Breakdown where
import Data.Aeson
import Data.Hashable
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Servant
import Data.Hashable
data Foo = Foo Int String
deriving (Generic, Eq, Show, Typeable)
instance Hashable Foo
instance ToJSON Foo
instance FromJSON Foo
instance ToJSON Foo
instance FromJSON Foo
data SomeSum = A Int | B String
deriving (Generic, Eq, Show, Typeable)
instance Hashable SomeSum
instance ToJSON SomeSum
instance FromJSON SomeSum
type ProductApi = "item" :> ReqBody '[JSON] Int :> Post '[JSON] ()
:<|> "getFoo" :> Get '[JSON] Foo
type ProductApi =
"item" :> ReqBody '[JSON] Int :> Post '[JSON] ()
:<|> "getFoo" :> Get '[JSON] Foo
eliminate :: Int -> Handler ()
eliminate _ = throwError $ err500 {errBody = "eliminate blew up, oh no!"}
@ -38,13 +41,10 @@ eliminate _ = throwError $ err500 {errBody = "eliminate blew up, oh no!"}
productServer :: Server ProductApi
productServer = eliminate :<|> pure (Foo 12 "abc")
type SumApi
= "item" :> ReqBody '[JSON] Int :> Post '[JSON] ()
type SumApi =
"item" :> ReqBody '[JSON] Int :> Post '[JSON] ()
:<|> "getFoo1" :> Get '[JSON] SomeSum
:<|> "getFoo2" :> Get '[JSON] SomeSum
sumServer :: Server SumApi
sumServer = eliminate :<|> pure (B "hi") :<|> pure (A 3)

4
test/Foo.hs
View File

@ -8,17 +8,19 @@
module Foo where
import Data.Aeson
import Data.Hashable
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Servant
import Data.Hashable
newtype Foo = Foo Int
deriving (Generic, Eq, Show, Typeable)
deriving newtype (FromHttpApiData, ToHttpApiData)
instance Hashable Foo
instance ToJSON Foo
instance FromJSON Foo
type Api =

7
test/Headers.hs
View File

@ -8,17 +8,19 @@
module Headers where
import Data.Aeson
import Data.Hashable
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Servant
import Data.Hashable
newtype Foo = Foo Int
deriving (Generic, Eq, Show, Typeable)
deriving newtype (FromHttpApiData, ToHttpApiData)
instance Hashable Foo
instance ToJSON Foo
instance FromJSON Foo
type Api =
@ -33,8 +35,7 @@ combine :: Maybe Foo -> Maybe Foo -> Handler Foo
combine (Just (Foo a)) (Just (Foo b)) = pure (Foo (a + b))
combine (Just a) Nothing = pure a
combine Nothing (Just a) = pure a
combine Nothing Nothing = pure (Foo 1)
combine Nothing Nothing = pure (Foo 1)
eliminate :: Foo -> Handler ()
eliminate (Foo a)

10
test/Nested.hs
View File

@ -10,14 +10,12 @@ module Nested where
import Servant
import Servant.API.Flatten
type Api =
("one" :> Post '[JSON] Int
:<|> "two" :> Post '[JSON] Int
)
:<|> (
"three" :> Post '[JSON] Int
( "one" :> Post '[JSON] Int
:<|> "two" :> Post '[JSON] Int
)
:<|> ( "three" :> Post '[JSON] Int
)
type FlatApi = Flat Api

18
test/Post.hs
View File

@ -7,21 +7,25 @@
module Post where
import GHC.Generics (Generic)
import Servant
import Data.Aeson
import Data.Hashable
import GHC.Generics (Generic)
import Servant
type Api = Get '[JSON] FooPost
:<|> ReqBody '[JSON] FooPost :> Post '[JSON] ()
type Api =
Get '[JSON] FooPost
:<|> ReqBody '[JSON] FooPost :> Post '[JSON] ()
data FooPost = FooPost
deriving (Eq,Show,Generic)
deriving (Eq, Show, Generic)
instance Hashable FooPost
instance ToJSON FooPost
instance FromJSON FooPost
server :: Server Api
server = pure FooPost
:<|> const (pure ())
server =
pure FooPost
:<|> const (pure ())

4
test/Product.hs
View File

@ -8,16 +8,18 @@
module Product where
import Data.Aeson
import Data.Hashable
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Servant
import Data.Hashable
data Foo = Foo Int String
deriving (Generic, Eq, Show, Typeable)
instance Hashable Foo
instance ToJSON Foo
instance FromJSON Foo
type Api = "item" :> ReqBody '[JSON] Foo :> Post '[JSON] ()

14
test/Seeded.hs
View File

@ -8,22 +8,26 @@
module Seeded where
import Data.Aeson
import Data.Hashable
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Servant
import Data.Hashable
newtype Seed = Seed Int
deriving (Generic, Eq, Show, Typeable)
deriving newtype (FromHttpApiData, ToHttpApiData)
instance ToJSON Seed
instance FromJSON Seed
instance Hashable Seed
type Api = Capture "seed" Seed :> Get '[JSON] ()
:<|> Get '[JSON] ()
type Api =
Capture "seed" Seed :> Get '[JSON] ()
:<|> Get '[JSON] ()
server :: Server Api
server = (\(Seed _) -> error "we blow up if we get here")
:<|> pure ()
server =
(\(Seed _) -> error "we blow up if we get here")
:<|> pure ()

140
test/Spec.hs
View File

@ -1,144 +1,130 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
import qualified Breakdown
import Data.Dynamic (toDyn)
import Data.Hashable (Hashable (hash))
import Data.Maybe (isNothing)
import Data.Void (Void)
import qualified Foo
import qualified Seeded
import qualified Valid
import qualified Headers
import qualified Nested
import qualified Post
import qualified Product
import qualified Breakdown
import qualified Nested
import Test.Hspec.Core.Spec(ResultStatus(Failure,Success),resultStatus,itemExample,FailureReason(Reason),mapSpecItem_)
import Data.Dynamic(toDyn)
import qualified Roboservant as RS
import qualified Seeded
import Test.Hspec
import Data.Void ( Void )
import Data.Maybe ( isNothing )
import Data.Hashable ( Hashable(hash) )
import Test.Hspec.Core.Spec (FailureReason (Reason), ResultStatus (Failure, Success), itemExample, mapSpecItem_, resultStatus)
import qualified Valid
main :: IO ()
main = hspec spec
noCheck :: IO ()
noCheck = pure ()
defaultConfig :: RS.Config
defaultConfig = RS.Config
{ RS.seed = []
, RS.maxRuntime = 0.5
, RS.maxReps = 1000
, RS.rngSeed = 0
, RS.coverageThreshold = 0
}
spec :: Spec
spec = do
describe "Basic usage" $ do
describe "noError" $ do
it "finds no error in a valid app" $ do
RS.fuzz @Valid.Api Valid.server defaultConfig noCheck
RS.fuzz @Valid.Api Valid.server RS.defaultConfig
>>= (`shouldSatisfy` isNothing)
it "finds no error in a valid generic app" $ do
RS.fuzz @Valid.RoutedApi Valid.routedServer defaultConfig noCheck
RS.fuzz @Valid.RoutedApi Valid.routedServer RS.defaultConfig
>>= (`shouldSatisfy` isNothing)
it "does fail coverage check" $ do
r <- RS.fuzz @Valid.Api Valid.server defaultConfig { RS.coverageThreshold = 0.6 } noCheck
fmap (RS.failureReason . RS.rsException) r `shouldSatisfy`
(\case
Just (RS.InsufficientCoverage _) -> True
_ -> False)
r <- RS.fuzz @Valid.Api Valid.server RS.defaultConfig {RS.coverageThreshold = 0.6}
fmap (RS.failureReason . RS.rsException) r
`shouldSatisfy` ( \case
Just (RS.InsufficientCoverage _) -> True
_ -> False
)
describe "posted body" $ do
it "passes a coverage check using a posted body" $ do
RS.fuzz @Post.Api Post.server defaultConfig { RS.coverageThreshold = 0.99 } noCheck
RS.fuzz @Post.Api Post.server RS.defaultConfig {RS.coverageThreshold = 0.99}
>>= (`shouldSatisfy` isNothing)
describe "seeded" $ do
shouldFail $
it "finds an error using information passed in" $
let res = Seeded.Seed 1 in
RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [(toDyn res,hash res) ] }) noCheck
>>= (`shouldSatisfy` isNothing)
shouldFail
$ it "finds an error using information passed in"
$ let res = Seeded.Seed 1
in RS.fuzz @Seeded.Api Seeded.server (RS.defaultConfig {RS.seed = [(toDyn res, hash res)]})
>>= (`shouldSatisfy` isNothing)
describe "Foo" $ do
it "finds an error in a basic app" $
RS.fuzz @Foo.Api Foo.server defaultConfig noCheck
RS.fuzz @Foo.Api Foo.server RS.defaultConfig
>>= (`shouldSatisfy` serverFailure)
describe "BuildFrom" $ do
describe "headers (and sum types)" $ do
it "should find a failure that's dependent on using header info" $ do
RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
RS.fuzz @Headers.Api Headers.server RS.defaultConfig
>>= (`shouldSatisfy` serverFailure)
describe "product types" $ do
it "should find a failure that's dependent on creating a product" $ do
RS.fuzz @Product.Api Product.server defaultConfig { RS.seed = [RS.hashedDyn 'a', RS.hashedDyn (1::Int)]} noCheck
RS.fuzz @Product.Api Product.server RS.defaultConfig {RS.seed = [RS.hashedDyn 'a', RS.hashedDyn (1 :: Int)]}
>>= (`shouldSatisfy` serverFailure)
describe "Breakdown" $ do
it "handles products" $ do
RS.fuzz @Breakdown.ProductApi Breakdown.productServer defaultConfig noCheck
RS.fuzz @Breakdown.ProductApi Breakdown.productServer RS.defaultConfig
>>= (`shouldSatisfy` serverFailure)
it "handles sums" $ do
RS.fuzz @Breakdown.SumApi Breakdown.sumServer defaultConfig noCheck
RS.fuzz @Breakdown.SumApi Breakdown.sumServer RS.defaultConfig
>>= (`shouldSatisfy` serverFailure)
describe "flattening" $ do
-- | we don't actually do much here, this is just here to document the appropriate response
-- if you get a type error with a nested api.
-- we don't actually do much here, this is just here to document the appropriate response
-- if you get a type error with a nested api.
it "can handle nested apis" $ do
RS.fuzz @(Nested.FlatApi) Nested.server defaultConfig { RS.coverageThreshold = 0.99 } noCheck
RS.fuzz @(Nested.FlatApi) Nested.server RS.defaultConfig {RS.coverageThreshold = 0.99}
>>= (`shouldSatisfy` isNothing)
serverFailure :: Maybe RS.Report -> Bool
serverFailure = \case
Just RS.Report{..} ->
let RS.RoboservantException{..} = rsException
in failureReason /= RS.NoPossibleMoves
Just RS.Report {..} ->
let RS.RoboservantException {..} = rsException
in failureReason /= RS.NoPossibleMoves
_ -> False
deriving via (RS.Atom Foo.Foo) instance RS.Breakdown Foo.Foo
deriving via (RS.Atom Foo.Foo) instance RS.BuildFrom Foo.Foo
deriving via (RS.Atom Headers.Foo) instance RS.Breakdown Headers.Foo
deriving via (RS.Atom Headers.Foo) instance RS.BuildFrom Headers.Foo
deriving via (RS.Atom Seeded.Seed) instance RS.Breakdown Seeded.Seed
deriving via (RS.Atom Seeded.Seed) instance RS.BuildFrom Seeded.Seed
-- instance RS.BuildFrom Seeded.Seed
deriving via (RS.Atom Void) instance RS.BuildFrom Void
deriving via (RS.Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
deriving via (RS.Atom Post.FooPost) instance RS.Breakdown Post.FooPost
deriving via (RS.Compound Product.Foo) instance RS.BuildFrom Product.Foo
deriving via (RS.Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
deriving via (RS.Compound Breakdown.Foo) instance RS.Breakdown Breakdown.Foo
deriving via (RS.Compound Product.Foo) instance RS.BuildFrom Product.Foo
deriving via (RS.Compound Breakdown.SomeSum) instance RS.Breakdown Breakdown.SomeSum
-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.
-- this is often useful when testing tests.
shouldFail :: SpecWith a -> SpecWith a
shouldFail = mapSpecItem_ (\i -> i {
itemExample = \p a cb -> do
r <- (itemExample i) p a cb
pure r {resultStatus = case resultStatus r of
Success -> Failure Nothing (Reason "Unexpected success")
Failure _ _ -> Success
x -> x
}
})
shouldFail =
mapSpecItem_
( \i ->
i
{ itemExample = \p a cb -> do
r <- (itemExample i) p a cb
pure
r
{ resultStatus = case resultStatus r of
Success -> Failure Nothing (Reason "Unexpected success")
Failure _ _ -> Success
x -> x
}
}
)

22
test/UnsafeIO.hs
View File

@ -7,16 +7,15 @@
module UnsafeIO where
import Data.Aeson()
import Servant
import Data.IORef (writeIORef, IORef, readIORef, newIORef)
import Control.Monad.Trans (MonadIO(liftIO))
import Control.Monad.Trans (MonadIO (liftIO))
import Data.Aeson ()
import qualified Data.ByteString.Lazy.Char8 as BL8
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Servant
type UnsafeApi =
"add" :> Get '[JSON] ()
:<|> "healthcheck" :> Get '[JSON] ()
:<|> "healthcheck" :> Get '[JSON] ()
healthcheck :: IORef Int -> Handler ()
healthcheck ref = do
@ -25,17 +24,16 @@ healthcheck ref = do
0 -> pure ()
n -> throwError $ err500 {errBody = "observed inconsistency: " <> (BL8.pack $ show n)}
makeServer :: IO (Server UnsafeApi)
makeServer = do
ref <- newIORef 0
pure $ unsafeMunge ref
:<|> healthcheck ref
pure $
unsafeMunge ref
:<|> healthcheck ref
unsafeMunge :: IORef Int -> Handler ()
unsafeMunge ref = liftIO $ do
t <- readIORef ref
writeIORef ref (t+1)
writeIORef ref (t + 1)
t2 <- readIORef ref
writeIORef ref (t2-1)
writeIORef ref (t2 -1)

29
test/Valid.hs
View File

@ -7,22 +7,26 @@
module Valid where
import Servant
import Data.Void
import GHC.Generics
import Servant
import Servant.API.Generic
import Servant.Server.Generic
type Api = Get '[JSON] Int
:<|> Capture "void" Void :> Get '[JSON] ()
type Api =
Get '[JSON] Int
:<|> Capture "void" Void :> Get '[JSON] ()
data Routes route
= Routes
{ getInt :: route :-
Get '[JSON] Int
, captureIt :: route :-
Capture "void" Void :> Get '[JSON] ()
} deriving Generic
{ getInt ::
route
:- Get '[JSON] Int,
captureIt ::
route
:- Capture "void" Void :> Get '[JSON] ()
}
deriving (Generic)
type RoutedApi = ToServantApi Routes
@ -31,10 +35,11 @@ routedServer :: Server RoutedApi
routedServer = genericServer routes
routes :: Routes AsServer
routes = Routes
{ getInt = pure 7
, captureIt = const (pure ())
}
routes =
Routes
{ getInt = pure 7,
captureIt = const (pure ())
}
server :: Server Api
server = pure 7 :<|> const (pure ())