Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Avoid test race condition #458

Merged
merged 1 commit into from
May 22, 2020
Merged
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
29 changes: 25 additions & 4 deletions tests/Network/Socket/ByteStringSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@

module Network.Socket.ByteStringSpec (main, spec) where

import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import Data.Bits
import Data.Maybe
import Control.Monad
Expand Down Expand Up @@ -235,10 +236,17 @@ spec = do
-- This test behaves strange on AppVeyor and I don't know why so skip
-- TOS for now.
isAppVeyor <- isJust <$> lookupEnv "APPVEYOR"

-- Avoid race condition between the client sending the message and
-- the server finishing its socket configuration. Otherwise the
-- message may be received with default socket options!
serverReady <- newEmptyMVar

let server sock = do
whenSupported RecvIPv4TTL $ setSocketOption sock RecvIPv4TTL 1
whenSupported RecvIPv4PktInfo $ setSocketOption sock RecvIPv4PktInfo 1
whenSupported RecvIPv4TOS $ setSocketOption sock RecvIPv4TOS 1
putMVar serverReady ()

(_, _, cmsgs, _) <- recvMsg sock 1024 128 mempty

Expand All @@ -249,39 +257,52 @@ spec = do
((lookupCmsg CmsgIdIPv4TTL cmsgs >>= decodeCmsg) :: Maybe IPv4TTL) `shouldNotBe` Nothing
whenSupported RecvIPv4TOS $
((lookupCmsg CmsgIdIPv4TOS cmsgs >>= decodeCmsg) :: Maybe IPv4TOS) `shouldNotBe` Nothing
client sock addr = sendTo sock seg addr
client sock addr = takeMVar serverReady >> sendTo sock seg addr

seg = C.pack "This is a test message"
udpTest client server

it "receives control messages for IPv6" $ do
-- Avoid race condition between the client sending the message and
-- the server finishing its socket configuration. Otherwise the
-- message may be received with default socket options!
serverReady <- newEmptyMVar

let server sock = do
whenSupported RecvIPv6HopLimit $ setSocketOption sock RecvIPv6HopLimit 1
whenSupported RecvIPv6TClass $ setSocketOption sock RecvIPv6TClass 1
whenSupported RecvIPv6PktInfo $ setSocketOption sock RecvIPv6PktInfo 1
(_, _, cmsgs, _) <- recvMsg sock 1024 128 mempty
putMVar serverReady ()

(_, _, cmsgs, _) <- recvMsg sock 1024 128 mempty

whenSupported RecvIPv6HopLimit $
((lookupCmsg CmsgIdIPv6HopLimit cmsgs >>= decodeCmsg) :: Maybe IPv6HopLimit) `shouldNotBe` Nothing
whenSupported RecvIPv6TClass $
((lookupCmsg CmsgIdIPv6TClass cmsgs >>= decodeCmsg) :: Maybe IPv6TClass) `shouldNotBe` Nothing
whenSupported RecvIPv6PktInfo $
((lookupCmsg CmsgIdIPv6PktInfo cmsgs >>= decodeCmsg) :: Maybe IPv6PktInfo) `shouldNotBe` Nothing
client sock addr = sendTo sock seg addr
client sock addr = takeMVar serverReady >> sendTo sock seg addr

seg = C.pack "This is a test message"
udpTest6 client server

it "receives truncated control messages" $ do
-- Avoid race condition between the client sending the message and
-- the server finishing its socket configuration. Otherwise the
-- message may be received with default socket options!
serverReady <- newEmptyMVar

let server sock = do
whenSupported RecvIPv4TTL $ setSocketOption sock RecvIPv4TTL 1
whenSupported RecvIPv4TOS $ setSocketOption sock RecvIPv4TOS 1
whenSupported RecvIPv4PktInfo $ setSocketOption sock RecvIPv4PktInfo 1
putMVar serverReady ()

(_, _, _, flags) <- recvMsg sock 1024 10 mempty
flags .&. MSG_CTRUNC `shouldBe` MSG_CTRUNC

client sock addr = sendTo sock seg addr
client sock addr = takeMVar serverReady >> sendTo sock seg addr

seg = C.pack "This is a test message"
udpTest client server