mirror of
https://github.com/ilyakooo0/roboservant.git
synced 2024-09-11 08:05:47 +03:00
commit
3bd7a4939c
2
Makefile
2
Makefile
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
41
src/Roboservant/Hedgehog.hs
Normal 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
|
@ -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)]
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user