34d1834 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Prep for release 0.3.1.

34d1834Edsko de Vries14 years ago

network-transport-tcp/ChangeLog+5

compare with master

unifiedsplit

@@ -1,3 +1,8 @@

1+2012-10-19 Edsko de Vries <edsko@well-typed.com> 0.3.1

3+* Bugfix. Reconnecting between endpoints did not work under certain

4+circumstances.

12012-10-03 Edsko de Vries <edsko@well-typed.com> 0.3.0

62012-10-03 Edsko de Vries <edsko@well-typed.com> 0.3.0

3* Implement new disconnection semantics

8* Implement new disconnection semantics

network-transport-tcp/network-transport-tcp.cabal+2−1

@@ -1,5 +1,5 @@

1Name: network-transport-tcp

2−Version: 0.3.0

2+Version: 0.3.1

3Cabal-Version: >=1.8

4Build-Type: Simple

5License: BSD3

@@ -81,3 +81,4 @@ Test-Suite TestQC

81 FlexibleInstances

82 OverlappingInstances

83 OverloadedStrings

84+ DeriveDataTypeable

network-transport-tcp/src/Network/Transport/TCP.hs−1

@@ -946,7 +946,6 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do

946 -- that case.

947 if lastReceivedId < lastSentId vst

948 then do

949− putStrLn "This really shouldn't happen"

950 return (RemoteEndPointClosing resolved vst, Nothing)

949 return (RemoteEndPointClosing resolved vst, Nothing)

951 else do

950 else do

952 removeRemoteEndPoint (ourEndPoint, theirEndPoint)

951 removeRemoteEndPoint (ourEndPoint, theirEndPoint)

network-transport-tcp/tests/TestQC.hs+36−14

@@ -27,11 +27,12 @@ import qualified Data.Map as Map

27import Control.Category ((>>>))

28import Control.Arrow (second)

29import Control.Applicative ((<$>))

30−import Control.Exception (throwIO)

30+import Control.Exception (Exception, throwIO, try)

31import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread)

32import Control.Monad (replicateM, forever, guard)

33import 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)

35import Data.Maybe (isJust)

36import Data.Maybe (isJust)

36import Data.List (inits)

37import Data.List (inits)

37import Data.ByteString (ByteString)

38import Data.ByteString (ByteString)

@@ -48,11 +49,9 @@ import Network.Transport

48import Network.Transport.TCP

49import Network.Transport.TCP

49 ( createTransportExposeInternals

50 ( createTransportExposeInternals

50 , defaultTCPParameters

51 , defaultTCPParameters

51− , TransportInternals(socketBetween)

52+ , TransportInternals

52 )

53 )

54−import Network.Transport.TCP.Mock.Socket (scheduleReadAction, sClose)

55−

56--------------------------------------------------------------------------------

55--------------------------------------------------------------------------------

57-- Script infrastructure --

56-- Script infrastructure --

58--------------------------------------------------------------------------------

57--------------------------------------------------------------------------------

@@ -124,7 +123,7 @@ initialRunState = RunState {

124 }

123 }

125

124

126verify :: (Transport, TransportInternals) -> Script -> IO (Either String ())

125verify :: (Transport, TransportInternals) -> Script -> IO (Either String ())

127−verify (transport, transportInternals) script = do

126+verify (transport, _transportInternals) script = do

128 allEvents <- newQ

127 allEvents <- newQ

129

128

130 let runScript :: Script -> StateT RunState IO ()

129 let runScript :: Script -> StateT RunState IO ()

@@ -162,6 +161,8 @@ verify (transport, transportInternals) script = do

162 Right () -> return ()

161 Right () -> return ()

163 Left err -> liftIO $ throwIO err

162 Left err -> liftIO $ throwIO err

164 modify (expectedEventsAt target) (snoc (ExpReceived connId payload))

163 modify (expectedEventsAt target) (snoc (ExpReceived connId payload))

164+ runCmd (BreakAfterReads _n _i _j) =

165+ expectedFailure "BreakAfterReads not implemented"

165

166

166 forward :: EndPoint -> IO ()

167 forward :: EndPoint -> IO ()

167 forward endPoint = forever $ do

168 forward endPoint = forever $ do

@@ -493,20 +494,30 @@ testScriptGen transport scriptGen =

493 forAll scriptGen $ \script ->

494 forAll scriptGen $ \script ->

494 morallyDubiousIOProperty $ do

495 morallyDubiousIOProperty $ do

495 logShow script

496 logShow script

496− mErr <- verify transport script

497+ mErr <- try $ verify transport script

497 return $ case mErr of

498 return $ case mErr of

499+ Left (ExpectedFailure str) ->

498− Right () -> result { ok = Just True }

500+ result { ok = Nothing

501+ , reason = str

502+ }

503+ Right (Left err) ->

499− Left err -> result { ok = Just False

504+ result { ok = Just False

500− , reason = '\n' : err ++ "\n"

505+ , reason = '\n' : err ++ "\n"

501− }

506+ }

507+ Right (Right ()) ->

508+ result { ok = Just True }

502

509

503testScript :: (Transport, TransportInternals) -> Script -> Assertion

510testScript :: (Transport, TransportInternals) -> Script -> Assertion

504testScript transport script = do

511testScript transport script = do

505 logShow script

512 logShow script

506− mErr <- verify transport script

513+ mErr <- try $ verify transport script

507 case mErr of

514 case mErr of

515+ Left (ExpectedFailure _str) ->

516+ return ()

517+ Right (Left err) ->

508− Left err -> assertFailure $ "Failed with script " ++ show script ++ ": " ++ err ++ "\n"

518+ assertFailure $ "Failed with script " ++ show script ++ ": " ++ err ++ "\n"

519+ Right (Right ()) ->

509− Right () -> return ()

520+ return ()

510

521

511--------------------------------------------------------------------------------

522--------------------------------------------------------------------------------

512-- Accessors --

523-- Accessors --

@@ -604,3 +615,14 @@ snoc x xs = xs ++ [x]

604

615

605groupByKey :: Ord a => [(a, b)] -> Map a [b]

616groupByKey :: Ord a => [(a, b)] -> Map a [b]

606groupByKey = Map.fromListWith (++) . map (second return)

617groupByKey = 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