@@ -0,0 +1,74 @@
1+import Test.Framework (defaultMain, testGroup)
2+import Test.Framework.Providers.QuickCheck2 (testProperty)
3+import Test.QuickCheck (Gen, choose, suchThatMaybe, forAll)
4+import Test.QuickCheck.Property (morallyDubiousIOProperty)
5+import Data.Map (Map)
6+import qualified Data.Map as Map
7+
8+import Network.Transport
9+import Network.Transport.TCP (createTransport, defaultTCPParameters)
10+
11+data ScriptCmd =
12+ Connect Int Int Reliability ConnectHints
13+ | Close Int
14+
15+instance Show ScriptCmd where
16+ show (Connect fr to _ _) = "Connect " ++ show fr ++ " " ++ show to
17+ show (Close i) = "Close " ++ show i
18+
19+type Script = [ScriptCmd]
20+
21+connectCloseScript :: Int -> Gen Script
22+connectCloseScript numEndPoints = go Map.empty
23+ where
24+ go :: Map Int Bool -> Gen Script
25+ go conns = do
26+ next <- choose (0, 2) :: Gen Int
27+ case next of
28+ 0 -> do
29+ fr <- choose (0, numEndPoints - 1)
30+ to <- choose (0, numEndPoints - 1)
31+ cmds <- go (Map.insert (Map.size conns) True conns)
32+ return (Connect fr to ReliableOrdered defaultConnectHints : cmds)
33+ 1 -> do
34+ mConn <- suchThatMaybe (choose (0, Map.size conns - 1)) (conns Map.!)
35+ case mConn of
36+ Nothing -> go conns
37+ Just conn -> do
38+ cmds <- go (Map.insert conn False conns)
39+ return (Close conn : cmds)
40+ _ ->
41+ return []
42+
43+execScript :: [EndPoint] -> Script -> IO [Event]
44+execScript endPoints = go [] []
45+ where
46+ go :: [Event] -> [(Connection, Int)] -> Script -> IO [Event]
47+ go acc _ [] = return (reverse acc)
48+ go acc conns (Connect fr to rel hints : cmds) = do
49+ Right conn <- connect (endPoints !! fr) (address (endPoints !! to)) rel hints
50+ ev <- receive (endPoints !! to)
51+ go (ev : acc) (conns ++ [(conn, to)]) cmds
52+ go acc conns (Close connIdx : cmds) = do
53+ let (conn, connDst) = conns !! connIdx
54+ close conn
55+ ev <- receive (endPoints !! connDst)
56+ go (ev : acc) conns cmds
57+
58+prop_connect_close transport = forAll (connectCloseScript 2) $ \script ->
59+ morallyDubiousIOProperty $ do
60+ Right endPointA <- newEndPoint transport
61+ Right endPointB <- newEndPoint transport
62+ evs <- execScript [endPointA, endPointB] script
63+ return (evs == [])
64+
65+tests transport = [
66+ testGroup "Unidirectional" [
67+ testProperty "ConnectClose" (prop_connect_close transport)
68+ ]
69+ ]
70+
71+main :: IO ()
72+main = do
73+ Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
74+ defaultMain (tests transport)