mirror of
https://github.com/ilyakooo0/roboservant.git
synced 2024-09-11 08:05:47 +03:00
Merge branch 'typesafe-servant' of https://github.com/mstksg/roboservant
This commit is contained in:
Mark Wotton
commit
1e54b220e8
@ -2,8 +2,6 @@ name: roboservant
|
||||
version: 0.1.0.2
|
||||
github: "mwotton/roboservant"
|
||||
license: BSD3
|
||||
author: "Mark Wotton, Samuel Schlesinger"
|
||||
maintainer: "mwotton@gmail.com"
|
||||
copyright: "2020 Mark Wotton, Samuel Schlesinger"
|
||||
synopsis: Automatic session-aware servant testing
|
||||
category: Web
|
||||
@ -27,6 +25,10 @@ dependencies:
|
||||
- servant-flatten
|
||||
- servant-server # >= 0.17
|
||||
- string-conversions
|
||||
- vinyl
|
||||
- dependent-sum
|
||||
- dependent-map
|
||||
- text
|
||||
- time
|
||||
|
||||
ghc-options:
|
||||
@ -49,4 +51,3 @@ tests:
|
||||
- aeson
|
||||
- hspec
|
||||
- hspec-core
|
||||
|
||||
|
||||
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 838fa22fc3ea6673432f485653caaca6c43bccce724777fafbb903dad8ce30cd
|
||||
-- hash: 49f8c03988a25b7e35dddaab65f250955a078392aaa293298885aea164315479
|
||||
|
||||
name: roboservant
|
||||
version: 0.1.0.2
|
||||
@ -13,8 +13,6 @@ description: Please see the README on GitHub at <https://github.com/mwotton/r
|
||||
category: Web
|
||||
homepage: https://github.com/mwotton/roboservant#readme
|
||||
bug-reports: https://github.com/mwotton/roboservant/issues
|
||||
author: Mark Wotton, Samuel Schlesinger
|
||||
maintainer: mwotton@gmail.com
|
||||
copyright: 2020 Mark Wotton, Samuel Schlesinger
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
@ -44,6 +42,8 @@ library
|
||||
base >=4.7 && <5
|
||||
, bytestring
|
||||
, containers
|
||||
, dependent-map
|
||||
, dependent-sum
|
||||
, lifted-base
|
||||
, monad-control
|
||||
, mtl
|
||||
@ -53,13 +53,16 @@ library
|
||||
, servant-flatten
|
||||
, servant-server
|
||||
, string-conversions
|
||||
, text
|
||||
, time
|
||||
, vinyl
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite roboservant-test
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
BuildFrom
|
||||
Foo
|
||||
Headers
|
||||
Seeded
|
||||
@ -74,6 +77,8 @@ test-suite roboservant-test
|
||||
, base >=4.7 && <5
|
||||
, bytestring
|
||||
, containers
|
||||
, dependent-map
|
||||
, dependent-sum
|
||||
, hspec
|
||||
, hspec-core
|
||||
, lifted-base
|
||||
@ -86,5 +91,7 @@ test-suite roboservant-test
|
||||
, servant-flatten
|
||||
, servant-server
|
||||
, string-conversions
|
||||
, text
|
||||
, time
|
||||
, vinyl
|
||||
default-language: Haskell2010
|
||||
|
||||
@ -7,6 +7,7 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
@ -20,7 +21,7 @@ module Roboservant.Direct
|
||||
( fuzz, Config(..)
|
||||
|
||||
-- TODO come up with something smarter than exporting all this, we should
|
||||
-- have some nice error-display functions
|
||||
-- have some nice error-display functions
|
||||
, RoboservantException(..), FuzzState(..), FuzzOp(..)
|
||||
)
|
||||
where
|
||||
@ -28,8 +29,13 @@ where
|
||||
import Control.Exception.Lifted(throw,handle,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
|
||||
import Control.Monad(void,replicateM)
|
||||
import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,runStateT)
|
||||
import Control.Exception.Lifted(throw,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
|
||||
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 qualified Data.Set as Set
|
||||
import Data.Maybe (mapMaybe)
|
||||
@ -37,9 +43,15 @@ 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 Data.Time.Clock
|
||||
import qualified Type.Reflection as R
|
||||
|
||||
import Roboservant.Types.Breakdown
|
||||
import Roboservant.Types
|
||||
@ -47,10 +59,14 @@ import Roboservant.Types
|
||||
FlattenServer (..),
|
||||
-- ReifiedApi,
|
||||
ToReifiedApi (..),
|
||||
ReifiedEndpoint(..),
|
||||
Argument(..),
|
||||
TypedF
|
||||
|
||||
)
|
||||
|
||||
data RoboservantException
|
||||
= RoboservantException FailureType (Maybe SomeException) Int FuzzState
|
||||
= RoboservantException FailureType (Maybe SomeException) Int FuzzState
|
||||
deriving (Show)
|
||||
-- we believe in nussink, lebowski
|
||||
instance Exception RoboservantException
|
||||
@ -63,7 +79,7 @@ data FailureType
|
||||
deriving (Show,Eq)
|
||||
|
||||
|
||||
data FuzzOp = FuzzOp
|
||||
data FuzzOp = FuzzOp
|
||||
{ apiOffset :: ApiOffset
|
||||
, provenance :: [Provenance]
|
||||
} deriving (Show,Eq)
|
||||
@ -82,7 +98,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
|
||||
}
|
||||
|
||||
data StopReason
|
||||
= TimedOut
|
||||
@ -91,7 +112,7 @@ data StopReason
|
||||
|
||||
data Report = Report
|
||||
{ textual :: String }
|
||||
deriving (Show,Eq)
|
||||
deriving (Show,Eq)
|
||||
|
||||
fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))
|
||||
=> Server api
|
||||
@ -103,16 +124,23 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
|
||||
stash = addToStash seed mempty
|
||||
currentRng = mkStdGen rngSeed
|
||||
|
||||
|
||||
|
||||
deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime
|
||||
-- either we time out without finding an error, which is fine, or we find an error
|
||||
-- and throw an exception that propagates through this.
|
||||
|
||||
|
||||
(stopreason, fs ) <- runStateT
|
||||
(untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get)) FuzzState{..}
|
||||
pure Nothing
|
||||
-- mapM_ (print . (\(offset, (args, dyn) ) -> (offset, map fst args, dyn))) reifiedApi
|
||||
|
||||
|
||||
-- void $ timeout (maxRuntime * 1000000) ( execStateT (replicateM maxReps go) FuzzState{..})
|
||||
-- forM_ reifiedApi $ \(offset, ReifiedEndpoint{..}) ->
|
||||
-- print (
|
||||
-- offset
|
||||
-- , recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) reArguments
|
||||
-- )
|
||||
where
|
||||
-- something less terrible later
|
||||
formatException :: RoboservantException -> Report
|
||||
@ -126,7 +154,7 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
|
||||
| otherwise = throw $ RoboservantException InsufficientCoverage Nothing routeCount f
|
||||
where hitRoutes = (fromIntegral . Set.size . Set.fromList $ map apiOffset path)
|
||||
totalRoutes = (fromIntegral routeCount)
|
||||
|
||||
|
||||
|
||||
untilDone :: MonadIO m => (Integer,UTCTime) -> m a -> m StopReason
|
||||
untilDone (0,_) _ = pure HitMaxIterations
|
||||
@ -137,10 +165,10 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
|
||||
else do
|
||||
action
|
||||
untilDone (n-1, deadline) action
|
||||
|
||||
|
||||
reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
|
||||
routeCount = length reifiedApi
|
||||
|
||||
|
||||
elementOrFail :: (MonadState FuzzState m, MonadIO m)
|
||||
=> [a] -> m a
|
||||
elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing routeCount =<< get
|
||||
@ -150,92 +178,108 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ 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
|
||||
-- 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)
|
||||
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
|
||||
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 $ putStrLn showable
|
||||
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) routeCount =<< get)
|
||||
]
|
||||
catch (liftIO checker)
|
||||
(\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) routeCount =<< get)
|
||||
|
||||
-- actions <-
|
||||
-- forAll $ do
|
||||
-- Gen.sequential
|
||||
-- (Range.linear 1 100)
|
||||
-- emptyState
|
||||
-- (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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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,45 +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, Ord)
|
||||
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
|
||||
@ -73,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
|
||||
@ -109,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
|
||||
|
||||
@ -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:
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user