mirror of
https://github.com/ilyakooo0/roboservant.git
synced 2024-09-11 08:05:47 +03:00
add some examples, remove old code
This commit is contained in:
parent
3bd7a4939c
commit
0724d7aa74
34
package.yaml
34
package.yaml
@ -1,48 +1,42 @@
|
|||||||
name: roboservant
|
name: roboservant
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
github: "githubuser/roboservant"
|
github: "mwotton/roboservant"
|
||||||
license: BSD3
|
license: BSD3
|
||||||
author: "Author name here"
|
author: "Mark Wotton, Samuel Schlesinger"
|
||||||
maintainer: "example@example.com"
|
maintainer: "mwotton@gmail.com"
|
||||||
copyright: "2020 Author name here"
|
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:
|
extra-source-files:
|
||||||
- README.md
|
- README.md
|
||||||
- ChangeLog.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:
|
dependencies:
|
||||||
- base >= 4.7 && < 5
|
- base >= 4.7 && < 5
|
||||||
|
|
||||||
|
- QuickCheck
|
||||||
- bytestring
|
- bytestring
|
||||||
- hedgehog
|
|
||||||
- constrained-dynamic
|
|
||||||
- containers
|
- containers
|
||||||
|
- hedgehog
|
||||||
- http-client
|
- http-client
|
||||||
- http-media
|
- http-media
|
||||||
- QuickCheck
|
|
||||||
- quickcheck-state-machine >= 0.7
|
|
||||||
- mtl
|
- mtl
|
||||||
|
- quickcheck-state-machine >= 0.7
|
||||||
- servant >= 0.17
|
- servant >= 0.17
|
||||||
- servant-client >= 0.17
|
- servant-client >= 0.17
|
||||||
- servant-flatten
|
- servant-flatten
|
||||||
- servant-server >= 0.17
|
- servant-server >= 0.17
|
||||||
- string-conversions
|
- string-conversions
|
||||||
|
|
||||||
# test deps
|
# test deps
|
||||||
- hspec
|
- hspec
|
||||||
- QuickCheck
|
- QuickCheck
|
||||||
- warp
|
|
||||||
- aeson
|
- aeson
|
||||||
- wai
|
|
||||||
|
ghc-options: -Wall
|
||||||
|
|
||||||
library:
|
library:
|
||||||
source-dirs: src
|
source-dirs: src
|
||||||
|
|
||||||
|
@ -1,19 +1,21 @@
|
|||||||
cabal-version: 1.12
|
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
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: 9d15f4554f9f8ea8913a6766643b63ee6633016374fc98164e81058799204a87
|
-- hash: 51154f1c866aea92673a52985de6810cebda3b2662fddd7b7f88a56725e30041
|
||||||
|
|
||||||
name: roboservant
|
name: roboservant
|
||||||
version: 0.1.0.0
|
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>
|
description: Please see the README on GitHub at <https://github.com/githubuser/roboservant#readme>
|
||||||
homepage: https://github.com/githubuser/roboservant#readme
|
category: Web
|
||||||
bug-reports: https://github.com/githubuser/roboservant/issues
|
homepage: https://github.com/mwotton/roboservant#readme
|
||||||
author: Author name here
|
bug-reports: https://github.com/mwotton/roboservant/issues
|
||||||
maintainer: example@example.com
|
author: Mark Wotton, Samuel Schlesinger
|
||||||
copyright: 2020 Author name here
|
maintainer: mwotton@gmail.com
|
||||||
|
copyright: 2020 Mark Wotton, Samuel Schlesinger
|
||||||
license: BSD3
|
license: BSD3
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
build-type: Simple
|
build-type: Simple
|
||||||
@ -23,24 +25,22 @@ extra-source-files:
|
|||||||
|
|
||||||
source-repository head
|
source-repository head
|
||||||
type: git
|
type: git
|
||||||
location: https://github.com/githubuser/roboservant
|
location: https://github.com/mwotton/roboservant
|
||||||
|
|
||||||
library
|
library
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Roboservant
|
Roboservant
|
||||||
Roboservant.ContextualGenRequest
|
|
||||||
Roboservant.Hedgehog
|
|
||||||
Roboservant.StateMachine
|
Roboservant.StateMachine
|
||||||
other-modules:
|
other-modules:
|
||||||
Paths_roboservant
|
Paths_roboservant
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
src
|
src
|
||||||
|
ghc-options: -Wall
|
||||||
build-depends:
|
build-depends:
|
||||||
QuickCheck
|
QuickCheck
|
||||||
, aeson
|
, aeson
|
||||||
, base >=4.7 && <5
|
, base >=4.7 && <5
|
||||||
, bytestring
|
, bytestring
|
||||||
, constrained-dynamic
|
|
||||||
, containers
|
, containers
|
||||||
, hedgehog
|
, hedgehog
|
||||||
, hspec
|
, hspec
|
||||||
@ -53,24 +53,23 @@ library
|
|||||||
, servant-flatten
|
, servant-flatten
|
||||||
, servant-server >=0.17
|
, servant-server >=0.17
|
||||||
, string-conversions
|
, string-conversions
|
||||||
, wai
|
|
||||||
, warp
|
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
test-suite roboservant-test
|
test-suite roboservant-test
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
main-is: Spec.hs
|
main-is: Spec.hs
|
||||||
other-modules:
|
other-modules:
|
||||||
|
Foo
|
||||||
|
UnsafeIO
|
||||||
Paths_roboservant
|
Paths_roboservant
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
test
|
test
|
||||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
|
||||||
build-depends:
|
build-depends:
|
||||||
QuickCheck
|
QuickCheck
|
||||||
, aeson
|
, aeson
|
||||||
, base >=4.7 && <5
|
, base >=4.7 && <5
|
||||||
, bytestring
|
, bytestring
|
||||||
, constrained-dynamic
|
|
||||||
, containers
|
, containers
|
||||||
, hedgehog
|
, hedgehog
|
||||||
, hspec
|
, hspec
|
||||||
@ -84,6 +83,4 @@ test-suite roboservant-test
|
|||||||
, servant-flatten
|
, servant-flatten
|
||||||
, servant-server >=0.17
|
, servant-server >=0.17
|
||||||
, string-conversions
|
, string-conversions
|
||||||
, wai
|
|
||||||
, warp
|
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
@ -1,110 +1,3 @@
|
|||||||
{-# LANGUAGE LambdaCase #-}
|
module Roboservant (module Roboservant.StateMachine) where
|
||||||
{-# 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
|
|
||||||
|
|
||||||
import Prelude hiding (lookup)
|
|
||||||
import GHC.TypeLits
|
|
||||||
import Servant.API
|
|
||||||
|
|
||||||
import Roboservant.ContextualGenRequest
|
|
||||||
import Roboservant.StateMachine
|
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
|
|
||||||
--
|
|
||||||
|
@ -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)
|
|
@ -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
|
|
@ -1,104 +1,41 @@
|
|||||||
{-# LANGUAGE UndecidableInstances #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE GADTs #-}
|
|
||||||
{-# LANGUAGE PolyKinds #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE DeriveAnyClass #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE DerivingStrategies #-}
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
{-# LANGUAGE ExistentialQuantification #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE GADTs #-}
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE KindSignatures #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE PolyKinds #-}
|
||||||
{-# LANGUAGE PartialTypeSignatures #-}
|
|
||||||
{-# LANGUAGE RankNTypes #-}
|
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE StandaloneDeriving #-}
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
-- for servant
|
|
||||||
|
|
||||||
module Roboservant.StateMachine where
|
module Roboservant.StateMachine where
|
||||||
|
|
||||||
import Control.Arrow (second)
|
import Control.Monad.Except (runExceptT)
|
||||||
-- import Data.Dynamic (Dynamic, fromDynamic)
|
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||||
|
import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic, toDyn)
|
||||||
--import Test.QuickCheck (Property)
|
|
||||||
-- import Test.StateMachine
|
|
||||||
|
|
||||||
import Type.Reflection (SomeTypeRep)
|
|
||||||
import Servant.API.Flatten (Flat)
|
|
||||||
import GHC.TypeLits (Nat, Symbol)
|
|
||||||
import Data.Function ((&))
|
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 Data.IORef (IORef, newIORef)
|
||||||
import qualified Data.List.NonEmpty as NEL
|
import qualified Data.List.NonEmpty as NEL
|
||||||
import Data.List.NonEmpty (NonEmpty)
|
import Data.List.NonEmpty (NonEmpty)
|
||||||
import Data.Map.Strict (Map)
|
import Data.Map.Strict (Map)
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
import Data.Maybe
|
import Data.Maybe (mapMaybe)
|
||||||
import Data.Type.HasClass
|
import Data.Typeable (TypeRep, Typeable, typeRep)
|
||||||
import Data.Type.HasClassPreludeInstances
|
|
||||||
import Data.Typeable (TypeRep, Typeable, typeOf, typeRep)
|
|
||||||
import Debug.Trace (traceM, traceShowM)
|
|
||||||
import GHC.Generics (Generic)
|
|
||||||
import GHC.Generics
|
|
||||||
import GHC.IORef (readIORef)
|
import GHC.IORef (readIORef)
|
||||||
import Control.Monad.Except (runExceptT)
|
import GHC.TypeLits (Symbol)
|
||||||
import Hedgehog
|
|
||||||
import Hedgehog
|
import Hedgehog
|
||||||
import qualified Hedgehog.Gen as Gen
|
import qualified Hedgehog.Gen as Gen
|
||||||
import qualified Hedgehog.Range as Range
|
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
|
||||||
import Servant.Client
|
import Type.Reflection (SomeTypeRep)
|
||||||
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
|
|
||||||
|
|
||||||
data State v
|
data State v
|
||||||
= State
|
= State
|
||||||
@ -109,24 +46,30 @@ class FlattenServer api where
|
|||||||
flattenServer :: Server api -> Bundled (Endpoints api)
|
flattenServer :: Server api -> Bundled (Endpoints api)
|
||||||
|
|
||||||
instance
|
instance
|
||||||
( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api)
|
( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api),
|
||||||
, Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api)
|
Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api),
|
||||||
, FlattenServer api
|
FlattenServer api
|
||||||
) => FlattenServer (endpoint :<|> api) where
|
) =>
|
||||||
|
FlattenServer (endpoint :<|> api)
|
||||||
|
where
|
||||||
flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
|
flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
|
||||||
|
|
||||||
instance
|
instance
|
||||||
( HasServer (x :> api) '[]
|
( HasServer (x :> api) '[],
|
||||||
, Endpoints (x :> api) ~ '[x :> api]
|
Endpoints (x :> api) ~ '[x :> api]
|
||||||
) => FlattenServer (x :> api) where
|
) =>
|
||||||
|
FlattenServer (x :> api)
|
||||||
|
where
|
||||||
flattenServer server = server `AnEndpoint` NoEndpoints
|
flattenServer server = server `AnEndpoint` NoEndpoints
|
||||||
|
|
||||||
instance
|
instance
|
||||||
( HasServer (Verb method statusCode contentTypes responseType) '[],
|
( HasServer (Verb method statusCode contentTypes responseType) '[],
|
||||||
Endpoints (Verb method statusCode contentTypes responseType) ~ '[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
|
flattenServer server = server `AnEndpoint` NoEndpoints
|
||||||
|
|
||||||
type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)
|
type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)
|
||||||
|
|
||||||
type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]
|
type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]
|
||||||
@ -144,18 +87,20 @@ class ToReifiedEndpoint (endpoint :: *) where
|
|||||||
instance ToReifiedApi '[] where
|
instance ToReifiedApi '[] where
|
||||||
toReifiedApi NoEndpoints _ = []
|
toReifiedApi NoEndpoints _ = []
|
||||||
|
|
||||||
instance (Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler))
|
instance
|
||||||
=> ToReifiedApi (endpoint : endpoints)
|
(Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)) =>
|
||||||
|
ToReifiedApi (endpoint : endpoints)
|
||||||
where
|
where
|
||||||
toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
|
toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
|
||||||
withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))
|
withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))
|
||||||
: map (\(n, x, y, z) -> (n + 1, x, y, z))
|
: map
|
||||||
(toReifiedApi endpoints (Proxy @endpoints))
|
(\(n, x, y, z) -> (n + 1, x, y, z))
|
||||||
where
|
(toReifiedApi endpoints (Proxy @endpoints))
|
||||||
withOffset (x, y, z) = (0, x, y, z)
|
where
|
||||||
|
withOffset (x, y, z) = (0, x, y, z)
|
||||||
|
|
||||||
class NormalizeFunction m where
|
class NormalizeFunction m where
|
||||||
type Normal m
|
type Normal m
|
||||||
normalize :: m -> Normal m
|
normalize :: m -> Normal m
|
||||||
|
|
||||||
instance NormalizeFunction x => NormalizeFunction (r -> x) where
|
instance NormalizeFunction x => NormalizeFunction (r -> x) where
|
||||||
@ -167,32 +112,36 @@ instance Typeable x => NormalizeFunction (Handler x) where
|
|||||||
normalize handler = (runExceptT . runHandler') handler >>= \case
|
normalize handler = (runExceptT . runHandler') handler >>= \case
|
||||||
Left serverError -> pure (Left serverError)
|
Left serverError -> pure (Left serverError)
|
||||||
Right x -> pure (Right (typeRep (Proxy @x), toDyn x))
|
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)
|
instance
|
||||||
=> ToReifiedEndpoint ((x :: Symbol) :> endpoint)
|
Typeable responseType =>
|
||||||
|
ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
|
||||||
where
|
where
|
||||||
toReifiedEndpoint endpoint _ =
|
toReifiedEndpoint endpoint _ =
|
||||||
toReifiedEndpoint endpoint (Proxy @endpoint)
|
([], typeRep (Proxy @responseType), endpoint)
|
||||||
|
|
||||||
instance (Typeable requestType, ToReifiedEndpoint endpoint)
|
instance
|
||||||
=> ToReifiedEndpoint (Capture name requestType :> endpoint)
|
(ToReifiedEndpoint endpoint) =>
|
||||||
|
ToReifiedEndpoint ((x :: Symbol) :> endpoint)
|
||||||
where
|
where
|
||||||
toReifiedEndpoint endpoint _ =
|
toReifiedEndpoint endpoint _ =
|
||||||
toReifiedEndpoint endpoint (Proxy @endpoint)
|
toReifiedEndpoint endpoint (Proxy @endpoint)
|
||||||
& \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
|
|
||||||
|
|
||||||
instance (Typeable requestType, ToReifiedEndpoint endpoint)
|
instance
|
||||||
=> ToReifiedEndpoint (ReqBody contentTypes requestType :> endpoint)
|
(Typeable requestType, ToReifiedEndpoint endpoint) =>
|
||||||
|
ToReifiedEndpoint (Capture name requestType :> endpoint)
|
||||||
where
|
where
|
||||||
toReifiedEndpoint endpoint _ =
|
toReifiedEndpoint endpoint _ =
|
||||||
toReifiedEndpoint endpoint (Proxy @endpoint)
|
toReifiedEndpoint endpoint (Proxy @endpoint)
|
||||||
& \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
|
& \(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
|
newtype ApiOffset = ApiOffset Int
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
@ -205,7 +154,7 @@ data Op (v :: * -> *) = Op ApiOffset [(TypeRep, Var (Opaque (IORef Dynamic)) v)]
|
|||||||
deriving instance Show (Op Symbolic)
|
deriving instance Show (Op Symbolic)
|
||||||
|
|
||||||
instance HTraversable Op where
|
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 :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State
|
||||||
callEndpoint staticRoutes =
|
callEndpoint staticRoutes =
|
||||||
@ -231,7 +180,7 @@ callEndpoint staticRoutes =
|
|||||||
options :: [(ApiOffset, [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])])]
|
options :: [(ApiOffset, [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])])]
|
||||||
options =
|
options =
|
||||||
mapMaybe
|
mapMaybe
|
||||||
( \(offset, argreps, retType, dynCall) -> (offset,) <$> do
|
( \(offset, argreps, _retType, _dynCall) -> (offset,) <$> do
|
||||||
mapM (\x -> (x,) <$> fillableWith x) argreps
|
mapM (\x -> (x,) <$> fillableWith x) argreps
|
||||||
)
|
)
|
||||||
staticRoutes
|
staticRoutes
|
||||||
@ -244,8 +193,8 @@ callEndpoint staticRoutes =
|
|||||||
execute (Op (ApiOffset offset) args) = do
|
execute (Op (ApiOffset offset) args) = do
|
||||||
-- traceM (show (offset, args))
|
-- traceM (show (offset, args))
|
||||||
fmap Opaque . liftIO $ do
|
fmap Opaque . liftIO $ do
|
||||||
realArgs <- mapM (\(tr, v) -> readIORef (opaque v)) args
|
realArgs <- mapM (\(_tr, v) -> readIORef (opaque v)) args
|
||||||
let (_offset, staticArgs, ret, endpoint) = staticRoutes !! offset
|
let (_offset, _staticArgs, _ret, endpoint) = staticRoutes !! offset
|
||||||
-- now, magic happens: we apply some dynamic arguments to a dynamic
|
-- now, magic happens: we apply some dynamic arguments to a dynamic
|
||||||
-- function and hopefully somtehing useful pops out the end.
|
-- function and hopefully somtehing useful pops out the end.
|
||||||
func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just endpoint) realArgs
|
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)
|
Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
|
||||||
Just f -> liftIO f >>= \case
|
Just f -> liftIO f >>= \case
|
||||||
Left (serverError :: ServerError) -> error (show serverError)
|
Left (serverError :: ServerError) -> error (show serverError)
|
||||||
Right (typeRep :: SomeTypeRep, (dyn :: Dynamic)) -> newIORef dyn
|
Right (_typeRep :: SomeTypeRep, (dyn :: Dynamic)) -> newIORef dyn
|
||||||
in Command
|
in Command
|
||||||
gen
|
gen
|
||||||
execute
|
execute
|
||||||
[ Update $ \s@State {..} (Op (ApiOffset offset) args) o' ->
|
[ Update $ \s@State {..} (Op (ApiOffset offset) _args) o' ->
|
||||||
-- let foo :: Var (Opaque Dynamic) v -> Var (Opaque (IORef Dynamic)) v
|
|
||||||
-- foo = _ . opaque
|
|
||||||
-- in
|
|
||||||
s
|
s
|
||||||
{ stateRefs =
|
{ stateRefs =
|
||||||
let (_, _, tr, _) = staticRoutes !! offset
|
let (_, _, tr, _) = staticRoutes !! offset
|
||||||
@ -277,8 +223,8 @@ callEndpoint staticRoutes =
|
|||||||
-- , Ensure (no-500 here)
|
-- , Ensure (no-500 here)
|
||||||
]
|
]
|
||||||
|
|
||||||
prop_sm_sequential :: ReifiedApi -> Property
|
prop_sequential :: ReifiedApi -> Property
|
||||||
prop_sm_sequential reifiedApi = do
|
prop_sequential reifiedApi = do
|
||||||
property $ do
|
property $ do
|
||||||
let initialState = State mempty
|
let initialState = State mempty
|
||||||
actions <-
|
actions <-
|
||||||
@ -289,54 +235,16 @@ prop_sm_sequential reifiedApi = do
|
|||||||
[callEndpoint reifiedApi]
|
[callEndpoint reifiedApi]
|
||||||
executeSequential initialState actions
|
executeSequential initialState actions
|
||||||
|
|
||||||
newtype Foo = Foo Int
|
prop_concurrent :: ReifiedApi -> Property
|
||||||
deriving (Generic, Eq, Show, Typeable)
|
prop_concurrent reifiedApi =
|
||||||
deriving newtype (FromHttpApiData, ToHttpApiData)
|
let initialState = State mempty
|
||||||
|
in withTests 1000 . withRetries 10 . property $ do
|
||||||
instance ToJSON Foo
|
actions <-
|
||||||
|
forAll $
|
||||||
instance FromJSON Foo
|
Gen.parallel
|
||||||
|
(Range.linear 1 50)
|
||||||
type FooApi =
|
(Range.linear 1 10)
|
||||||
"item" :> Get '[JSON] Foo
|
initialState
|
||||||
:<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo
|
[callEndpoint reifiedApi]
|
||||||
:<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()
|
test $
|
||||||
|
executeParallel initialState actions
|
||||||
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)]
|
|
||||||
|
43
test/Foo.hs
Normal file
43
test/Foo.hs
Normal 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
71
test/Spec.hs
@ -1,52 +1,27 @@
|
|||||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# 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 #-}
|
|
||||||
|
|
||||||
import Roboservant
|
import Data.Proxy (Proxy (..))
|
||||||
import Servant.API
|
import qualified Foo
|
||||||
import Test.Hspec
|
import Hedgehog (Group (..), checkSequential)
|
||||||
import qualified Roboservant.StateMachine as SM
|
import qualified Roboservant as RS
|
||||||
|
import Servant (Endpoints)
|
||||||
|
import qualified UnsafeIO
|
||||||
|
|
||||||
newtype Foo = Foo Int
|
-- | this is pretty bad. hopefully Jacob knows a better way of doing this.
|
||||||
deriving (Show)
|
-- https://twitter.com/mwotton/status/1305189249646460933
|
||||||
|
assert :: String -> Bool -> IO ()
|
||||||
newtype Bar = Bar String
|
assert _ True = pure ()
|
||||||
deriving (Show)
|
assert err False = ioError $ userError err
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
main :: IO ()
|
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
41
test/UnsafeIO.hs
Normal 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)
|
Loading…
Reference in New Issue
Block a user