add some examples, remove old code

package.yaml

@@ -1,48 +1,42 @@
 name:                roboservant
 version:             0.1.0.0
-github:              "githubuser/roboservant"
+github:              "mwotton/roboservant"
 license:             BSD3
-author:              "Author name here"
+author:              "Mark Wotton, Samuel Schlesinger"
-maintainer:          "example@example.com"
+maintainer:          "mwotton@gmail.com"
-copyright:           "2020 Author name here"
+copyright:           "2020 Mark Wotton, Samuel Schlesinger"
+synopsis:            Automatic session-aware servant testing
+category:            Web
+description:         Please see the README on GitHub at <https://github.com/githubuser/roboservant#readme>
 
 extra-source-files:
 - README.md
 - ChangeLog.md
 
-# Metadata used when publishing your package
-# synopsis:            Short description of your package
-# category:            Web
-
-# To avoid duplicated efforts in documentation and dealing with the
-# complications of embedding Haddock markup inside cabal files, it is
-# common to point users to the README.md file.
-description:         Please see the README on GitHub at <https://github.com/githubuser/roboservant#readme>
-
 dependencies:
 - base >= 4.7 && < 5
 
-
+- QuickCheck
 - bytestring
-- hedgehog
-- constrained-dynamic
 - containers
+- hedgehog
 - http-client
 - http-media
-- QuickCheck
-- quickcheck-state-machine >= 0.7
 - mtl
+- quickcheck-state-machine >= 0.7
 - servant >= 0.17
 - servant-client >= 0.17
 - servant-flatten
 - servant-server >= 0.17
 - string-conversions
+
 # test deps
 - hspec
 - QuickCheck
-- warp
 - aeson
-- wai
+
+ghc-options: -Wall
+
 library:
   source-dirs: src
 

roboservant.cabal

@@ -1,19 +1,21 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.31.2.
+-- This file has been generated from package.yaml by hpack version 0.33.0.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 9d15f4554f9f8ea8913a6766643b63ee6633016374fc98164e81058799204a87
+-- 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>
-homepage:       https://github.com/githubuser/roboservant#readme
+category:       Web
-bug-reports:    https://github.com/githubuser/roboservant/issues
+homepage:       https://github.com/mwotton/roboservant#readme
-author:         Author name here
+bug-reports:    https://github.com/mwotton/roboservant/issues
-maintainer:     example@example.com
+author:         Mark Wotton, Samuel Schlesinger
-copyright:      2020 Author name here
+maintainer:     mwotton@gmail.com
+copyright:      2020 Mark Wotton, Samuel Schlesinger
 license:        BSD3
 license-file:   LICENSE
 build-type:     Simple
@@ -23,24 +25,22 @@ extra-source-files:
 
 source-repository head
   type: git
-  location: https://github.com/githubuser/roboservant
+  location: https://github.com/mwotton/roboservant
 
 library
   exposed-modules:
       Roboservant
-      Roboservant.ContextualGenRequest
-      Roboservant.Hedgehog
       Roboservant.StateMachine
   other-modules:
       Paths_roboservant
   hs-source-dirs:
       src
+  ghc-options: -Wall
   build-depends:
       QuickCheck
     , aeson
     , base >=4.7 && <5
     , bytestring
-    , constrained-dynamic
     , containers
     , hedgehog
     , hspec
@@ -53,24 +53,23 @@ library
     , servant-flatten
     , servant-server >=0.17
     , string-conversions
-    , wai
-    , warp
   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: -threaded -rtsopts -with-rtsopts=-N
+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       QuickCheck
     , aeson
     , base >=4.7 && <5
     , bytestring
-    , constrained-dynamic
     , containers
     , hedgehog
     , hspec
@@ -84,6 +83,4 @@ test-suite roboservant-test
     , servant-flatten
     , servant-server >=0.17
     , string-conversions
-    , wai
-    , warp
   default-language: Haskell2010

src/Roboservant.hs

@@ -1,110 +1,3 @@
-{-# LANGUAGE LambdaCase #-}
+module Roboservant (module Roboservant.StateMachine) where
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE QuantifiedConstraints #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
-module Roboservant where
 
-import Prelude hiding (lookup)
-import GHC.TypeLits
-import Servant.API
-
-import Roboservant.ContextualGenRequest
 import Roboservant.StateMachine
-
-
--- | Extract the response types from a single servant endpoint, i.e. one
--- without any ':<|>' type constructors in it.
-type family ExtractRespType (path :: *) :: * where
-  ExtractRespType (_ :> b) = ExtractRespType b
-  ExtractRespType (Verb (method :: StdMethod) (responseCode :: Nat) (contentTypes :: [*]) (respType :: *)) = respType
-
--- | Extract the response types from a flattened servant API, i.e. one
--- which has the distributive law (modulo isomorphism) applied to it until
--- it reaches a normal form.
-type family ExtractRespTypes (paths :: *) :: [*] where
-  ExtractRespTypes (a :<|> b) = ExtractRespTypes a <> ExtractRespTypes b
-  ExtractRespTypes a = '[ExtractRespType a]
-
--- | Append two type level lists.
-type family (<>) (xs :: [k]) (ys :: [k]) :: [k] where
-  (x ': xs) <> ys = x ': (xs <> ys)
-  '[] <> ys = ys
-
--- | A homogeneous-functor-list, I guess.
-data List :: (* -> *) -> [*] -> * where
-  Cons :: f a -> List f as -> List f (a ': as)
-  Nil :: List f '[]
-
--- | So we can use efficient container types for specific types if the need
--- arises.
-class Listy f a where
-  cons :: a -> f a -> f a
-  empty :: f a
-  uncons :: f a -> Maybe (a, f a)
-
-instance Listy [] a where
-  cons = (:)
-  empty = []
-  uncons = \case
-    a : as -> Just (a, as)
-    [] -> Nothing
-
--- | A function for inserting elements into their slot in the store.
-class Insert f a as where
-  insert :: a -> List f as -> List f as
-instance {-# OVERLAPPABLE #-} Listy f a => Insert f a (a ': as) where
-  insert a (Cons as ls) = Cons (cons a as) ls
-instance {-# OVERLAPPABLE #-} Insert f a as => Insert f a (b ': as) where
-  insert a (Cons as ls) = Cons as (insert a ls)
-
--- | A function for looking up the container of elements for a specific
--- type in the store.
-class Lookup f a as where
-  lookup :: List f as -> f a
-
-instance {-# OVERLAPPABLE #-} Lookup f a (a ': as) where
-  lookup (Cons fa ls) = fa
-instance {-# OVERLAPPABLE #-} Lookup f a as => Lookup f a (b ': as) where
-  lookup (Cons fa ls) = lookup ls
-
-deriving instance (Show (List f as), forall a. Show a => Show (f a), Show a)
-  => Show (List f (a ': as))
-
-instance Show (List f '[]) where show _ = "Nil" 
-
-storeOfApi :: BuildStore [] (ExtractRespTypes api) => List [] (ExtractRespTypes api)
-storeOfApi = buildStore
-
-class BuildStore f xs where
-  buildStore :: List f xs
-
-instance BuildStore f '[] where
-  buildStore = Nil
-
-instance (BuildStore f as, Listy f a) => BuildStore f (a ': as) where
-  buildStore = Cons empty buildStore
--- 1.
--- Instead of just the resptype, let's return a tuple of (resptype, '[]::[ ? respType])
-
--- 2.
--- break down respType into "useful" components
---   data Baz = Baz { key1 :: Key Foo, key2 :: Key Bar }
---   should insert into type-indexed list three elements
---     'Baz -> whole value
---     '(Key Bar) -> key2
---     '(Key Foo) -> key1
---

src/Roboservant/ContextualGenRequest.hs

@@ -1,238 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes   #-}
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE FlexibleContexts      #-}
-{-# 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         #-}
-{-# LANGUAGE UndecidableInstances  #-}
-module Roboservant.ContextualGenRequest where
-
-import qualified Data.ByteString          as BS
-import qualified Data.ByteString.Internal as BS (c2w)
-import           Data.Data                (Proxy (Proxy))
-import           Data.String              (IsString (fromString))
-import           Data.String.Conversions  (cs)
-import           GHC.TypeLits             (KnownSymbol, Nat, symbolVal)
-import           Network.HTTP.Client      (Request,
-                                           RequestBody (RequestBodyLBS),
-                                           defaultRequest, host, method, path,
-                                           port, queryString, requestBody,
-                                           requestHeaders, secure)
-import           Network.HTTP.Media       (renderHeader)
-import           Servant
-import           Servant.API
-import           Servant.API.ContentTypes (AllMimeRender, allMimeRender)
-import           Servant.Client
--- import           Test.QuickCheck          (Arbitrary, Gen, elements, frequency)
-
-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
-
-class HasContextualGenRequest a where
-  genContextualRequest :: Proxy a -> Map TypeRep Dynamic -> Maybe (Int, Gen ( BaseUrl -> Request))
-
--- | Generatable is functionally equivalent to Arbitrary with a default.
---   It is separate because we want to allow overwriting at will.
-class Generatable a where
-  generator :: Gen [a]
-  generator = pure []
-
-instance ( HasContextualGenRequest a
-         , HasContextualGenRequest b)
-  => HasContextualGenRequest  (a :<|> b) where
-    genContextualRequest _ store
-      = case sub of
-          [] -> Nothing
-          _  -> Just (newfreq, Gen.frequency sub)
-      where
-        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
-
-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
-
-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) store
-        new = cs $ symbolVal (Proxy :: Proxy path)
-
-instance HasContextualGenRequest EmptyAPI where
-  genContextualRequest _ _ = Nothing
-
-instance HasContextualGenRequest api => HasContextualGenRequest (Summary d :> api) where
-  genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
-
-instance HasContextualGenRequest api => HasContextualGenRequest (Description d :> api) where
-  genContextualRequest _ = genContextualRequest (Proxy :: Proxy api)
-
-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 })
-
--- 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
-
-
-
---           return $ \burl -> let r = old' burl
---             in r { path = new'' <> path r })
-
---             -- (oldf, old) = genContextualRequest (Proxy :: Proxy b)
---             -- new = _arbitrary  :: Gen [c]
-
--- instance (KnownSymbol h, HasContextualGenRequest b st, ToHttpApiData c)
---     => HasContextualGenRequest (Header' mods h c :> b) st where
---     genContextualRequest _ = (oldf, do
---       old' <- old
---       new' <- toUrlPiece <$> new  -- TODO: generate lenient or/and optional
---       return $ \burl st -> let r = old' burl st in r {
---           requestHeaders = (hdr, cs new') : requestHeaders r })
---       where
---         (oldf, old) = genContextualRequest (Proxy :: Proxy b)
---         hdr = fromString $ symbolVal (Proxy :: Proxy h)
---         new = _arbitrary :: Gen c
-
--- instance (AllMimeRender x c, HasContextualGenRequest b st)
---     => HasContextualGenRequest (ReqBody' mods x c :> b) st where
---     genContextualRequest _ = (oldf, do
---       old' <- old  -- TODO: generate lenient
---       new' <- new
---       (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
---       return $ \burl st -> let r = old' burl st in r {
---           requestBody = RequestBodyLBS bd
---         , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
---         })
---       where
---         (oldf, old) = genContextualRequest (Proxy :: Proxy b)
---         new = _arbitrary :: Gen c
-
--- instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
---     => HasContextualGenRequest (QueryParam' mods x c :> b) st where
---     genContextualRequest _ = (oldf, do
---       new' <- new  -- TODO: generate lenient or/and optional
---       old' <- old
---       return $ \burl st -> let
---         r = old' burl st
---         newExpr = param <> "=" <> cs (toQueryParam new')
---         qs = queryString r in r {
---           queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs })
---       where
---         (oldf, old) = genContextualRequest (Proxy :: Proxy b)
---         param = cs $ symbolVal (Proxy :: Proxy x)
---         new = _arbitrary :: Gen c
-
--- instance (KnownSymbol x, ToHttpApiData c, HasContextualGenRequest b st)
---     => HasContextualGenRequest (QueryParams x c :> b) st where
---     genContextualRequest _ = (oldf, do
---       (new' :: c) <- _fetch
---       old' <- old
---       return $ \burl st -> let r = old' burl st in r {
---           queryString = queryString r
---                      <> if length new' > 0 then fold (toParam <$> new') else ""})
---       where
---         (oldf, old) = genContextualRequest (Proxy :: Proxy b)
---         param = cs $ symbolVal (Proxy :: Proxy x)
---         toParam c = param <> "[]=" <> cs (toQueryParam c)
---         fold = foldr1 (\a b -> a <> "&" <> b)
-
--- instance (KnownSymbol x, HasContextualGenRequest b st)
---     => HasContextualGenRequest (QueryFlag x :> b) st where
---     genContextualRequest _ = (oldf, do
---       old' <- old
---       return $ \burl st -> let r = old' burl st
---                                qs = queryString r in r {
---           queryString = if BS.null qs then param else param <> "&" <> qs })
---       where
---         (oldf, old) = genContextualRequest (Proxy :: Proxy b)
---         param = cs $ symbolVal (Proxy :: Proxy x)
-
--- instance (ReflectMethod method)
---     => HasContextualGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) st where
---     genContextualRequest _ = (1, return $ \burl st -> defaultRequest
---        { host = cs $ baseUrlHost burl
---        , port = baseUrlPort burl
---        , secure = baseUrlScheme burl == Https
---        , method = reflectMethod (Proxy :: Proxy method)
---        })
-
--- instance (ReflectMethod method)
---     => HasContextualGenRequest (NoContentVerb (method :: k)) st where
---     genContextualRequest _ = (1, return $ \burl st -> defaultRequest
---        { host = cs $ baseUrlHost burl
---        , port = baseUrlPort burl
---        , secure = baseUrlScheme burl == Https
---        , method = reflectMethod (Proxy :: Proxy method)
---        })
-
--- instance (HasContextualGenRequest a st) => HasContextualGenRequest (RemoteHost :> a) st where
---     genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
-
--- instance (HasContextualGenRequest a st) => HasContextualGenRequest (IsSecure :> a) st where
---     genContextualRequest _ = genContextualRequest (Proxy :: Proxy a)
-
--- instance (HasContextualGenRequest a st) => HasContextualGenRequest (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)

src/Roboservant/Hedgehog.hs

@@ -1,41 +0,0 @@
-{-# 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

src/Roboservant/StateMachine.hs

@@ -1,104 +1,41 @@
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
-
+{-# LANGUAGE UndecidableInstances #-}
--- for servant
 
 module Roboservant.StateMachine where
 
-import Control.Arrow (second)
+import Control.Monad.Except (runExceptT)
--- import           Data.Dynamic                     (Dynamic, fromDynamic)
+import Control.Monad.IO.Class (MonadIO, liftIO)
-
+import Data.Dynamic (Dynamic, dynApply, dynTypeRep, fromDynamic, toDyn)
---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.Maybe (mapMaybe)
-import Data.Type.HasClass
+import Data.Typeable (TypeRep, Typeable, typeRep)
-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 GHC.TypeLits (Symbol)
-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 Type.Reflection (SomeTypeRep)
-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 => 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
@@ -109,24 +46,30 @@ class FlattenServer api where
   flattenServer :: Server api -> Bundled (Endpoints api)
 
 instance
-  ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api)
+  ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api),
-  , Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api)
+    Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api),
-  , FlattenServer api
+    FlattenServer api
-  ) => FlattenServer (endpoint :<|> api) where
+  ) =>
+  FlattenServer (endpoint :<|> api)
+  where
   flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
 
 instance
-  ( HasServer (x :> api) '[]
+  ( HasServer (x :> api) '[],
-  , Endpoints (x :> api) ~ '[x :> api]
+    Endpoints (x :> api) ~ '[x :> api]
-  ) => FlattenServer (x :> api) where
+  ) =>
+  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 (Verb method statusCode contentTypes responseType)
+  where
   flattenServer server = server `AnEndpoint` NoEndpoints
-  
+
 type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)
 
 type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]
@@ -144,18 +87,20 @@ class ToReifiedEndpoint (endpoint :: *) where
 instance ToReifiedApi '[] where
   toReifiedApi NoEndpoints _ = []
 
-instance (Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler))
+instance
-  => ToReifiedApi (endpoint : endpoints)
+  (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) _ =
+  toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
-      withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))
+    withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))
-        : map (\(n, x, y, z) -> (n + 1, x, y, z))
+      : map
-            (toReifiedApi endpoints (Proxy @endpoints))
+        (\(n, x, y, z) -> (n + 1, x, y, z))
-      where
+        (toReifiedApi endpoints (Proxy @endpoints))
-        withOffset (x, y, z) = (0, x, y, z)
+    where
+      withOffset (x, y, z) = (0, x, y, z)
 
 class NormalizeFunction m where
-  type Normal m 
+  type Normal m
   normalize :: m -> Normal m
 
 instance NormalizeFunction x => NormalizeFunction (r -> x) where
@@ -167,32 +112,36 @@ instance Typeable x => NormalizeFunction (Handler x) where
   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)
+instance
-  => ToReifiedEndpoint ((x :: Symbol) :> endpoint)
+  Typeable responseType =>
+  ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
   where
-    toReifiedEndpoint endpoint _ =
+  toReifiedEndpoint endpoint _ =
-      toReifiedEndpoint endpoint (Proxy @endpoint) 
+    ([], typeRep (Proxy @responseType), endpoint)
 
-instance (Typeable requestType, ToReifiedEndpoint endpoint)
+instance
-  => ToReifiedEndpoint (Capture name requestType :> endpoint)
+  (ToReifiedEndpoint endpoint) =>
+  ToReifiedEndpoint ((x :: Symbol) :> endpoint)
   where
-    toReifiedEndpoint endpoint _ =
+  toReifiedEndpoint endpoint _ =
-      toReifiedEndpoint endpoint (Proxy @endpoint) 
+    toReifiedEndpoint endpoint (Proxy @endpoint)
-        & \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
 
-instance (Typeable requestType, ToReifiedEndpoint endpoint)
+instance
-  => ToReifiedEndpoint (ReqBody contentTypes requestType :> endpoint)
+  (Typeable requestType, ToReifiedEndpoint endpoint) =>
+  ToReifiedEndpoint (Capture name requestType :> endpoint)
   where
-    toReifiedEndpoint endpoint _ =
+  toReifiedEndpoint endpoint _ =
-      toReifiedEndpoint endpoint (Proxy @endpoint) 
+    toReifiedEndpoint endpoint (Proxy @endpoint)
-        & \(args, result, typeRepMap) -> (typeRep (Proxy @requestType) : args, result, typeRepMap)
+      & \(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)
@@ -205,7 +154,7 @@ 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
+  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 =
@@ -231,7 +180,7 @@ callEndpoint staticRoutes =
           options :: [(ApiOffset, [(TypeRep, [Var (Opaque (IORef Dynamic)) Symbolic])])]
           options =
             mapMaybe
-              ( \(offset, argreps, retType, dynCall) -> (offset,) <$> do
+              ( \(offset, argreps, _retType, _dynCall) -> (offset,) <$> do
                   mapM (\x -> (x,) <$> fillableWith x) argreps
               )
               staticRoutes
@@ -244,8 +193,8 @@ callEndpoint staticRoutes =
       execute (Op (ApiOffset offset) args) = do
         --        traceM (show (offset, args))
         fmap Opaque . liftIO $ do
-          realArgs <- mapM (\(tr, v) -> readIORef (opaque v)) args
+          realArgs <- mapM (\(_tr, v) -> readIORef (opaque v)) args
-          let (_offset, staticArgs, ret, endpoint) = staticRoutes !! offset
+          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
@@ -257,14 +206,11 @@ callEndpoint staticRoutes =
                 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
+                  Right (_typeRep :: SomeTypeRep, (dyn :: Dynamic)) -> newIORef dyn
    in Command
         gen
         execute
-        [ Update $ \s@State {..} (Op (ApiOffset offset) args) o' ->
+        [ 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
@@ -277,8 +223,8 @@ callEndpoint staticRoutes =
           -- , Ensure (no-500 here)
         ]
 
-prop_sm_sequential :: ReifiedApi -> Property
+prop_sequential :: ReifiedApi -> Property
-prop_sm_sequential reifiedApi = do
+prop_sequential reifiedApi = do
   property $ do
     let initialState = State mempty
     actions <-
@@ -289,54 +235,16 @@ prop_sm_sequential reifiedApi = do
           [callEndpoint reifiedApi]
     executeSequential initialState actions
 
-newtype Foo = Foo Int
+prop_concurrent :: ReifiedApi -> Property
-  deriving (Generic, Eq, Show, Typeable)
+prop_concurrent reifiedApi =
-  deriving newtype (FromHttpApiData, ToHttpApiData)
+  let initialState = State mempty
-
+   in withTests 1000 . withRetries 10 . property $ do
-instance ToJSON Foo
+        actions <-
-
+          forAll $
-instance FromJSON Foo
+            Gen.parallel
-
+              (Range.linear 1 50)
-type FooApi =
+              (Range.linear 1 10)
-  "item" :> Get '[JSON] Foo
+              initialState
-    :<|> "itemAdd" :> Capture "one" Foo :> Capture "two" Foo :> Get '[JSON] Foo
+              [callEndpoint reifiedApi]
-    :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] ()
+        test $
-
+          executeParallel initialState actions
-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)]

test/Foo.hs

@@ -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

@@ -1,52 +1,27 @@
-{-# LANGUAGE AllowAmbiguousTypes   #-}
+{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE GADTs                 #-}
-{-# LANGUAGE KindSignatures        #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PolyKinds             #-}
-{-# LANGUAGE QuantifiedConstraints #-}
-{-# LANGUAGE RankNTypes            #-}
-{-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE TypeApplications      #-}
-{-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE TypeOperators         #-}
-{-# LANGUAGE UndecidableInstances  #-}
 
-import           Roboservant
+import Data.Proxy (Proxy (..))
-import           Servant.API
+import qualified Foo
-import           Test.Hspec
+import Hedgehog (Group (..), checkSequential)
-import qualified Roboservant.StateMachine as SM
+import qualified Roboservant as RS
+import Servant (Endpoints)
+import qualified UnsafeIO
 
-newtype Foo = Foo Int
+-- | this is pretty bad. hopefully Jacob knows a better way of doing this.
-  deriving (Show)
+--   https://twitter.com/mwotton/status/1305189249646460933
-
+assert :: String -> Bool -> IO ()
-newtype Bar = Bar String
+assert _ True = pure ()
-  deriving (Show)
+assert err False = ioError $ userError err
-
-type FooApi = "foo" :> "fle" :> "far" :> Get '[JSON] Foo
-
-type BarApi = "bar" :> ReqBody '[JSON] Foo :> Post '[JSON] Bar
-
-type Api =
-  FooApi :<|> BarApi
-
-type Foo' = ExtractRespType FooApi
-
-test :: ()
-test = foo'EqualFoo
-  where
-    foo'EqualFoo :: Foo' ~ Foo => ()
-    foo'EqualFoo = ()
-
-test' :: ()
-test' = blah
-  where
-    blah :: ExtractRespTypes Api ~ '[Foo, Bar] => ()
-    blah = ()
-
-storeOfOurApi = storeOfApi @Api
 
 main :: IO ()
-main = SM.tests  >>= print
+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)])
+  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)])
+  assert "should find with parallel check" . not
+    =<< checkSequential (Group "Unsafe" [("Parallel", RS.prop_concurrent unsafeApi)])

test/UnsafeIO.hs

@@ -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)