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

type-safe servant interface

Browse Source
This commit is contained in:
Justin Le 2020-11-17 14:14:09 -08:00
parent c9076d7cf5
commit d54960dcec
No known key found for this signature in database
GPG Key ID: 7250924767D57F1C
7 changed files with 268 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
package.yaml
View File

@ -27,6 +27,10 @@ dependencies:
- servant-flatten
- servant-server # >= 0.17
- string-conversions
- vinyl
- dependent-sum
- dependent-map
- text
ghc-options:
- -Wall

10
roboservant.cabal
View File

@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: 8359b70b81d2fdfc7001a1f607745da953f6e8f7b8188a54857d658406c238a2
-- hash: d9b75d0543bde313d954ce10fe6c45bbb21467e7c2d65320dc3a85e15a6ec345
name: roboservant
version: 0.1.0.2
@ -44,6 +44,8 @@ library
base >=4.7 && <5
, bytestring
, containers
, dependent-map
, dependent-sum
, lifted-base
, monad-control
, mtl
@ -53,6 +55,8 @@ library
, servant-flatten
, servant-server
, string-conversions
, text
, vinyl
default-language: Haskell2010
test-suite roboservant-test
@ -73,6 +77,8 @@ test-suite roboservant-test
, base >=4.7 && <5
, bytestring
, containers
, dependent-map
, dependent-sum
, hspec
, hspec-core
, lifted-base
@ -85,4 +91,6 @@ test-suite roboservant-test
, servant-flatten
, servant-server
, string-conversions
, text
, vinyl
default-language: Haskell2010

156
src/Roboservant/Direct.hs
View File

@ -7,6 +7,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
@ -22,18 +23,26 @@ module Roboservant.Direct
where
import Control.Exception.Lifted(throw,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
import Control.Monad(void,replicateM)
import Control.Monad(void,replicateM,forM_)
import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,execStateT)
import Control.Monad.Trans.Control(MonadBaseControl)
import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic)
import Data.Dependent.Map (DMap)
import Data.Dynamic (Dynamic(..), dynApply, dynTypeRep, fromDynamic)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Map.Strict(Map)
import Data.Maybe (mapMaybe)
import Data.Typeable (TypeRep)
import Servant (Endpoints, Proxy (Proxy), Server, ServerError(..))
import System.Random(StdGen,randomR,mkStdGen)
import System.Timeout.Lifted(timeout)
import GHC.Generics ((:*:)(..))
import qualified Data.Vinyl.Functor as V
import qualified Data.Vinyl.Curry as V
import qualified Data.Dependent.Map as DM
import qualified Data.Vinyl as V
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map.Strict as Map
import qualified Type.Reflection as R
import Roboservant.Types.Breakdown
import Roboservant.Types
@ -41,6 +50,10 @@ import Roboservant.Types
FlattenServer (..),
-- ReifiedApi,
ToReifiedApi (..),
ReifiedEndpoint(..),
Argument(..),
TypedF
)
data RoboservantException
@ -72,7 +85,12 @@ data FuzzState = FuzzState
, stash :: Stash
, currentRng :: StdGen
}
deriving (Show)
deriving Show
data EndpointOption = forall as. (V.RecordToList as, V.RMap as) => EndpointOption
{ eoCall :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
, eoArgs :: V.Rec (TypedF StashValue) as
}
fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))
=> Server api
@ -87,8 +105,11 @@ fuzz server Config{..} checker = do
-- and throw an exception that propagates through this.
void $ timeout (maxRuntime * 1000000) ( execStateT (replicateM maxReps go) FuzzState{..})
mapM_ (print . (\(offset, (args, dyn) ) -> (offset, map fst args, dyn))) reifiedApi
forM_ reifiedApi $ \(offset, ReifiedEndpoint{..}) ->
print (
offset
, recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) reArguments
)
where
reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
@ -102,67 +123,77 @@ fuzz server Config{..} checker = do
modify' $ \st' -> st' { currentRng = newGen }
pure (l !! index)
genOp :: (MonadState FuzzState m, MonadIO m)
=> m (FuzzOp, Dynamic, [Dynamic])
genOp = do -- fs@FuzzState{..} = do
withOp :: (MonadState FuzzState m, MonadIO m)
=> (forall as. (V.RecordToList as, V.RMap as)
=> FuzzOp
-> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
-> V.Rec (TypedF V.Identity) as -> m r
)
-> m r
withOp callback = do
-- choose a call to make, from the endpoints with fillable arguments.
(offset, dynCall, args) <- elementOrFail . options =<< get
r <- mapM (elementOrFail . zip [0..] . NEL.toList) args
let pathSegment = FuzzOp offset (map (\(index,(_,dyn) ) -> Provenance (dynTypeRep dyn) index) r)
(offset, EndpointOption{..}) <- elementOrFail . options =<< get
r <- V.rtraverse
(\(tr :*: StashValue svs) -> elementOrFail $
zipWith (\i xy -> V.Const i :*: tr :*: xy)
[0..]
(NEL.toList svs)
)
eoArgs
let pathSegment = FuzzOp offset $
recordToList'
(\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)
r
argValues = V.rmap
(\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)
r
modify' (\f -> f { path = path f <> [pathSegment] })
pure (pathSegment, dynCall, fmap (snd . snd) r)
callback pathSegment eoCall argValues
where
options :: FuzzState -> [(ApiOffset, Dynamic, [NEL.NonEmpty ([Provenance], Dynamic)])]
options :: FuzzState -> [(ApiOffset, EndpointOption)]
options FuzzState{..} =
mapMaybe
( \(offset, (argreps, dynCall)) -> (offset,dynCall,) <$> do
mapM (\(_tr,bf) -> bf stash ) argreps
( \(offset, ReifiedEndpoint{..}) -> do
args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
pure (offset, EndpointOption reEndpointFunc args)
)
reifiedApi
execute :: (MonadState FuzzState m, MonadIO m)
=> (FuzzOp,Dynamic,[Dynamic]) -> m ()
execute (fuzzop, dyncall, args) = do
execute :: (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as)
=> FuzzOp
-> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
-> V.Rec (TypedF V.Identity) as
-> m ()
execute fuzzop func args = do
liftIO $ print fuzzop
-- now, magic happens: we apply some dynamic arguments to a dynamic
-- function and hopefully something useful pops out the end.
let func = foldr (\arg curr -> flip dynApply arg =<< curr) (Just dyncall) (reverse args)
st <- get
let showable = unlines $ ("args":map (show . dynTypeRep) args)
let showable = unlines $ ("args":map show argTypes)
<> ["fuzzop"
, show fuzzop
,"dyncall"
,show (dynTypeRep dyncall)
-- ,"dyncall"
-- ,show (dynTypeRep dyncall)
,"state"
,show st]
liftIO $ putStrLn showable
case func of
Nothing -> error ("all screwed up 1: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
Just (f') -> do
-- liftIO $ print
case fromDynamic f' of
Nothing -> error ("all screwed up 2: " <> maybe ("nothing: " <> show showable) (show . dynTypeRep) func)
Just (f) -> liftIO f >>= \case
-- parameterise this
Left (serverError :: ServerError) ->
case errHTTPCode serverError of
500 -> throw serverError
_ -> do
liftIO $ print ("ignoring non-500 error" , serverError)
Right (dyn :: NEL.NonEmpty Dynamic) -> do
liftIO $ print ("storing", fmap dynTypeRep dyn)
modify' (\fs@FuzzState{..} ->
fs { stash = addToStash (NEL.toList dyn) stash } )
pure ()
liftIO (V.runcurry' func argVals) >>= \case
-- parameterise this
Left (serverError :: ServerError) ->
case errHTTPCode serverError of
500 -> throw serverError
_ -> do
liftIO $ print ("ignoring non-500 error" , serverError)
Right (dyn :: NEL.NonEmpty Dynamic) -> do
liftIO $ print ("storing", fmap dynTypeRep dyn)
modify' (\fs@FuzzState{..} ->
fs { stash = addToStash (NEL.toList dyn) stash } )
where
argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)
=> m ()
go = do
op <- genOp
catches (execute op)
go = withOp $ \op func args -> do
catches (execute op func args)
[ Handler (\(e :: SomeAsyncException) -> throw e)
, Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) =<< get)
]
@ -177,17 +208,30 @@ fuzz server Config{..} checker = do
-- (fmap preload seed <> [callEndpoint reifiedApi])
-- executeSequential emptyState actions
addToStash :: [Dynamic]
-> Map TypeRep (NEL.NonEmpty ([Provenance], Dynamic))
-> Map TypeRep (NEL.NonEmpty ([Provenance], Dynamic))
-> Stash
-> Stash
addToStash result stash =
foldr (\dyn dict -> let tr = dynTypeRep dyn in
Map.insertWith renumber tr (pure ([Provenance tr 0],dyn)) dict) stash result
foldr (\(Dynamic tr x) (Stash dict) -> Stash $
DM.insertWith renumber tr (StashValue (([Provenance (R.SomeTypeRep tr) 0],x):|[])) dict
-- in DM.insertWith renumber _ (pure ([Provenance tr 0],x)) dict
)
stash
result
-- Map.insertWith (flip (<>)) (dynTypeRep result) (_pure result) stash })
where
renumber :: NEL.NonEmpty ([Provenance],Dynamic)
-> NEL.NonEmpty ([Provenance],Dynamic)
-> NEL.NonEmpty ([Provenance],Dynamic)
renumber singleDyn l = case NEL.toList singleDyn of
renumber :: StashValue a
-> StashValue a
-> StashValue a
renumber (StashValue singleDyn) (StashValue l) = StashValue $ case NEL.toList singleDyn of
[([Provenance tr _], dyn)] -> l
<> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
_ -> error "should be impossible"
-- why isn't this in vinyl?
recordToList'
:: (V.RecordToList as, V.RMap as)
=> (forall x. f x -> a)
-> V.Rec f as
-> [a]
recordToList' f = V.recordToList . V.rmap (V.Const . f)

41
src/Roboservant/Types/Breakdown.hs
View File

@ -1,11 +1,13 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
@ -25,16 +27,32 @@ import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy (..))
import Data.Typeable (TypeRep, Typeable, typeRep)
import qualified Data.Dependent.Map as DM
import Data.Dependent.Map (DMap)
import qualified Type.Reflection as R
import Data.Dependent.Sum
import Data.Kind
data Provenance
= Provenance TypeRep Int
= Provenance R.SomeTypeRep Int
deriving (Show,Eq)
type Stash = Map TypeRep (NonEmpty ([Provenance], Dynamic))
class Typeable x => BuildFrom x where
buildFrom :: Stash -> Maybe (NonEmpty ([Provenance],Dynamic))
default buildFrom :: Stash -> Maybe (NonEmpty ([Provenance], Dynamic))
buildFrom = Map.lookup (typeRep (Proxy @x))
newtype StashValue a = StashValue { getStashValue :: NonEmpty ([Provenance], a) }
deriving (Functor, Show)
-- wrap in newtype to give a custom Show instance, since the normal
-- instance for DMap is not happy since StashValue needs Show a to show
newtype Stash = Stash { getStash :: DMap R.TypeRep StashValue }
deriving (Semigroup, Monoid)
instance Show Stash where
showsPrec i (Stash x) = showsPrec i $
Map.fromList . map (\(tr :=> StashValue vs) -> (R.SomeTypeRep tr, fmap fst vs)) $ DM.toList x
class Typeable x => BuildFrom (x :: Type) where
buildFrom :: Stash -> Maybe (StashValue x)
default buildFrom :: Stash -> Maybe (StashValue x)
buildFrom = DM.lookup R.typeRep . getStash
-- (fmap promisedDyn . NEL.toList) . Map.lookup (typeRep (Proxy @x))
@ -50,11 +68,12 @@ promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . f
instance BuildFrom Bool
instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where
buildFrom dict = Just $ fmap toDyn <$> options
where options :: NonEmpty ([Provenance], Maybe x)
options = ([],Nothing) :|
(maybe [] NEL.toList . fmap (fmap (fmap (Just . promisedDyn @x)))
$ buildFrom @x dict)
buildFrom dict = Just options
where options :: StashValue (Maybe x)
options = StashValue $
([],Nothing) :|
(maybe [] (NEL.toList . getStashValue . fmap Just) $ buildFrom @x dict
)
class Breakdown x where
breakdown :: x -> NonEmpty Dynamic

149
src/Roboservant/Types/ReifiedApi.hs
View File

@ -2,10 +2,13 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
@ -18,43 +21,76 @@ module Roboservant.Types.ReifiedApi where
import Control.Monad.Except (runExceptT)
import Data.Bifunctor
import Data.Dependent.Sum
import Data.Dynamic (Dynamic, toDyn)
import Data.Function ((&))
import Data.Kind
import Data.List.NonEmpty (NonEmpty)
import Data.Typeable (TypeRep, Typeable, typeRep)
import GHC.Generics ((:*:)(..))
import GHC.TypeLits (Symbol)
import Roboservant.Types.Breakdown
import Roboservant.Types.FlattenServer
import Servant
import Servant.API.Modifiers(FoldRequired,FoldLenient)
import Roboservant.Types.FlattenServer
import Roboservant.Types.Breakdown
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Text as T
import qualified Data.Vinyl as V
import qualified Data.Vinyl.Curry as V
import qualified Type.Reflection as R
newtype ApiOffset = ApiOffset Int
deriving (Eq, Show)
deriving newtype (Enum, Num)
type ReifiedEndpoint = ([(TypeRep, Stash -> Maybe (NonEmpty ([Provenance], Dynamic)))], Dynamic)
type TypedF = (:*:) R.TypeRep
newtype Argument a = Argument
{ getArgument :: Stash -> Maybe (StashValue a)
}
data ReifiedEndpoint = forall as. (V.RecordToList as, V.RMap as) => ReifiedEndpoint
{ reArguments :: V.Rec (TypedF Argument) as
, reEndpointFunc :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
}
type ReifiedApi = [(ApiOffset, ReifiedEndpoint)]
tagType :: Typeable a => f a -> TypedF f a
tagType = (R.typeRep :*:)
class ToReifiedApi (endpoints :: [*]) where
toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
class ToReifiedEndpoint (endpoint :: *) where
toReifiedEndpoint :: Dynamic -> Proxy endpoint -> ReifiedEndpoint
class ( V.Curried (EndpointArgs endpoint) (Handler (EndpointRes endpoint)) ~ Server endpoint
, V.RecordToList (EndpointArgs endpoint)
, V.RMap (EndpointArgs endpoint)
) => ToReifiedEndpoint (endpoint :: *) where
type EndpointArgs endpoint :: [Type]
type EndpointRes endpoint :: Type
reifiedEndpointArguments :: V.Rec (TypedF Argument) (EndpointArgs endpoint)
instance ToReifiedApi '[] where
toReifiedApi NoEndpoints _ = []
instance
(Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)) =>
( Typeable (EndpointRes endpoint)
, NormalizeFunction (ServerT endpoint Handler)
, Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either ServerError (NonEmpty Dynamic)))
, ToReifiedEndpoint endpoint
, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)
) =>
ToReifiedApi (endpoint : endpoints)
where
toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
(0,) (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))
: map
(\(n, x) -> (n + 1, x))
(0, ReifiedEndpoint
{ reArguments = reifiedEndpointArguments @endpoint
, reEndpointFunc = normalize endpoint
}
)
: (map . first) (+1)
(toReifiedApi endpoints (Proxy @endpoints))
class NormalizeFunction m where
@ -71,35 +107,37 @@ instance (Typeable x, Breakdown x) => NormalizeFunction (Handler x) where
Left serverError -> pure (Left serverError)
Right x -> pure $ Right $ breakdown x
-- pure (Right (typeRep (Proxy @x), toDyn x))
instance
(Typeable responseType, Breakdown responseType) =>
ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
where
toReifiedEndpoint endpoint _ = id
([], endpoint)
type EndpointArgs (Verb method statusCode contentTypes responseType) = '[]
type EndpointRes (Verb method statusCode contentTypes responseType) = responseType
reifiedEndpointArguments = V.RNil
instance
(ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint ((x :: Symbol) :> endpoint)
where
toReifiedEndpoint endpoint _ =
toReifiedEndpoint endpoint (Proxy @endpoint)
type EndpointArgs ((x :: Symbol) :> endpoint) = EndpointArgs endpoint
type EndpointRes ((x :: Symbol) :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments = reifiedEndpointArguments @endpoint
instance
(ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint (Description s :> endpoint)
where
toReifiedEndpoint endpoint _ =
toReifiedEndpoint endpoint (Proxy @endpoint)
type EndpointArgs (Description s :> endpoint) = EndpointArgs endpoint
type EndpointRes (Description s :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments = reifiedEndpointArguments @endpoint
instance
(ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint (Summary s :> endpoint)
where
toReifiedEndpoint endpoint _ =
toReifiedEndpoint endpoint (Proxy @endpoint)
type EndpointArgs (Summary s :> endpoint) = EndpointArgs endpoint
type EndpointRes (Summary s :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments = reifiedEndpointArguments @endpoint
instance
(Typeable requestType
@ -107,58 +145,57 @@ instance
,ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint (QueryFlag name :> endpoint)
where
toReifiedEndpoint endpoint _ =
toReifiedEndpoint endpoint (Proxy @endpoint)
& \(args, result) -> ((typeRep (Proxy @Bool),buildFrom @Bool) : args, result)
type EndpointArgs (QueryFlag name :> endpoint) = Bool ': EndpointArgs endpoint
type EndpointRes (QueryFlag name :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments = tagType (Argument (buildFrom @Bool)) V.:& reifiedEndpointArguments @endpoint
type IfLenient s mods t = If (FoldLenient mods) (Either s t) t
type IfRequired mods t = If (FoldRequired mods) t (Maybe t)
type IfRequiredLenient s mods t = IfRequired mods (IfLenient s mods t)
instance
( Typeable (If (FoldRequired mods) paramType (Maybe paramType))
, BuildFrom (If (FoldRequired mods) paramType (Maybe paramType))
( BuildFrom (IfRequiredLenient T.Text mods paramType)
, ToReifiedEndpoint endpoint
, SBoolI (FoldRequired mods)) =>
) =>
ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)
where
toReifiedEndpoint endpoint _ =
toReifiedEndpoint endpoint (Proxy @endpoint)
& \(args, result) ->
((typeRep (Proxy @(If (FoldRequired mods) paramType (Maybe paramType)))
,buildFrom @(If (FoldRequired mods) paramType (Maybe paramType)))
: args, result)
type EndpointArgs (QueryParam' mods name paramType :> endpoint) = IfRequiredLenient T.Text mods paramType ': EndpointArgs endpoint
type EndpointRes (QueryParam' mods name paramType :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments =
tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods paramType)))
V.:& reifiedEndpointArguments @endpoint
instance
( Typeable (If (FoldRequired mods) headerType (Maybe headerType))
, BuildFrom (If (FoldRequired mods) headerType (Maybe headerType))
( BuildFrom (IfRequiredLenient T.Text mods headerType)
, ToReifiedEndpoint endpoint
, SBoolI (FoldRequired mods)) =>
) =>
ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)
where
toReifiedEndpoint endpoint _ =
toReifiedEndpoint endpoint (Proxy @endpoint)
& \(args, result) -> ((typeRep (Proxy @(If (FoldRequired mods) headerType (Maybe headerType)))
,buildFrom @(If (FoldRequired mods) headerType (Maybe headerType)))
: args, result)
type EndpointArgs (Header' mods headerName headerType :> endpoint) = IfRequiredLenient T.Text mods headerType ': EndpointArgs endpoint
type EndpointRes (Header' mods headerName headerType :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments =
tagType (Argument (buildFrom @(IfRequiredLenient T.Text mods headerType)))
V.:& reifiedEndpointArguments @endpoint
instance
( Typeable captureType
, BuildFrom captureType
( BuildFrom (IfLenient String mods captureType)
, ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint (Capture' mods name captureType :> endpoint)
where
toReifiedEndpoint endpoint _ =
toReifiedEndpoint endpoint (Proxy @endpoint)
& \(args, result) -> ((typeRep (Proxy @captureType)
,buildFrom @captureType)
: args, result)
type EndpointArgs (Capture' mods name captureType :> endpoint) = IfLenient String mods captureType ': EndpointArgs endpoint
type EndpointRes (Capture' mods name captureType :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments =
tagType (Argument (buildFrom @(IfLenient String mods captureType)))
V.:& reifiedEndpointArguments @endpoint
instance
( Typeable (If (FoldLenient mods) (Either String requestType) requestType)
, BuildFrom (If (FoldLenient mods) (Either String requestType) requestType)
, ToReifiedEndpoint endpoint, SBoolI (FoldLenient mods)) =>
( BuildFrom (IfLenient String mods requestType)
, ToReifiedEndpoint endpoint) =>
ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)
where
toReifiedEndpoint endpoint _ =
toReifiedEndpoint endpoint (Proxy @endpoint)
& \(args, result) -> ((typeRep (Proxy @(If (FoldLenient mods) (Either String requestType) requestType))
,buildFrom @(If (FoldLenient mods) (Either String requestType) requestType))
: args, result)
type EndpointArgs (ReqBody' mods contentTypes requestType :> endpoint) = IfLenient String mods requestType ': EndpointArgs endpoint
type EndpointRes (ReqBody' mods contentTypes requestType :> endpoint) = EndpointRes endpoint
reifiedEndpointArguments =
tagType (Argument (buildFrom @(IfLenient String mods requestType)))
V.:& reifiedEndpointArguments @endpoint

4
stack.yaml
View File

@ -13,6 +13,10 @@ extra-deps:
- QuickCheck-2.14.1@sha256:01e46d7b0a8d3148288ec977625f62d5516ebb5031a50c63f0453863301b4a79,7736
- random-1.2.0
- splitmix-0.1.0.1@sha256:22f9662e7e8b173421872241edd39350078a9ed4bb9e9f503948c5b483c79276,5253
- vinyl-0.13.0
- dependent-sum-0.7.1.0
- constraints-extras-0.3.0.2
- dependent-map-0.4.0.0
- git: https://github.com/hedgehogqa/haskell-hedgehog.git
commit: 03714682586e43b5ddf5c00391035471a6e01238
subdirs:

28
stack.yaml.lock
View File

@ -67,6 +67,34 @@ packages:
sha256: b9a0c60e2d4786bbb276ce6606027a99615bf703fa3e0f01911e8c6a656c5161
original:
hackage: splitmix-0.1.0.1@sha256:22f9662e7e8b173421872241edd39350078a9ed4bb9e9f503948c5b483c79276,5253
- completed:
hackage: vinyl-0.13.0@sha256:0f247cd3f8682b30881a07de18e6fec52d540646fbcb328420049cc8d63cd407,3724
pantry-tree:
size: 1857
sha256: 860fb95820b595161cdbdec5f376100ebae2d14e5ef0dbe311546202f7525d01
original:
hackage: vinyl-0.13.0
- completed:
hackage: dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068
pantry-tree:
size: 290
sha256: 9cbfb32b5a8a782b7a1c941803fd517633cb699159b851c1d82267a9e9391b50
original:
hackage: dependent-sum-0.7.1.0
- completed:
hackage: constraints-extras-0.3.0.2@sha256:013b8d0392582c6ca068e226718a4fe8be8e22321cc0634f6115505bf377ad26,1853
pantry-tree:
size: 594
sha256: 3ce1012bfb02e4d7def9df19ce80b8cd2b472c691b25b181d9960638673fecd1
original:
hackage: constraints-extras-0.3.0.2
- completed:
hackage: dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657
pantry-tree:
size: 551
sha256: 5defa30010904d2ad05a036f3eaf83793506717c93cbeb599f40db1a3632cfc5
original:
hackage: dependent-map-0.4.0.0
- completed:
subdir: hedgehog
name: hedgehog