packages feed

roboservant (empty) → 0.1.0.0

raw patch · 10 files changed

+573/−0 lines, 10 filesdep +QuickCheckdep +aesondep +basesetup-changed

Dependencies added: QuickCheck, aeson, base, bytestring, containers, hedgehog, hspec, http-client, http-media, mtl, quickcheck-state-machine, roboservant, servant, servant-client, servant-flatten, servant-server, string-conversions

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for roboservant++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,84 @@+# roboservant++Automatically fuzz your servant apis in a contextually-aware way.++![CI](https://github.com/mwotton/roboservant/workflows/CI/badge.svg)+++# why?++Servant gives us a lot of information about what a server can do. We+use this information to generate arbitrarily long request/response+sessions and verify properties that should hold over them.++# example++Our api under test:++```+newtype Foo = Foo Int+  deriving (Generic, Eq, Show, Typeable)+  deriving newtype (FromHttpApiData, ToHttpApiData)++type FooApi =+  "item" :> Get '[JSON] Foo+    :<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo+    :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()+```++From the tests:++```+  let reifiedApi = RS.toReifiedApi (RS.flattenServer @Foo.FooApi Foo.fooServer) (Proxy @(Endpoints Foo.FooApi))+  assert "should find an error in Foo" . not+    =<< checkSequential (Group "Foo" [("Foo", RS.prop_sequential reifiedApi)])+```++We have a server that blows up if the value of the int in a `Foo` ever gets above 10. Note:+there is no generator for `Foo` types: larger `Foo`s can only be made only by combining existing+`Foo`s with `itemAdd`. This is an important distinction, because many APIs will return UUIDs or+similar as keys, which make it impossible to cover a useful section of the state space without+using the values returned by the API+++# why not servant-quickcheck?++[servant-quickcheck](https://hackage.haskell.org/package/servant-quickcheck)+is a great package and I've learned a lot from it. Unfortunately, as mentioned previously,+there's a lot of the state space you just can't explore without context: modern webapps are+full of pointer-like structures, whether they're URLs or database+keys/uuids, and servant-quickcheck requires that you be able to generate+these without context via Arbitrary.++## extensions/todo++- add some "starter" values to the store+  - there may be a JWT that's established outside the servant app, for instance.+- `class Extras a where extras :: Gen [a]`+  - default implementation `pure []`+  - selectively allow some types to create values we haven't seen from the api.+	`newtype FirstName = FirstName Text`, say.+- break down each response type into its components+  - if i have+	- `data Foo = FBar Bar | FBaz Baz`+	- an endpoint `foo` that returns a `Foo`+	- and an endpoint `bar` that takes a `Bar`+  - I should be able to call `foo` to get a `Foo`, and if it happens to be an `FBar Bar`, I+	should be able to use that `Bar` to call `bar`.+- better handling of properties to be verified+  - some properties should always hold (no 500s): this already works.+  - to-do: there may be some other properties that hold contextually+	- healthcheck should be 200+	- test complex permissions/ownership/delegation logic - should never be able to+	  get access to something you don't own or haven't been delegated access to.++## other possible applications++- coverage+  - if you run the checker for a while and `hpc` suggests you still have bad coverage,+	your api is designed in a way that requires external manipulation and may be improvable.++- benchmarking+  - we can generate "big-enough" call sequences, then save the database & a sample call for each+	endpoint that takes long enough to be a reasonable test.+  - from this we can generate tests that a given call on that setup never gets slower.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ roboservant.cabal view
@@ -0,0 +1,86 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 51154f1c866aea92673a52985de6810cebda3b2662fddd7b7f88a56725e30041++name:           roboservant+version:        0.1.0.0+synopsis:       Automatic session-aware servant testing+description:    Please see the README on GitHub at <https://github.com/githubuser/roboservant#readme>+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+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/mwotton/roboservant++library+  exposed-modules:+      Roboservant+      Roboservant.StateMachine+  other-modules:+      Paths_roboservant+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      QuickCheck+    , aeson+    , base >=4.7 && <5+    , bytestring+    , containers+    , hedgehog+    , hspec+    , http-client+    , http-media+    , mtl+    , quickcheck-state-machine >=0.7+    , servant >=0.17+    , servant-client >=0.17+    , servant-flatten+    , servant-server >=0.17+    , string-conversions+  default-language: Haskell2010++test-suite roboservant-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Foo+      UnsafeIO+      Paths_roboservant+  hs-source-dirs:+      test+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      QuickCheck+    , aeson+    , base >=4.7 && <5+    , bytestring+    , containers+    , hedgehog+    , hspec+    , http-client+    , http-media+    , mtl+    , quickcheck-state-machine >=0.7+    , roboservant+    , servant >=0.17+    , servant-client >=0.17+    , servant-flatten+    , servant-server >=0.17+    , string-conversions+  default-language: Haskell2010
+ src/Roboservant.hs view
@@ -0,0 +1,3 @@+module Roboservant (module Roboservant.StateMachine) where++import Roboservant.StateMachine
+ src/Roboservant/StateMachine.hs view
@@ -0,0 +1,250 @@+{-# 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 #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Roboservant.StateMachine where++import Control.Monad.Except (runExceptT)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic, toDyn)+import Data.Function ((&))+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 (mapMaybe)+import Data.Typeable (TypeRep, Typeable, typeRep)+import GHC.IORef (readIORef)+import GHC.TypeLits (Symbol)+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Servant+import Type.Reflection (SomeTypeRep)++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 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' ->+            s+              { stateRefs =+                  let (_, _, tr, _) = staticRoutes !! offset+                   in Map.insertWith+                        (<>)+                        tr+                        (pure o')+                        stateRefs+              }+          -- , Ensure (no-500 here)+        ]++prop_sequential :: ReifiedApi -> Property+prop_sequential reifiedApi = do+  property $ do+    let initialState = State mempty+    actions <-+      forAll $+        Gen.sequential+          (Range.linear 1 100)+          initialState+          [callEndpoint reifiedApi]+    executeSequential initialState actions++prop_concurrent :: ReifiedApi -> Property+prop_concurrent reifiedApi =+  let initialState = State mempty+   in withTests 1000 . withRetries 10 . property $ do+        actions <-+          forAll $+            Gen.parallel+              (Range.linear 1 50)+              (Range.linear 1 10)+              initialState+              [callEndpoint reifiedApi]+        test $+          executeParallel initialState actions
+ test/Foo.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Foo where++import Data.Aeson+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Servant++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 :: Handler Foo+intro = pure (Foo 1)++combine :: Foo -> Foo -> Handler Foo+combine (Foo a) (Foo b) = pure (Foo (a + b))++eliminate :: Foo -> Handler ()+eliminate (Foo a)+  | a > 10 = throwError $ err500 {errBody = "eliminate blew up, oh no!"}+  | otherwise = pure ()++fooServer :: Server FooApi+fooServer =+  intro+    :<|> combine+    :<|> eliminate
+ test/Spec.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++import Data.Proxy (Proxy (..))+import qualified Foo+import Hedgehog (Group (..), checkSequential)+import qualified Roboservant as RS+import Servant (Endpoints)+import qualified UnsafeIO++-- | this is pretty bad. hopefully Jacob knows a better way of doing this.+--   https://twitter.com/mwotton/status/1305189249646460933+assert :: String -> Bool -> IO ()+assert _ True = pure ()+assert err False = ioError $ userError err++-- | This is horribly laid out, sorry. Will fix at some point.+main :: IO ()+main = do+  let reifiedApi = RS.toReifiedApi (RS.flattenServer @Foo.FooApi Foo.fooServer) (Proxy @(Endpoints Foo.FooApi))+  assert "should find an error in Foo" . not+    =<< checkSequential (Group "Foo" [("Foo", RS.prop_sequential reifiedApi)])+  -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it+  -- could: it's mostly here to show how to test for concurrency problems.+  unsafeServer <- UnsafeIO.makeServer+  let unsafeApi = RS.toReifiedApi (RS.flattenServer @UnsafeIO.UnsafeApi unsafeServer) (Proxy @(Endpoints UnsafeIO.UnsafeApi))+  -- this will not detect the error, as it requires concurrency.+  assert "should find nothing" =<< checkSequential (Group "Unsafe" [("Sequential", RS.prop_sequential unsafeApi)])+  -- this will!+  assert "should find with parallel check" . not+    =<< checkSequential (Group "Unsafe" [("Parallel", RS.prop_concurrent unsafeApi)])
+ test/UnsafeIO.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module UnsafeIO where++import Data.Aeson()+import Servant+import Data.IORef (writeIORef, IORef, readIORef, newIORef)+import Control.Monad.Trans (MonadIO(liftIO))+import qualified Data.ByteString.Lazy.Char8 as BL8+++type UnsafeApi =+  "add" :> Get '[JSON] ()+  :<|> "healthcheck" :> Get '[JSON] ()++healthcheck :: IORef Int -> Handler ()+healthcheck ref = do+  t <- liftIO $ readIORef ref+  case t of+    0 -> pure ()+    n -> throwError $ err500 {errBody = "observed inconsistency: " <> (BL8.pack $ show n)}++++makeServer :: IO (Server UnsafeApi)+makeServer = do+  ref <- newIORef 0+  pure $ unsafeMunge ref+    :<|> healthcheck ref++unsafeMunge :: IORef Int -> Handler ()+unsafeMunge ref = liftIO $ do+  t <- readIORef ref+  writeIORef ref (t+1)+  t2 <- readIORef ref+  writeIORef ref (t2-1)