Skip to content

Instantly share code, notes, and snippets.

@magthe magthe/test-01.hs
Created Jun 23, 2019

Embed
What would you like to do?
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
import Control.Monad (unless, void)
import Control.Monad.IO.Class
import Data.Aeson
import qualified Data.Map as M
import Data.Maybe (isJust)
import Data.Text (Text)
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Network.HTTP.Client
import Network.HTTP.Types
import System.Exit (exitFailure)
import Types (User(..))
newtype State (v :: * -> *)= State (M.Map Int Text)
deriving (Eq, Show)
initialState :: State v
initialState = State M.empty
newtype AddUser (v :: * -> *) = AddUser Text
deriving (Eq, Show)
instance HTraversable AddUser where
htraverse _ (AddUser n) = AddUser <$> pure n
addUser :: (MonadGen n, MonadIO m) => Command n m State
addUser = Command gen exec [ Update u
, Ensure e
]
where
gen _ = Just $ AddUser <$> Gen.text (Range.linear 0 42) Gen.alpha
exec (AddUser n) = liftIO $ do
mgr <- newManager defaultManagerSettings
addReq <- parseRequest "POST http://localhost:3000/users"
let addReq' = addReq { requestBody = RequestBodyLBS (encode $ User 0 n)}
addResp <- httpLbs addReq' mgr
let user = decode (responseBody addResp) :: Maybe User
return (responseStatus addResp, user)
u (State m) (AddUser n) _o = State $ M.insert k n m
where
k = case M.keys m of
[] -> 0
ks -> succ $ foldl max 0 ks
e _ _ (AddUser n) (r, ui) = do
r === status201
assert $ isJust ui
(userName <$> ui) === Just n
newtype DeleteUser (v :: * -> *) = DeleteUser Int
deriving (Eq, Show)
instance HTraversable DeleteUser where
htraverse _ (DeleteUser i) = DeleteUser <$> pure i
deleteUser :: (MonadGen n, MonadIO m) => Command n m State
deleteUser = Command gen exec [ Update u
, Require r
, Ensure e
]
where
gen (State m) = case M.keys m of
[] -> Nothing
ks -> Just $ DeleteUser <$> Gen.element ks
exec (DeleteUser i) = liftIO $ do
mgr <- newManager defaultManagerSettings
delReq <- parseRequest $ "DELETE http://localhost:3000/users/" ++ show i
delResp <- httpNoBody delReq mgr
return $ responseStatus delResp
u (State m) (DeleteUser i) _ = State $ M.delete i m
r (State m) (DeleteUser i) = i `elem` M.keys m
e _ _ (DeleteUser _) r = r === status200
newtype GetUser (v :: * -> *) = GetUser Int
deriving (Eq, Show)
instance HTraversable GetUser where
htraverse _ (GetUser i) = GetUser <$> pure i
getUser :: (MonadGen n, MonadIO m) => Command n m State
getUser = Command gen exec [ Require r
, Ensure e
]
where
gen (State m) = case M.keys m of
[] -> Nothing
ks -> Just $ GetUser <$> Gen.element ks
exec (GetUser i) = liftIO $ do
mgr <- newManager defaultManagerSettings
getReq <- parseRequest $ "GET http://localhost:3000/users/" ++ show i
getResp <- httpLbs getReq mgr
let us = decode $ responseBody getResp :: Maybe [User]
return (status200 == responseStatus getResp, us)
r (State m) (GetUser i) = i `elem` M.keys m
e _ _ (GetUser _) (r, us) = do
r === True
assert $ isJust us
(length <$> us) === Just 1
resetWS :: MonadIO m => m ()
resetWS = liftIO $ do
mgr <- newManager defaultManagerSettings
resetReq <- parseRequest "POST http://localhost:3000/reset"
void $ httpNoBody resetReq mgr
prop_seq :: Property
prop_seq = property $ do
actions <- forAll $ Gen.sequential (Range.linear 1 10) initialState [addUser, deleteUser, getUser]
resetWS
executeSequential initialState actions
main :: IO ()
main = do
res <- checkSequential $ Group "Main" [("sequential", prop_seq)]
unless res exitFailure
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.