@@ -27,11 +27,12 @@ import qualified Data.Map as Map
2727import Control.Category ((>>>))
2828import Control.Arrow (second)
2929import Control.Applicative ((<$>))
30−import Control.Exception (throwIO)
30+import Control.Exception (Exception, throwIO, try)
3131import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread)
3232import Control.Monad (replicateM, forever, guard)
3333import Control.Monad.State.Lazy (StateT, execStateT)
34−import Control.Monad.IO.Class (liftIO)
34+import Control.Monad.IO.Class (MonadIO, liftIO)
35+import Data.Typeable (Typeable)
3536import Data.Maybe (isJust)
3637import Data.List (inits)
3738import Data.ByteString (ByteString)
@@ -48,11 +49,9 @@ import Network.Transport
4849import Network.Transport.TCP
4950 ( createTransportExposeInternals
5051 , defaultTCPParameters
51− , TransportInternals(socketBetween)
52+ , TransportInternals
5253 )
5354
54−import Network.Transport.TCP.Mock.Socket (scheduleReadAction, sClose)
55−
5655--------------------------------------------------------------------------------
5756-- Script infrastructure --
5857--------------------------------------------------------------------------------
@@ -124,7 +123,7 @@ initialRunState = RunState {
124123 }
125124
126125verify :: (Transport, TransportInternals) -> Script -> IO (Either String ())
127−verify (transport, transportInternals) script = do
126+verify (transport, _transportInternals) script = do
128127 allEvents <- newQ
129128
130129 let runScript :: Script -> StateT RunState IO ()
@@ -162,6 +161,8 @@ verify (transport, transportInternals) script = do
162161 Right () -> return ()
163162 Left err -> liftIO $ throwIO err
164163 modify (expectedEventsAt target) (snoc (ExpReceived connId payload))
164+ runCmd (BreakAfterReads _n _i _j) =
165+ expectedFailure "BreakAfterReads not implemented"
165166
166167 forward :: EndPoint -> IO ()
167168 forward endPoint = forever $ do
@@ -493,20 +494,30 @@ testScriptGen transport scriptGen =
493494 forAll scriptGen $ \script ->
494495 morallyDubiousIOProperty $ do
495496 logShow script
496− mErr <- verify transport script
497+ mErr <- try $ verify transport script
497498 return $ case mErr of
498− Right () -> result { ok = Just True }
499− Left err -> result { ok = Just False
500− , reason = '\n' : err ++ "\n"
501− }
499+ Left (ExpectedFailure str) ->
500+ result { ok = Nothing
501+ , reason = str
502+ }
503+ Right (Left err) ->
504+ result { ok = Just False
505+ , reason = '\n' : err ++ "\n"
506+ }
507+ Right (Right ()) ->
508+ result { ok = Just True }
502509
503510testScript :: (Transport, TransportInternals) -> Script -> Assertion
504511testScript transport script = do
505512 logShow script
506− mErr <- verify transport script
513+ mErr <- try $ verify transport script
507514 case mErr of
508− Left err -> assertFailure $ "Failed with script " ++ show script ++ ": " ++ err ++ "\n"
509− Right () -> return ()
515+ Left (ExpectedFailure _str) ->
516+ return ()
517+ Right (Left err) ->
518+ assertFailure $ "Failed with script " ++ show script ++ ": " ++ err ++ "\n"
519+ Right (Right ()) ->
520+ return ()
510521
511522--------------------------------------------------------------------------------
512523-- Accessors --
@@ -604,3 +615,14 @@ snoc x xs = xs ++ [x]
604615
605616groupByKey :: Ord a => [(a, b)] -> Map a [b]
606617groupByKey = Map.fromListWith (++) . map (second return)
618+
619+--------------------------------------------------------------------------------
620+-- Expected failures (can't find explicit support for this in test-framework) --
621+--------------------------------------------------------------------------------
622+
623+data ExpectedFailure = ExpectedFailure String deriving (Typeable, Show)
624+
625+instance Exception ExpectedFailure
626+
627+expectedFailure :: MonadIO m => String -> m ()
628+expectedFailure = liftIO . throwIO . ExpectedFailure