ilyakooo0/roboservant
1
0
Fork 0
mirror of https://github.com/ilyakooo0/roboservant.git synced 2024-09-11 08:05:47 +03:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #1 from mwotton/sam/typerepmap

Browse Source 
Sam/typerepmap
This commit is contained in:
Mark Wotton 2020-09-13 11:41:04 -04:00 committed by GitHub
commit 3bd7a4939c
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
8 changed files with 580 additions and 154 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -1,2 +1,2 @@
testwatch:
ghcid -c 'stack repl --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml"
ghcid -c 'stack repl --test --ghc-options=-fobject-code roboservant' --allow-eval --restart="stack.yaml" --restart="package.yaml" -W

9
package.yaml
View File

@ -24,10 +24,14 @@ dependencies:
- bytestring
- hedgehog
- constrained-dynamic
- containers
- http-client
- http-media
- QuickCheck
- quickcheck-state-machine
- quickcheck-state-machine >= 0.7
- mtl
- servant >= 0.17
- servant-client >= 0.17
- servant-flatten
@ -36,6 +40,9 @@ dependencies:
# test deps
- hspec
- QuickCheck
- warp
- aeson
- wai
library:
source-dirs: src

23
roboservant.cabal
View File

@ -1,10 +1,10 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.33.0.
-- This file has been generated from package.yaml by hpack version 0.31.2.
--
-- see: https://github.com/sol/hpack
--
-- hash: e066fe1fb50c5d775ba730812d8afb9db9b9d14e08b2c25ca2277a1d7205d852
-- hash: 9d15f4554f9f8ea8913a6766643b63ee6633016374fc98164e81058799204a87
name: roboservant
version: 0.1.0.0
@ -29,6 +29,7 @@ library
exposed-modules:
Roboservant
Roboservant.ContextualGenRequest
Roboservant.Hedgehog
Roboservant.StateMachine
other-modules:
Paths_roboservant
@ -36,17 +37,24 @@ library
src
build-depends:
QuickCheck
, aeson
, base >=4.7 && <5
, bytestring
, constrained-dynamic
, containers
, hedgehog
, hspec
, http-client
, http-media
, quickcheck-state-machine
, mtl
, quickcheck-state-machine >=0.7
, servant >=0.17
, servant-client >=0.17
, servant-flatten
, servant-server >=0.17
, string-conversions
, wai
, warp
default-language: Haskell2010
test-suite roboservant-test
@ -59,16 +67,23 @@ test-suite roboservant-test
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends:
QuickCheck
, aeson
, base >=4.7 && <5
, bytestring
, constrained-dynamic
, containers
, hedgehog
, hspec
, http-client
, http-media
, quickcheck-state-machine
, mtl
, quickcheck-state-machine >=0.7
, roboservant
, servant >=0.17
, servant-client >=0.17
, servant-flatten
, servant-server >=0.17
, string-conversions
, wai
, warp
default-language: Haskell2010

314
src/Roboservant/ContextualGenRequest.hs
View File

@ -4,12 +4,14 @@
{-# 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 #-}
@ -32,171 +34,205 @@ import Servant
import Servant.API
import Servant.API.ContentTypes (AllMimeRender, allMimeRender)
import Servant.Client
import Test.QuickCheck (Arbitrary, Gen, elements, frequency)
-- import Test.QuickCheck (Arbitrary, Gen, elements, frequency)
class HasContextualGenRequest a b where
genContextualRequest :: Proxy a -> (Int, Gen (BaseUrl -> b -> Request))
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
-- -- | 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 []
class HasContextualGenRequest a where
genContextualRequest :: Proxy a -> Map TypeRep Dynamic -> Maybe (Int, Gen ( BaseUrl -> Request))
instance ( HasContextualGenRequest a st
, HasContextualGenRequest b st)
=> HasContextualGenRequest (a :<|> b) st where
genContextualRequest _
= (lf + rf, frequency [l, r])
-- | 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
l@(lf, _) = genContextualRequest (Proxy :: Proxy a)
r@(rf, _) = genContextualRequest (Proxy :: Proxy b)
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
instance (KnownSymbol path, HasContextualGenRequest b st)
=> HasContextualGenRequest (path :> b) st where
genContextualRequest _ = (1, do
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
old' <- (_old :: _)
return $ \burl st ->
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 })
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)
-- (oldf, old) = genContextualRequest (Proxy :: Proxy b) store
new = cs $ symbolVal (Proxy :: Proxy path)
instance HasContextualGenRequest EmptyAPI st where
genContextualRequest _ = (0, error "EmptyAPIs cannot be queried.")
instance HasContextualGenRequest EmptyAPI where
genContextualRequest _ _ = Nothing
instance HasContextualGenRequest api st => HasContextualGenRequest (Summary d :> api) st where
instance HasContextualGenRequest api => HasContextualGenRequest (Summary d :> api) where
genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
instance HasContextualGenRequest api st => HasContextualGenRequest (Description d :> api) st where
instance HasContextualGenRequest api => HasContextualGenRequest (Description d :> api) where
genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
instance (HasContextualGenRequest b st, ToHttpApiData c )
=> HasContextualGenRequest (Capture' mods x c :> b) st where
genContextualRequest _ = (oldf, do
old' <- old
new' <- toUrlPiece <$> _generator
return $ \burl st -> let r = old' burl st in r { path = cs new' <> path r })
where
(oldf, old) = genContextualRequest (Proxy :: Proxy b)
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 })
instance (HasContextualGenRequest b st, ToHttpApiData c )
=> HasContextualGenRequest (CaptureAll x c :> b) st where
genContextualRequest _ = (oldf, do
old' <- old
new' <- fmap (cs . toUrlPiece) <$> new
let new'' = BS.intercalate "/" new'
return $ \burl st -> let r = old' burl st
in r { path = new'' <> path r })
where
(oldf, old) = genContextualRequest (Proxy :: Proxy b)
new = _arbitrary :: Gen [c]
-- 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
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
-- return $ \burl -> let r = old' burl
-- in r { path = new'' <> path r })
instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
=> HasContextualGenRequest (QueryParams x c :> b) st where
genContextualRequest _ = (oldf, do
new' <- _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)
-- -- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
-- -- new = _arbitrary :: Gen [c]
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 (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 (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 (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 (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 (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 (HasContextualGenRequest a st) => HasContextualGenRequest (RemoteHost :> a) st where
genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
-- 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 (HasContextualGenRequest a st) => HasContextualGenRequest (IsSecure :> a) st where
genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
-- 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 (HasContextualGenRequest a st) => HasContextualGenRequest (HttpVersion :> a) st where
genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
-- 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 (HasContextualGenRequest a st) => HasContextualGenRequest (Vault :> a) st where
genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
-- 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 (WithNamedContext x y a) st where
genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (RemoteHost :> 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)
-- 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 Normal file
View File

@ -0,0 +1,41 @@
{-# 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

340
src/Roboservant/StateMachine.hs
View File

@ -1,16 +1,342 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
-- for servant
module Roboservant.StateMachine where
import Servant.Server (Server)
import Test.QuickCheck (Property)
import Test.StateMachine
import Roboservant.ContextualGenRequest
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 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 GHC.IORef (readIORef)
import Control.Monad.Except (runExceptT)
import Hedgehog
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 b => Server a -> StateMachine model command IO response
genStateMachine = undefined
-- 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
= State
{ stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v))
}
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
flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
instance
( 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 server = server `AnEndpoint` NoEndpoints
type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)
type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]
data Bundled endpoints where
AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
NoEndpoints :: Bundled '[]
class ToReifiedApi (endpoints :: [*]) where
toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
class ToReifiedEndpoint (endpoint :: *) where
toReifiedEndpoint :: Dynamic -> Proxy endpoint -> ReifiedEndpoint
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)
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)
class NormalizeFunction m where
type Normal m
normalize :: m -> Normal m
instance NormalizeFunction x => NormalizeFunction (r -> x) where
type Normal (r -> x) = r -> Normal x
normalize = fmap normalize
instance Typeable x => NormalizeFunction (Handler x) where
type Normal (Handler x) = IO (Either ServerError (TypeRep, Dynamic))
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)
where
toReifiedEndpoint endpoint _ =
toReifiedEndpoint endpoint (Proxy @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)
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)
deriving newtype (Enum, Num)
-- | we need to specify an offset because it's entirely possible to have two
-- functions with the same arguments that do different things.
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
callEndpoint :: (MonadGen n, MonadIO m) => ReifiedApi -> Command n m State
callEndpoint staticRoutes =
let gen :: MonadGen n => State Symbolic -> Maybe (n (Op Symbolic))
gen State {..}
| any null options = Nothing
| otherwise = Just $ do
uncurry Op <$> chooseOne options
where
chooseOne ::
MonadGen n =>
[ ( ApiOffset,
[(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])]
)
] ->
n
( ApiOffset,
[(TypeRep, Var (Opaque (IORef Dynamic)) Symbolic)]
)
chooseOne opts = do
(offset, args) <- Gen.element opts
(offset,) <$> mapM (\(tr, argOpts) -> (tr,) <$> Gen.element argOpts) args
options :: [(ApiOffset, [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])])]
options =
mapMaybe
( \(offset, argreps, retType, dynCall) -> (offset,) <$> do
mapM (\x -> (x,) <$> fillableWith x) argreps
)
staticRoutes
fillableWith :: TypeRep -> Maybe [Var (Opaque (IORef Dynamic)) Symbolic]
fillableWith tr = NEL.toList <$> Map.lookup tr stateRefs
execute ::
(MonadIO m) =>
Op Concrete ->
m (Opaque (IORef Dynamic))
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
-- 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
let showable = map dynTypeRep (endpoint : realArgs)
case func of
Nothing -> error ("all screwed up: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
Just (f') -> do
case fromDynamic f' of
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
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
s
{ stateRefs =
let (_, _, tr, _) = staticRoutes !! offset
in Map.insertWith
(<>)
tr
(pure o')
stateRefs
}
-- , Ensure (no-500 here)
]
prop_sm_sequential :: ReifiedApi -> Property
prop_sm_sequential reifiedApi = do
property $ do
let initialState = State mempty
actions <-
forAll $
Gen.sequential
(Range.linear 1 100)
initialState
[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)]

2
stack.yaml
View File

@ -10,4 +10,4 @@ extra-deps:
- servant-client-0.17
- servant-client-core-0.17
- servant-server-0.17
- constrained-dynamic-0.1.0.0@sha256:3516d3b95c8180f8904671aa982af2fae55a185b18642192f5c8f50657108e82,1207

3
test/Spec.hs
View File

@ -17,6 +17,7 @@
import Roboservant
import Servant.API
import Test.Hspec
import qualified Roboservant.StateMachine as SM
newtype Foo = Foo Int
deriving (Show)
@ -48,4 +49,4 @@ test' = blah
storeOfOurApi = storeOfApi @Api
main :: IO ()
main = putStrLn "Test suite not yet implemented"
main = SM.tests >>= print