3acfb21 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Fix bug in mock network interface

3acfb21Edsko de Vries14 years ago

network-transport-tcp/src/Network/Transport/TCP/Mock/Socket.hs+49−32

compare with master

unifiedsplit

@@ -28,13 +28,13 @@ module Network.Transport.TCP.Mock.Socket

28 -- * Internal API

29 , writeSocket

30 , readSocket

31+ , Message(..)

31 ) where

32 ) where

33import Data.Word (Word8)

34import Data.Word (Word8)

34import Data.Map (Map)

35import Data.Map (Map)

35import qualified Data.Map as Map

36import qualified Data.Map as Map

36import Control.Category ((>>>))

37import Control.Category ((>>>))

37−import Control.Applicative ((<$>))

38import Control.Concurrent.MVar

39import Control.Concurrent.Chan

40import System.IO.Unsafe (unsafePerformIO)

@@ -99,12 +99,16 @@ data Socket = Socket {

99data SocketState =

100 Uninit

101 | BoundSocket { socketBacklog :: Chan (Socket, SockAddr, MVar Socket) }

102− | Connected { socketPeer :: Socket,socketBuff :: Chan Word8 }

102+ | Connected { socketPeer :: Socket, socketBuff :: Chan Message }

103 | Closed

104

105+data Message =

106+ Payload Word8

107+ | CloseSocket

108+

105data AddrInfo = AddrInfo {

109data AddrInfo = AddrInfo {

106− addrFamily :: Family

110+ addrFamily :: Family

107− , addrAddress :: !SockAddr

111+ , addrAddress :: SockAddr

108 }

112 }

109

113

110data SockAddr = SockAddrInet PortNumber HostAddress

114data SockAddr = SockAddrInet PortNumber HostAddress

@@ -165,29 +169,23 @@ accept serverSock = do

165 return (socketBacklog st)

169 return (socketBacklog st)

166 _ ->

170 _ ->

167 error "accept: socket not bound"

171 error "accept: socket not bound"

168− (them, theirAddress, reply) <- readChan backlog

172+ (theirSocket, theirAddress, reply) <- readChan backlog

169− buff <- newChan

173+ ourBuff <- newChan

170 ourState <- newMVar Connected {

174 ourState <- newMVar Connected {

171− socketPeer = them

175+ socketPeer = theirSocket

172− , socketBuff = buff

176+ , socketBuff = ourBuff

173 }

177 }

174− let us = Socket {

178+ let ourSocket = Socket {

175 socketState = ourState

179 socketState = ourState

176 , socketDescription = ""

180 , socketDescription = ""

177 }

181 }

178− putMVar reply us

182+ putMVar reply ourSocket

179− return (us, theirAddress)

183+ return (ourSocket, theirAddress)

180

184

181sClose :: Socket -> IO ()

185sClose :: Socket -> IO ()

182sClose sock = do

186sClose sock = do

183− mPeer <- modifyMVar (socketState sock) $ \st -> case st of

187+ writeSocket sock CloseSocket

184− Connected {} ->

185− return (Closed, Just $ socketPeer st)

186− _ ->

187− return (Closed, Nothing)

188− case mPeer of

189− Just peer -> modifyMVar_ (socketState peer) $ const (return Closed)

188+ modifyMVar_ (socketState sock) $ const (return Closed)

190− Nothing -> return ()

191

189

192connect :: Socket -> SockAddr -> IO ()

190connect :: Socket -> SockAddr -> IO ()

193connect us serverAddr = do

191connect us serverAddr = do

@@ -223,19 +221,29 @@ shutdown = error "shutdown not implemented"

223-- Functions with no direct public counterpart --

221-- Functions with no direct public counterpart --

224--------------------------------------------------------------------------------

222--------------------------------------------------------------------------------

225

223

226−writeSocket :: Socket -> Word8 -> IO ()

224+peerBuffer :: Socket -> IO (Either String (Chan Message))

227−writeSocket sock w = do

225+peerBuffer sock = do

228− peer <- withMVar (socketState sock) $ \st -> case st of

226+ mPeer <- withMVar (socketState sock) $ \st -> case st of

229 Connected {} ->

227 Connected {} ->

230− return (socketPeer st)

228+ return (Just (socketPeer st))

231− _ ->

232− error "writeSocket: not connected"

233− theirBuff <- withMVar (socketState peer) $ \st -> case st of

234− Connected {} ->

235− return (socketBuff st)

236 _ ->

229 _ ->

230+ return Nothing

231+ case mPeer of

232+ Just peer -> withMVar (socketState peer) $ \st -> case st of

233+ Connected {} ->

234+ return (Right (socketBuff st))

235+ _ ->

237− error "writeSocket: peer socket closed"

236+ return (Left "Peer socket closed")

237+ Nothing ->

238+ return (Left "Socket closed")

239+

240+writeSocket :: Socket -> Message -> IO ()

241+writeSocket sock msg = do

242+ theirBuff <- peerBuffer sock

243+ case theirBuff of

238− writeChan theirBuff w

244+ Right buff -> writeChan buff msg

245+ Left err -> case msg of Payload _ -> error $ "writeSocket: " ++ err

246+ CloseSocket -> return ()

239

247

240readSocket :: Socket -> IO (Maybe Word8)

248readSocket :: Socket -> IO (Maybe Word8)

241readSocket sock = do

249readSocket sock = do

@@ -245,5 +253,14 @@ readSocket sock = do

245 _ ->

253 _ ->

246 return Nothing

254 return Nothing

247 case mBuff of

255 case mBuff of

248− Just buff -> Just <$> readChan buff

256+ Just buff -> do

257+ msg <- readChan buff

258+ case msg of

259+ Payload w -> return (Just w)

260+ CloseSocket -> modifyMVar (socketState sock) $ \st -> case st of

261+ Connected {} ->

262+ return (Closed, Nothing)

263+ _ ->

264+ error "readSocket: socket in unexpected state"

265+ Nothing ->

249− Nothing -> return Nothing

266+ return Nothing

network-transport-tcp/src/Network/Transport/TCP/Mock/Socket/ByteString.hs+1−1

@@ -10,7 +10,7 @@ import Control.Applicative ((<$>))

10import Network.Transport.TCP.Mock.Socket

12sendMany :: Socket -> [ByteString] -> IO ()

13−sendMany sock = mapM_ (bsMapM_ $ writeSocket sock)

13+sendMany sock = mapM_ (bsMapM_ (writeSocket sock . Payload))

14 where

15 bsMapM_ :: (Word8 -> IO ()) -> ByteString -> IO ()

16 bsMapM_ p = BSS.foldl (\io w -> io >> p w) (return ())