From a59a92a04239ba59ff23af47981d1c2b0646b6ea Mon Sep 17 00:00:00 2001 From: Mark Wotton Date: Sat, 15 Aug 2020 13:32:57 -0400 Subject: [PATCH] trying a typerep approach --- package.yaml | 2 + roboservant.cabal | 7 +- src/Roboservant/ContextualGenRequest.hs | 302 +++++++++++++----------- src/Roboservant/Hedgehog.hs | 41 ++++ src/Roboservant/StateMachine.hs | 8 +- 5 files changed, 214 insertions(+), 146 deletions(-) create mode 100644 src/Roboservant/Hedgehog.hs diff --git a/package.yaml b/package.yaml index c2ea5d8..ae8f6f0 100644 --- a/package.yaml +++ b/package.yaml @@ -24,6 +24,8 @@ dependencies: - bytestring +- hedgehog +- containers - http-client - http-media - QuickCheck diff --git a/roboservant.cabal b/roboservant.cabal index 72a3ab1..55264a6 100644 --- a/roboservant.cabal +++ b/roboservant.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: e066fe1fb50c5d775ba730812d8afb9db9b9d14e08b2c25ca2277a1d7205d852 +-- hash: a191221847f306a37d41754b238e8ccc040f3279c30853f21542d4bdf5ab60d3 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 @@ -38,6 +39,8 @@ library QuickCheck , base >=4.7 && <5 , bytestring + , containers + , hedgehog , hspec , http-client , http-media @@ -61,6 +64,8 @@ test-suite roboservant-test QuickCheck , base >=4.7 && <5 , bytestring + , containers + , hedgehog , hspec , http-client , http-media diff --git a/src/Roboservant/ContextualGenRequest.hs b/src/Roboservant/ContextualGenRequest.hs index f0b629b..5d130ea 100644 --- a/src/Roboservant/ContextualGenRequest.hs +++ b/src/Roboservant/ContextualGenRequest.hs @@ -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,189 @@ 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) +import Data.Dynamic (Dynamic) +import Data.Map.Strict (Map) +import Data.Maybe +import Data.Typeable (TypeRep) +import Hedgehog +import qualified Hedgehog.Gen as Gen +import Roboservant.Hedgehog -class HasContextualGenRequest a b where - genContextualRequest :: Proxy a -> (Int, Gen (BaseUrl -> b -> Request)) +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 [] +-- | 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 st - , HasContextualGenRequest b st) - => HasContextualGenRequest (a :<|> b) st where - genContextualRequest _ - = (lf + rf, frequency [l, r]) +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 +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 } - 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 }) + ) +-- , pure ( \burl -> do +-- _ + -- fmap (Just . (1,)) $ return $ \burl st -> 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 st where +-- genContextualRequest _ = (0, error "EmptyAPIs cannot be queried.") -instance HasContextualGenRequest api st => HasContextualGenRequest (Summary d :> api) st where - genContextualRequest _ = genContextualRequest (Proxy :: Proxy api) +-- instance HasContextualGenRequest api st => HasContextualGenRequest (Summary d :> api) st where +-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy api) -instance HasContextualGenRequest api st => HasContextualGenRequest (Description d :> api) st where - genContextualRequest _ = genContextualRequest (Proxy :: Proxy api) +-- instance HasContextualGenRequest api st => HasContextualGenRequest (Description d :> api) st 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 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 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] +-- 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] -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 (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 (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 (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' <- _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, 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 (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 (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 (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 (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 (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 (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 (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) +-- 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) +-- -- TODO: Try logging in +-- instance (HasContextualGenRequest a st) => HasContextualGenRequest (BasicAuth x y :> a) st where +-- genContextualRequest _ = genContextualRequest (Proxy :: Proxy a) diff --git a/src/Roboservant/Hedgehog.hs b/src/Roboservant/Hedgehog.hs new file mode 100644 index 0000000..2f7b4d6 --- /dev/null +++ b/src/Roboservant/Hedgehog.hs @@ -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 diff --git a/src/Roboservant/StateMachine.hs b/src/Roboservant/StateMachine.hs index 315d52a..76ad02a 100644 --- a/src/Roboservant/StateMachine.hs +++ b/src/Roboservant/StateMachine.hs @@ -2,15 +2,15 @@ {-# LANGUAGE RankNTypes #-} module Roboservant.StateMachine where -import Servant.Server (Server) -import Test.QuickCheck (Property) +import Roboservant.ContextualGenRequest +import Servant.Server (Server) +import Test.QuickCheck (Property) import Test.StateMachine -import Roboservant.ContextualGenRequest -- | 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 :: HasContextualGenRequest a => Server a -> StateMachine model command IO response genStateMachine = undefined