ilyakooo0/roboservant
1
0
Fork 0
mirror of https://github.com/ilyakooo0/roboservant.git synced 2024-08-15 19:10:24 +03:00
Code Issues Packages Projects Releases Wiki Activity

add some examples, remove old code

Browse Source
This commit is contained in:
Mark Wotton 2020-09-13 13:42:23 -04:00
parent 3bd7a4939c
commit 0724d7aa74
9 changed files with 219 additions and 647 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
package.yaml
View File

@ -1,48 +1,42 @@
name: roboservant
version: 0.1.0.0
github: "githubuser/roboservant"
github: "mwotton/roboservant"
license: BSD3
author: "Author name here"
maintainer: "example@example.com"
copyright: "2020 Author name here"
author: "Mark Wotton, Samuel Schlesinger"
maintainer: "mwotton@gmail.com"
copyright: "2020 Mark Wotton, Samuel Schlesinger"
synopsis: Automatic session-aware servant testing
category: Web
description: Please see the README on GitHub at <https://github.com/githubuser/roboservant#readme>
extra-source-files:
- README.md
- ChangeLog.md
# Metadata used when publishing your package
# synopsis: Short description of your package
# category: Web
# To avoid duplicated efforts in documentation and dealing with the
# complications of embedding Haddock markup inside cabal files, it is
# common to point users to the README.md file.
description: Please see the README on GitHub at <https://github.com/githubuser/roboservant#readme>
dependencies:
- base >= 4.7 && < 5
- QuickCheck
- bytestring
- hedgehog
- constrained-dynamic
- containers
- hedgehog
- http-client
- http-media
- QuickCheck
- quickcheck-state-machine >= 0.7
- mtl
- quickcheck-state-machine >= 0.7
- servant >= 0.17
- servant-client >= 0.17
- servant-flatten
- servant-server >= 0.17
- string-conversions
# test deps
- hspec
- QuickCheck
- warp
- aeson
- wai
ghc-options: -Wall
library:
source-dirs: src

31
roboservant.cabal
View File

@ -1,19 +1,21 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.31.2.
-- This file has been generated from package.yaml by hpack version 0.33.0.
--
-- see: https://github.com/sol/hpack
--
-- hash: 9d15f4554f9f8ea8913a6766643b63ee6633016374fc98164e81058799204a87
-- hash: 51154f1c866aea92673a52985de6810cebda3b2662fddd7b7f88a56725e30041
name: roboservant
version: 0.1.0.0
synopsis: Automatic session-aware servant testing
description: Please see the README on GitHub at <https://github.com/githubuser/roboservant#readme>
homepage: https://github.com/githubuser/roboservant#readme
bug-reports: https://github.com/githubuser/roboservant/issues
author: Author name here
maintainer: example@example.com
copyright: 2020 Author name here
category: Web
homepage: https://github.com/mwotton/roboservant#readme
bug-reports: https://github.com/mwotton/roboservant/issues
author: Mark Wotton, Samuel Schlesinger
maintainer: mwotton@gmail.com
copyright: 2020 Mark Wotton, Samuel Schlesinger
license: BSD3
license-file: LICENSE
build-type: Simple
@ -23,24 +25,22 @@ extra-source-files:
source-repository head
type: git
location: https://github.com/githubuser/roboservant
location: https://github.com/mwotton/roboservant
library
exposed-modules:
Roboservant
Roboservant.ContextualGenRequest
Roboservant.Hedgehog
Roboservant.StateMachine
other-modules:
Paths_roboservant
hs-source-dirs:
src
ghc-options: -Wall
build-depends:
QuickCheck
, aeson
, base >=4.7 && <5
, bytestring
, constrained-dynamic
, containers
, hedgehog
, hspec
@ -53,24 +53,23 @@ library
, servant-flatten
, servant-server >=0.17
, string-conversions
, wai
, warp
default-language: Haskell2010
test-suite roboservant-test
type: exitcode-stdio-1.0
main-is: Spec.hs
other-modules:
Foo
UnsafeIO
Paths_roboservant
hs-source-dirs:
test
ghc-options: -threaded -rtsopts -with-rtsopts=-N
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
build-depends:
QuickCheck
, aeson
, base >=4.7 && <5
, bytestring
, constrained-dynamic
, containers
, hedgehog
, hspec
@ -84,6 +83,4 @@ test-suite roboservant-test
, servant-flatten
, servant-server >=0.17
, string-conversions
, wai
, warp
default-language: Haskell2010

109
src/Roboservant.hs
View File

@ -1,110 +1,3 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
module Roboservant where
module Roboservant (module Roboservant.StateMachine) where
import Prelude hiding (lookup)
import GHC.TypeLits
import Servant.API
import Roboservant.ContextualGenRequest
import Roboservant.StateMachine
-- | Extract the response types from a single servant endpoint, i.e. one
-- without any ':<|>' type constructors in it.
type family ExtractRespType (path :: *) :: * where
ExtractRespType (_ :> b) = ExtractRespType b
ExtractRespType (Verb (method :: StdMethod) (responseCode :: Nat) (contentTypes :: [*]) (respType :: *)) = respType
-- | Extract the response types from a flattened servant API, i.e. one
-- which has the distributive law (modulo isomorphism) applied to it until
-- it reaches a normal form.
type family ExtractRespTypes (paths :: *) :: [*] where
ExtractRespTypes (a :<|> b) = ExtractRespTypes a <> ExtractRespTypes b
ExtractRespTypes a = '[ExtractRespType a]
-- | Append two type level lists.
type family (<>) (xs :: [k]) (ys :: [k]) :: [k] where
(x ': xs) <> ys = x ': (xs <> ys)
'[] <> ys = ys
-- | A homogeneous-functor-list, I guess.
data List :: (* -> *) -> [*] -> * where
Cons :: f a -> List f as -> List f (a ': as)
Nil :: List f '[]
-- | So we can use efficient container types for specific types if the need
-- arises.
class Listy f a where
cons :: a -> f a -> f a
empty :: f a
uncons :: f a -> Maybe (a, f a)
instance Listy [] a where
cons = (:)
empty = []
uncons = \case
a : as -> Just (a, as)
[] -> Nothing
-- | A function for inserting elements into their slot in the store.
class Insert f a as where
insert :: a -> List f as -> List f as
instance {-# OVERLAPPABLE #-} Listy f a => Insert f a (a ': as) where
insert a (Cons as ls) = Cons (cons a as) ls
instance {-# OVERLAPPABLE #-} Insert f a as => Insert f a (b ': as) where
insert a (Cons as ls) = Cons as (insert a ls)
-- | A function for looking up the container of elements for a specific
-- type in the store.
class Lookup f a as where
lookup :: List f as -> f a
instance {-# OVERLAPPABLE #-} Lookup f a (a ': as) where
lookup (Cons fa ls) = fa
instance {-# OVERLAPPABLE #-} Lookup f a as => Lookup f a (b ': as) where
lookup (Cons fa ls) = lookup ls
deriving instance (Show (List f as), forall a. Show a => Show (f a), Show a)
=> Show (List f (a ': as))
instance Show (List f '[]) where show _ = "Nil"
storeOfApi :: BuildStore [] (ExtractRespTypes api) => List [] (ExtractRespTypes api)
storeOfApi = buildStore
class BuildStore f xs where
buildStore :: List f xs
instance BuildStore f '[] where
buildStore = Nil
instance (BuildStore f as, Listy f a) => BuildStore f (a ': as) where
buildStore = Cons empty buildStore
-- 1.
-- Instead of just the resptype, let's return a tuple of (resptype, '[]::[ ? respType])
-- 2.
-- break down respType into "useful" components
-- data Baz = Baz { key1 :: Key Foo, key2 :: Key Bar }
-- should insert into type-indexed list three elements
-- 'Baz -> whole value
-- '(Key Bar) -> key2
-- '(Key Foo) -> key1
--

238
src/Roboservant/ContextualGenRequest.hs
View File

@ -1,238 +0,0 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Roboservant.ContextualGenRequest where
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS (c2w)
import Data.Data (Proxy (Proxy))
import Data.String (IsString (fromString))
import Data.String.Conversions (cs)
import GHC.TypeLits (KnownSymbol, Nat, symbolVal)
import Network.HTTP.Client (Request,
RequestBody (RequestBodyLBS),
defaultRequest, host, method, path,
port, queryString, requestBody,
requestHeaders, secure)
import Network.HTTP.Media (renderHeader)
import Servant
import Servant.API
import Servant.API.ContentTypes (AllMimeRender, allMimeRender)
import Servant.Client
-- import Test.QuickCheck (Arbitrary, Gen, elements, frequency)
import Data.Dynamic (Dynamic, fromDynamic)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Typeable (TypeRep, Typeable, typeRep)
import Hedgehog
import qualified Hedgehog.Gen as Gen
import Roboservant.Hedgehog
class HasContextualGenRequest a where
genContextualRequest :: Proxy a -> Map TypeRep Dynamic -> Maybe (Int, Gen ( BaseUrl -> Request))
-- | Generatable is functionally equivalent to Arbitrary with a default.
-- It is separate because we want to allow overwriting at will.
class Generatable a where
generator :: Gen [a]
generator = pure []
instance ( HasContextualGenRequest a
, HasContextualGenRequest b)
=> HasContextualGenRequest (a :<|> b) where
genContextualRequest _ store
= case sub of
[] -> Nothing
_ -> Just (newfreq, Gen.frequency sub)
where
newfreq = sum (map fst sub)
sub = catMaybes [l,r]
l = genContextualRequest (Proxy :: Proxy a) store
r = genContextualRequest (Proxy :: Proxy b) store
withGeneratable p store cont = cont <$> genContextualRequest p store
getCandidates p st cont =
case Map.lookup (typeRep p) st of
Nothing -> (0,error "shouldn't ever be invoked")
Just x -> do
case fromDynamic x of
Nothing -> (0,error "shouldn't ever be invoked")
Just candidates -> cont candidates
instance (KnownSymbol path, HasContextualGenRequest b )
=> HasContextualGenRequest (path :> b) where
genContextualRequest _ store =
withGeneratable (Proxy :: Proxy b) store $ \(oldf,old') -> do
( oldf, do
old <- old'
pure $ \burl ->
let r = old burl
oldPath = path r
oldPath' = BS.dropWhile (== BS.c2w '/') oldPath
paths = filter (not . BS.null) [new, oldPath']
in r { path = "/" <> BS.intercalate "/" paths }
)
where
-- (oldf, old) = genContextualRequest (Proxy :: Proxy b) store
new = cs $ symbolVal (Proxy :: Proxy path)
instance HasContextualGenRequest EmptyAPI where
genContextualRequest _ _ = Nothing
instance HasContextualGenRequest api => HasContextualGenRequest (Summary d :> api) where
genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
instance HasContextualGenRequest api => HasContextualGenRequest (Description d :> api) where
genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
instance (HasContextualGenRequest b, Typeable c, ToHttpApiData c )
=> HasContextualGenRequest (Capture' mods x c :> b) where
genContextualRequest _ st = withGeneratable (Proxy :: Proxy b) st $ \(oldf,old) ->
getCandidates (Proxy :: Proxy c) st $ \candidates ->
(oldf
,do
piece :: c <- Gen.choice candidates
old' <- old
pure $ \burl ->
let r = old' burl
in r { path = cs (toUrlPiece piece) <> path r })
-- unsure how CaptureAll works, finish later.
-- instance (HasContextualGenRequest b, ToHttpApiData c, Typeable c )
-- => HasContextualGenRequest (CaptureAll x c :> b) where
-- genContextualRequest _ st = withGeneratable (Proxy :: Proxy b) st $ \(oldf,old) ->
-- getCandidates (Proxy :: Proxy c) st $ \candidates ->
-- (oldf, do
-- old' <- old
-- piece :: c <- Gen.choice candidates
-- let new'' = BS.intercalate "/" . fmap (cs . toUrlPiece) $ piece
-- return $ \burl -> let r = old' burl
-- in r { path = new'' <> path r })
-- -- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
-- -- new = _arbitrary :: Gen [c]
-- instance (KnownSymbol h, HasContextualGenRequest b st, ToHttpApiData c)
-- => HasContextualGenRequest (Header' mods h c :> b) st where
-- genContextualRequest _ = (oldf, do
-- old' <- old
-- new' <- toUrlPiece <$> new -- TODO: generate lenient or/and optional
-- return $ \burl st -> let r = old' burl st in r {
-- requestHeaders = (hdr, cs new') : requestHeaders r })
-- where
-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
-- hdr = fromString $ symbolVal (Proxy :: Proxy h)
-- new = _arbitrary :: Gen c
-- instance (AllMimeRender x c, HasContextualGenRequest b st)
-- => HasContextualGenRequest (ReqBody' mods x c :> b) st where
-- genContextualRequest _ = (oldf, do
-- old' <- old -- TODO: generate lenient
-- new' <- new
-- (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
-- return $ \burl st -> let r = old' burl st in r {
-- requestBody = RequestBodyLBS bd
-- , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
-- })
-- where
-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
-- new = _arbitrary :: Gen c
-- instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
-- => HasContextualGenRequest (QueryParam' mods x c :> b) st where
-- genContextualRequest _ = (oldf, do
-- new' <- new -- TODO: generate lenient or/and optional
-- old' <- old
-- return $ \burl st -> let
-- r = old' burl st
-- newExpr = param <> "=" <> cs (toQueryParam new')
-- qs = queryString r in r {
-- queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs })
-- where
-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
-- param = cs $ symbolVal (Proxy :: Proxy x)
-- new = _arbitrary :: Gen c
-- instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
-- => HasContextualGenRequest (QueryParams x c :> b) st where
-- genContextualRequest _ = (oldf, do
-- (new' :: c) <- _fetch
-- old' <- old
-- return $ \burl st -> let r = old' burl st in r {
-- queryString = queryString r
-- <> if length new' > 0 then fold (toParam <$> new') else ""})
-- where
-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
-- param = cs $ symbolVal (Proxy :: Proxy x)
-- toParam c = param <> "[]=" <> cs (toQueryParam c)
-- fold = foldr1 (\a b -> a <> "&" <> b)
-- instance (KnownSymbol x, HasContextualGenRequest b st)
-- => HasContextualGenRequest (QueryFlag x :> b) st where
-- genContextualRequest _ = (oldf, do
-- old' <- old
-- return $ \burl st -> let r = old' burl st
-- qs = queryString r in r {
-- queryString = if BS.null qs then param else param <> "&" <> qs })
-- where
-- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
-- param = cs $ symbolVal (Proxy :: Proxy x)
-- instance (ReflectMethod method)
-- => HasContextualGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) st where
-- genContextualRequest _ = (1, return $ \burl st -> defaultRequest
-- { host = cs $ baseUrlHost burl
-- , port = baseUrlPort burl
-- , secure = baseUrlScheme burl == Https
-- , method = reflectMethod (Proxy :: Proxy method)
-- })
-- instance (ReflectMethod method)
-- => HasContextualGenRequest (NoContentVerb (method :: k)) st where
-- genContextualRequest _ = (1, return $ \burl st -> defaultRequest
-- { host = cs $ baseUrlHost burl
-- , port = baseUrlPort burl
-- , secure = baseUrlScheme burl == Https
-- , method = reflectMethod (Proxy :: Proxy method)
-- })
-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (RemoteHost :> a) st where
-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (IsSecure :> a) st where
-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (HttpVersion :> a) st where
-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (Vault :> a) st where
-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (WithNamedContext x y a) st where
-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
-- -- TODO: Try logging in
-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (BasicAuth x y :> a) st where
-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)

41
src/Roboservant/Hedgehog.hs
View File

@ -1,41 +0,0 @@
{-# LANGUAGE LambdaCase #-}
module Roboservant.Hedgehog where
import Hedgehog
import Hedgehog.Gen
import qualified Hedgehog.Range as Range
-- | Uses a weighted distribution to randomly select one of the generators in
-- the list.
--
-- This generator shrinks towards the first generator in the list.
--
-- This is to be used when the generator returning a Nothing indicates
-- that it will never succeed so should be abandoned entirely.
--
-- /The input list must be non-empty./
--
frequencyM :: MonadGen m => [(Int, m (Maybe a))] -> m (Maybe a)
frequencyM = \case
[] -> pure Nothing
-- error "Hedgehog.Gen.frequency: used with empty list"
xs0 -> do
let
pick acc n = \case
[] -> pure Nothing
-- error "Hedgehog.Gen.frequency/pick: used with empty list"
(k, x) : xs ->
if n <= k then
x >>= \case
Nothing -> do
-- this one will never come out right, so reassemble list without it
frequencyM (acc <> xs)
Just y -> pure $ Just y
else
pick ((k,x):acc) (n - k) xs
total =
sum (fmap fst xs0)
n <- integral $ Range.constant 1 total
pick [] n xs0

258
src/Roboservant/StateMachine.hs
View File

@ -1,104 +1,41 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-- for servant
{-# LANGUAGE UndecidableInstances #-}
module Roboservant.StateMachine where
import Control.Arrow (second)
-- import Data.Dynamic (Dynamic, fromDynamic)
--import Test.QuickCheck (Property)
-- import Test.StateMachine
import Type.Reflection (SomeTypeRep)
import Servant.API.Flatten (Flat)
import GHC.TypeLits (Nat, Symbol)
import Control.Monad.Except (runExceptT)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic, toDyn)
import Data.Function ((&))
import Control.Concurrent (forkIO)
import Control.Monad ((<=<))
import Control.Monad.IO.Class
import Data.Aeson
import Data.Dynamic
import Data.IORef (IORef, newIORef)
import qualified Data.List.NonEmpty as NEL
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Type.HasClass
import Data.Type.HasClassPreludeInstances
import Data.Typeable (TypeRep, Typeable, typeOf, typeRep)
import Debug.Trace (traceM, traceShowM)
import GHC.Generics (Generic)
import GHC.Generics
import Data.Maybe (mapMaybe)
import Data.Typeable (TypeRep, Typeable, typeRep)
import GHC.IORef (readIORef)
import Control.Monad.Except (runExceptT)
import Hedgehog
import GHC.TypeLits (Symbol)
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Network.HTTP.Client (defaultManagerSettings, newManager)
import Network.Wai
import Network.Wai.Handler.Warp
import Roboservant.ContextualGenRequest
import Servant
import Servant.Client
import Servant.Server (Server)
-- | can then use either `forAllParallelCommands` or `forAllCommands` to turn
-- this into a property
--
-- TODO: how do we tie the model, command and response types to the Server?
-- genStateMachine :: HasContextualGenRequest a => Server a -> StateMachine Model Command IO Response
-- genStateMachine = StateMachine initModel _transition _precondition _postcondition
-- Nothing _generator _shrinker _semantics _mock
-- initModel :: Model r
-- initModel = Model mempty
-- newtype Model r = Model (Map TypeRep Dynamic)
-- data Command r
-- = CallEndpoint
-- | Read (Reference (Opaque (IORef Int)) r)
-- | Write (Reference (Opaque (IORef Int)) r) Int
-- | Increment (Reference (Opaque (IORef Int)) r)
-- data Response r
-- = Created (Reference (Opaque (IORef Int)) r)
-- | ReadValue Int
-- | Written
-- | Incremented
-- deriving Show
-- instance Eq MyDyn where
-- MyDyn a == MyDyn b = show a == show b
import Type.Reflection (SomeTypeRep)
data State v
= State
@ -109,24 +46,30 @@ class FlattenServer api where
flattenServer :: Server api -> Bundled (Endpoints api)
instance
( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api)
, Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api)
, FlattenServer api
) => FlattenServer (endpoint :<|> api) where
( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api),
Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api),
FlattenServer api
) =>
FlattenServer (endpoint :<|> api)
where
flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
instance
( HasServer (x :> api) '[]
, Endpoints (x :> api) ~ '[x :> api]
) => FlattenServer (x :> api) where
( HasServer (x :> api) '[],
Endpoints (x :> api) ~ '[x :> api]
) =>
FlattenServer (x :> api)
where
flattenServer server = server `AnEndpoint` NoEndpoints
instance
( HasServer (Verb method statusCode contentTypes responseType) '[],
Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType]
) => FlattenServer (Verb method statusCode contentTypes responseType) where
) =>
FlattenServer (Verb method statusCode contentTypes responseType)
where
flattenServer server = server `AnEndpoint` NoEndpoints
type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)
type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]
@ -144,18 +87,20 @@ class ToReifiedEndpoint (endpoint :: *) where
instance ToReifiedApi '[] where
toReifiedApi NoEndpoints _ = []
instance (Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler))
=> ToReifiedApi (endpoint : endpoints)
instance
(Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)) =>
ToReifiedApi (endpoint : endpoints)
where
toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))
: map (\(n, x, y, z) -> (n + 1, x, y, z))
(toReifiedApi endpoints (Proxy @endpoints))
where
withOffset (x, y, z) = (0, x, y, z)
toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))
: map
(\(n, x, y, z) -> (n + 1, x, y, z))
(toReifiedApi endpoints (Proxy @endpoints))
where
withOffset (x, y, z) = (0, x, y, z)
class NormalizeFunction m where
type Normal m
type Normal m
normalize :: m -> Normal m
instance NormalizeFunction x => NormalizeFunction (r -> x) where
@ -167,32 +112,36 @@ instance Typeable x => NormalizeFunction (Handler x) where
normalize handler = (runExceptT . runHandler') handler >>= \case
Left serverError -> pure (Left serverError)
Right x -> pure (Right (typeRep (Proxy @x), toDyn x))
instance Typeable responseType
=> ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
where
toReifiedEndpoint endpoint _ =
([], typeRep (Proxy @responseType), endpoint)
instance (ToReifiedEndpoint endpoint)
=> ToReifiedEndpoint ((x :: Symbol) :> endpoint)
instance
Typeable responseType =>
ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
where
toReifiedEndpoint endpoint _ =
toReifiedEndpoint endpoint (Proxy @endpoint)
toReifiedEndpoint endpoint _ =
([], typeRep (Proxy @responseType), endpoint)
instance (Typeable requestType, ToReifiedEndpoint endpoint)
=> ToReifiedEndpoint (Capture name requestType :> endpoint)
instance
(ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint ((x :: Symbol) :> endpoint)
where
toReifiedEndpoint endpoint _ =
toReifiedEndpoint endpoint (Proxy @endpoint)
& \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
toReifiedEndpoint endpoint _ =
toReifiedEndpoint endpoint (Proxy @endpoint)
instance (Typeable requestType, ToReifiedEndpoint endpoint)
=> ToReifiedEndpoint (ReqBody contentTypes requestType :> endpoint)
instance
(Typeable requestType, ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint (Capture name requestType :> endpoint)
where
toReifiedEndpoint endpoint _ =
toReifiedEndpoint endpoint (Proxy @endpoint)
& \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
toReifiedEndpoint endpoint _ =
toReifiedEndpoint endpoint (Proxy @endpoint)
& \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
instance
(Typeable requestType, ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint (ReqBody contentTypes requestType :> endpoint)
where
toReifiedEndpoint endpoint _ =
toReifiedEndpoint endpoint (Proxy @endpoint)
& \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
newtype ApiOffset = ApiOffset Int
deriving (Eq, Show)
@ -205,7 +154,7 @@ data Op (v :: * -> *) = Op ApiOffset [(TypeRep, Var (Opaque (IORef Dynamic)) v)]
deriving instance Show (Op Symbolic)
instance HTraversable Op where
htraverse r op@(Op offset args) = Op offset <$> traverse (\(t, v) -> (t,) <$> htraverse r v) args
htraverse r (Op offset args) = Op offset <$> traverse (\(t, v) -> (t,) <$> htraverse r v) args
callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State
callEndpoint staticRoutes =
@ -231,7 +180,7 @@ callEndpoint staticRoutes =
options :: [(ApiOffset, [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])])]
options =
mapMaybe
( \(offset, argreps, retType, dynCall) -> (offset,) <$> do
( \(offset, argreps, _retType, _dynCall) -> (offset,) <$> do
mapM (\x -> (x,) <$> fillableWith x) argreps
)
staticRoutes
@ -244,8 +193,8 @@ callEndpoint staticRoutes =
execute (Op (ApiOffset offset) args) = do
-- traceM (show (offset, args))
fmap Opaque . liftIO $ do
realArgs <- mapM (\(tr, v) -> readIORef (opaque v)) args
let (_offset, staticArgs, ret, endpoint) = staticRoutes !! offset
realArgs <- mapM (\(_tr, v) -> readIORef (opaque v)) args
let (_offset, _staticArgs, _ret, endpoint) = staticRoutes !! offset
-- now, magic happens: we apply some dynamic arguments to a dynamic
-- function and hopefully somtehing useful pops out the end.
func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just endpoint) realArgs
@ -257,14 +206,11 @@ callEndpoint staticRoutes =
Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
Just f -> liftIO f >>= \case
Left (serverError :: ServerError) -> error (show serverError)
Right (typeRep :: SomeTypeRep, (dyn :: Dynamic)) -> newIORef dyn
Right (_typeRep :: SomeTypeRep, (dyn :: Dynamic)) -> newIORef dyn
in Command
gen
execute
[ Update $ \s@State {..} (Op (ApiOffset offset) args) o' ->
-- let foo :: Var (Opaque Dynamic) v -> Var (Opaque (IORef Dynamic)) v
-- foo = _ . opaque
-- in
[ Update $ \s@State {..} (Op (ApiOffset offset) _args) o' ->
s
{ stateRefs =
let (_, _, tr, _) = staticRoutes !! offset
@ -277,8 +223,8 @@ callEndpoint staticRoutes =
-- , Ensure (no-500 here)
]
prop_sm_sequential :: ReifiedApi -> Property
prop_sm_sequential reifiedApi = do
prop_sequential :: ReifiedApi -> Property
prop_sequential reifiedApi = do
property $ do
let initialState = State mempty
actions <-
@ -289,54 +235,16 @@ prop_sm_sequential reifiedApi = do
[callEndpoint reifiedApi]
executeSequential initialState actions
newtype Foo = Foo Int
deriving (Generic, Eq, Show, Typeable)
deriving newtype (FromHttpApiData, ToHttpApiData)
instance ToJSON Foo
instance FromJSON Foo
type FooApi =
"item" :> Get '[JSON] Foo
:<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo
:<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()
intro = pure (Foo 1)
combine = (\(Foo a) (Foo b) -> pure (Foo (a + b)))
eliminate =
( \(Foo a) ->
if a > 10
then error "eliminate blew up, oh no!"
else pure ()
)
fooServer :: Server FooApi
fooServer =
intro
:<|> combine
:<|> eliminate
bundledFooServer :: Bundled (Endpoints FooApi)
bundledFooServer = flattenServer @FooApi fooServer
runServer :: IO ()
runServer = do
let port = 3000
settings =
setPort port
$ setBeforeMainLoop (putStrLn ("listening on port " ++ show port))
$ defaultSettings
runSettings settings (serve fooApi fooServer)
fooApi :: Proxy FooApi
fooApi = Proxy
introC :<|> combineC :<|> eliminateC = Servant.Client.client fooApi
tests :: IO Bool
tests = do
let reifiedApi = toReifiedApi (flattenServer @FooApi fooServer) (Proxy @(Endpoints FooApi))
checkParallel $ Group "props" [("aprop", prop_sm_sequential reifiedApi)]
prop_concurrent :: ReifiedApi -> Property
prop_concurrent reifiedApi =
let initialState = State mempty
in withTests 1000 . withRetries 10 . property $ do
actions <-
forAll $
Gen.parallel
(Range.linear 1 50)
(Range.linear 1 10)
initialState
[callEndpoint reifiedApi]
test $
executeParallel initialState actions

43
test/Foo.hs Normal file
View File

@ -0,0 +1,43 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Foo where
import Data.Aeson
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Servant
newtype Foo = Foo Int
deriving (Generic, Eq, Show, Typeable)
deriving newtype (FromHttpApiData, ToHttpApiData)
instance ToJSON Foo
instance FromJSON Foo
type FooApi =
"item" :> Get '[JSON] Foo
:<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo
:<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()
intro :: Handler Foo
intro = pure (Foo 1)
combine :: Foo -> Foo -> Handler Foo
combine (Foo a) (Foo b) = pure (Foo (a + b))
eliminate :: Foo -> Handler ()
eliminate (Foo a)
| a > 10 = throwError $ err500 {errBody = "eliminate blew up, oh no!"}
| otherwise = pure ()
fooServer :: Server FooApi
fooServer =
intro
:<|> combine
:<|> eliminate

71
test/Spec.hs
View File

@ -1,52 +1,27 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
import Roboservant
import Servant.API
import Test.Hspec
import qualified Roboservant.StateMachine as SM
import Data.Proxy (Proxy (..))
import qualified Foo
import Hedgehog (Group (..), checkSequential)
import qualified Roboservant as RS
import Servant (Endpoints)
import qualified UnsafeIO
newtype Foo = Foo Int
deriving (Show)
newtype Bar = Bar String
deriving (Show)
type FooApi = "foo" :> "fle" :> "far" :> Get '[JSON] Foo
type BarApi = "bar" :> ReqBody '[JSON] Foo :> Post '[JSON] Bar
type Api =
FooApi :<|> BarApi
type Foo' = ExtractRespType FooApi
test :: ()
test = foo'EqualFoo
where
foo'EqualFoo :: Foo' ~ Foo => ()
foo'EqualFoo = ()
test' :: ()
test' = blah
where
blah :: ExtractRespTypes Api ~ '[Foo, Bar] => ()
blah = ()
storeOfOurApi = storeOfApi @Api
-- | this is pretty bad. hopefully Jacob knows a better way of doing this.
-- https://twitter.com/mwotton/status/1305189249646460933
assert :: String -> Bool -> IO ()
assert _ True = pure ()
assert err False = ioError $ userError err
main :: IO ()
main = SM.tests >>= print
main = do
let reifiedApi = RS.toReifiedApi (RS.flattenServer @Foo.FooApi Foo.fooServer) (Proxy @(Endpoints Foo.FooApi))
assert "should find an error in Foo" . not
=<< checkSequential (Group "Foo" [("Foo", RS.prop_sequential reifiedApi)])
unsafeServer <- UnsafeIO.makeServer
let unsafeApi = RS.toReifiedApi (RS.flattenServer @UnsafeIO.UnsafeApi unsafeServer) (Proxy @(Endpoints UnsafeIO.UnsafeApi))
-- this will not detect the error, as it requires concurrency.
assert "should find nothing" =<< checkSequential (Group "Unsafe" [("Sequential", RS.prop_sequential unsafeApi)])
assert "should find with parallel check" . not
=<< checkSequential (Group "Unsafe" [("Parallel", RS.prop_concurrent unsafeApi)])

41
test/UnsafeIO.hs Normal file
View File

@ -0,0 +1,41 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module UnsafeIO where
import Data.Aeson()
import Servant
import Data.IORef (writeIORef, IORef, readIORef, newIORef)
import Control.Monad.Trans (MonadIO(liftIO))
import qualified Data.ByteString.Lazy.Char8 as BL8
type UnsafeApi =
"add" :> Get '[JSON] ()
:<|> "healthcheck" :> Get '[JSON] ()
healthcheck :: IORef Int -> Handler ()
healthcheck ref = do
t <- liftIO $ readIORef ref
case t of
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
unsafeMunge :: IORef Int -> Handler ()
unsafeMunge ref = liftIO $ do
t <- readIORef ref
writeIORef ref (t+1)
t2 <- readIORef ref
writeIORef ref (t2-1)