git.iko.soy/distributed-process
on master help sign in
Remove trailing whitespace
commit883830fff4746d51571d09cd944f829f7e296a87 authorEdsko de Vries <edsko@well-typed.com> dateMon 3 Dec 2012, 14:38 (14 years ago) parent3e51084
81 files changed+2470−2470
compare with master
unifiedsplit
azure-service-api/src/Network/Azure/ServiceManagement.hs+35−35 distributed-process-azure/demos/Echo.hs+8−8 distributed-process-azure/demos/Fib.hs+8−8 distributed-process-azure/demos/Ping.hs+21−21 distributed-process-azure/src/Control/Distributed/Process/Backend/Azure.hs+174−174 distributed-process-demos/src/Common/PrimeFactors.hs+2−2 distributed-process-demos/src/MapReduce/CountWords.hs+5−5 distributed-process-demos/src/MapReduce/KMeans.hs+30−30 distributed-process-demos/src/MapReduce/MapReduce.hs+6−6 distributed-process-demos/src/MapReduce/MonoDistrMapReduce.hs+8−8 distributed-process-demos/src/MapReduce/PolyDistrMapReduce.hs+23−23 distributed-process-demos/src/MapReduce/SimpleLocalnet.hs+15−15 distributed-process-demos/src/MasterSlave/Azure.hs+7−7 distributed-process-demos/src/MasterSlave/MasterSlave.hs+4−4 distributed-process-demos/src/MasterSlave/SimpleLocalnet.hs+4−4 distributed-process-demos/src/TypedWorkPushing/Azure.hs+7−7 distributed-process-demos/src/TypedWorkPushing/SimpleLocalnet.hs+4−4 distributed-process-demos/src/TypedWorkPushing/TypedWorkPushing.hs+7−7 distributed-process-demos/src/WorkPushing/Azure.hs+7−7 distributed-process-demos/src/WorkPushing/SimpleLocalnet.hs+4−4 distributed-process-demos/src/WorkPushing/WorkPushing.hs+4−4 distributed-process-demos/src/WorkStealing/SimpleLocalnet.hs+4−4 distributed-process-demos/src/WorkStealing/WorkStealing.hs+8−8 distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hs+52−52 distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet/Internal/Multicast.hs+19−19 distributed-process-simplelocalnet/tests/TestSimpleLocalnet.hs+3−3 distributed-process-simplelocalnet/tests/runTestSimpleLocalnet.hs+4−4 distributed-process/benchmarks/Channels.hs+4−4 distributed-process/benchmarks/Latency.hs+4−4 distributed-process/benchmarks/Spawns.hs+4−4 distributed-process/benchmarks/Throughput.hs+7−7 distributed-process/benchmarks/remote/Latency.hs+3−3 distributed-process/benchmarks/remote/Throughput.hs+3−3 distributed-process/src/Control/Distributed/Process.hs+42−42 distributed-process/src/Control/Distributed/Process/Closure.hs+39−39 distributed-process/src/Control/Distributed/Process/Internal/CQueue.hs+20−20 distributed-process/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs+41−41 distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs+56−56 distributed-process/src/Control/Distributed/Process/Internal/Messaging.hs+42−42 distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+93−93 distributed-process/src/Control/Distributed/Process/Internal/StrictContainerAccessors.hs+1−1 distributed-process/src/Control/Distributed/Process/Internal/StrictList.hs+4−4 distributed-process/src/Control/Distributed/Process/Internal/StrictMVar.hs+4−4 distributed-process/src/Control/Distributed/Process/Internal/Types.hs+69−69 distributed-process/src/Control/Distributed/Process/Internal/WeakTQueue.hs+2−2 distributed-process/src/Control/Distributed/Process/Node.hs+122−122 distributed-process/src/Control/Distributed/Process/Serializable.hs+8−8 distributed-process/tests/TestCH.hs+104−104 distributed-process/tests/TestClosure.hs+66−66 distributed-static/src/Control/Distributed/Static.hs+64−64 doc/tutorial/tutorial-client.hs+3−3 doc/tutorial/tutorial-server.hs+10−10 network-transport-composed/src/Network/Transport/Composed.hs+43−43 network-transport-inmemory/src/Network/Transport/Chan.hs+38−38 network-transport-inmemory/tests/TestInMemory.hs+1−1 network-transport-tcp/benchmarks/JustPingCacheHeader.hs+15−15 network-transport-tcp/benchmarks/JustPingHaskell.hs+9−9 network-transport-tcp/benchmarks/JustPingOneRecv.hs+14−14 network-transport-tcp/benchmarks/JustPingThroughChan.hs+15−15 network-transport-tcp/benchmarks/JustPingThroughMVar.hs+15−15 network-transport-tcp/benchmarks/JustPingTransport.hs+14−14 network-transport-tcp/benchmarks/JustPingTwoSocketPairs.hs+14−14 network-transport-tcp/benchmarks/JustPingWithHeader.hs+15−15 network-transport-tcp/src/Network/Transport/TCP.hs+368−368 network-transport-tcp/src/Network/Transport/TCP/Internal.hs+22−22 network-transport-tcp/src/Network/Transport/TCP/Mock/Socket.hs+47−47 network-transport-tcp/tests/TestQC.hs+120−120 network-transport-tcp/tests/TestTCP.hs+98−98 network-transport-tests/src/Network/Transport/Tests.hs+113−113 network-transport-tests/src/Network/Transport/Tests/Auxiliary.hs+14−14 network-transport-tests/src/Network/Transport/Tests/Multicast.hs+15−15 network-transport-tests/src/Network/Transport/Tests/Traced.hs+31−31 network-transport/src/Network/Transport.hs+36−36 network-transport/src/Network/Transport/Internal.hs+26−26 network-transport/src/Network/Transport/Util.hs+5−5 network-transport/tests/chat/ChatClient.hs+13−13 network-transport/tests/chat/ChatServer.hs+1−1 network-transport/tests/sumeuler/SumEulerMaster.hs+4−4 network-transport/tests/sumeuler/SumEulerWorker.hs+4−4 rank1dynamic/src/Data/Rank1Dynamic.hs+21−21 rank1dynamic/src/Data/Rank1Typeable.hs+51−51
azure-service-api/src/Network/Azure/ServiceManagement.hs+35−35
@@ -1,5 +1,5 @@
11{-# LANGUAGE Arrows #-}
2−module Network.Azure.ServiceManagement
2+module Network.Azure.ServiceManagement
33 ( -- * Data types
44 CloudService
55 , cloudServiceName
@@ -13,12 +13,12 @@ module Network.Azure.ServiceManagement
1313 , endpointPort
1414 , endpointVip
1515 -- * Pure functions
16− , vmSshEndpoint
16+ , vmSshEndpoint
1717 -- * Setup
1818 , AzureSetup(..)
1919 , azureSetup
2020 -- * High-level API
21− , cloudServices
21+ , cloudServices
2222 ) where
2323
2424import Prelude hiding (id, (.))
@@ -40,7 +40,7 @@ import qualified Crypto.Types.PubKey.RSA as RSA (PrivateKey(..))
4040import Control.Monad.Trans.Resource (ResourceT)
4141import Control.Monad.IO.Class (liftIO)
4242import Control.Arrow.ArrowList (listA, arr2A)
43−import Text.PrettyPrint
43+import Text.PrettyPrint
4444 ( Doc
4545 , text
4646 , (<+>)
@@ -49,7 +49,7 @@ import Text.PrettyPrint
4949 , hang
5050 , doubleQuotes
5151 )
52−import Network.HTTP.Conduit
52+import Network.HTTP.Conduit
5353 ( parseUrl
5454 , clientCertificates
5555 , requestHeaders
@@ -59,7 +59,7 @@ import Network.HTTP.Conduit
5959 , Manager
6060 )
6161import Data.CaseInsensitive as CI (mk)
62−import Text.XML.HXT.Core
62+import Text.XML.HXT.Core
6363 ( runX
6464 , readString
6565 , withValidate
@@ -75,25 +75,25 @@ import Text.XML.HXT.XPath (getXPathTrees)
7575-- Data types --
7676--------------------------------------------------------------------------------
7777
78−data HostedService = HostedService {
79− hostedServiceName :: String
78+data HostedService = HostedService {
79+ hostedServiceName :: String
8080 }
8181
8282-- | A cloud service is a bunch of virtual machines that are part of the same
83−-- network (i.e., can talk to each other directly using standard TCP
83+-- network (i.e., can talk to each other directly using standard TCP
8484-- connections).
8585data CloudService = CloudService {
8686 -- | Name of the service.
87− cloudServiceName :: String
87+ cloudServiceName :: String
8888 -- | Virtual machines that are part of this cloud service.
8989 , cloudServiceVMs :: [VirtualMachine]
9090 }
9191
9292-- | Virtual machine
93−data VirtualMachine = VirtualMachine {
93+data VirtualMachine = VirtualMachine {
9494 -- | Name of the virtual machine.
9595 vmName :: String
96− -- | The /internal/ IP address of the virtual machine (that is, the
96+ -- | The /internal/ IP address of the virtual machine (that is, the
9797 -- IP address on the Cloud Service). For the globally accessible IP
9898 -- address see 'vmInputEndpoints'.
9999 , vmIpAddress :: String
@@ -105,12 +105,12 @@ data VirtualMachine = VirtualMachine {
105105data Endpoint = Endpoint {
106106 -- | Name of the endpoint (typical example: @SSH@)
107107 endpointName :: String
108− -- | Port number (typical examples are 22 or high numbered ports such as 53749)
109− , endpointPort :: String
108+ -- | Port number (typical examples are 22 or high numbered ports such as 53749)
109+ , endpointPort :: String
110110 -- | Virtual IP address (that is, globally accessible IP address).
111111 --
112112 -- This corresponds to the IP address associated with the Cloud Service
113− -- (i.e., that would be returned by a DNS lookup for @name.cloudapp.net@,
113+ -- (i.e., that would be returned by a DNS lookup for @name.cloudapp.net@,
114114 -- where @name@ is the name of the Cloud Service).
115115 , endpointVip :: String
116116 }
@@ -119,7 +119,7 @@ data Endpoint = Endpoint {
119119-- Pretty-printing --
120120--------------------------------------------------------------------------------
121121
122−instance Show HostedService where
122+instance Show HostedService where
123123 show = show . ppHostedService
124124
125125instance Show CloudService where
@@ -136,7 +136,7 @@ ppHostedService = text . hostedServiceName
136136
137137ppCloudService :: CloudService -> Doc
138138ppCloudService cs =
139− (text "Cloud Service" <+> (doubleQuotes . text . cloudServiceName $ cs))
139+ (text "Cloud Service" <+> (doubleQuotes . text . cloudServiceName $ cs))
140140 `hang2`
141141 ( text "VIRTUAL MACHINES"
142142 `hang2`
@@ -144,7 +144,7 @@ ppCloudService cs =
144144 )
145145
146146ppVirtualMachine :: VirtualMachine -> Doc
147−ppVirtualMachine vm =
147+ppVirtualMachine vm =
148148 (text "Virtual Machine" <+> (doubleQuotes . text . vmName $ vm))
149149 `hang2`
150150 ( text "IP" <+> text (vmIpAddress vm)
@@ -155,7 +155,7 @@ ppVirtualMachine vm =
155155 )
156156
157157ppEndpoint :: Endpoint -> Doc
158−ppEndpoint ep =
158+ppEndpoint ep =
159159 (text "Input endpoint" <+> (doubleQuotes . text . endpointName $ ep))
160160 `hang2`
161161 ( text "Port" <+> text (endpointPort ep)
@@ -171,7 +171,7 @@ hang2 d1 = hang d1 2
171171
172172-- | Find the endpoint with name @SSH@.
173173vmSshEndpoint :: VirtualMachine -> Maybe Endpoint
174−vmSshEndpoint vm = listToMaybe
174+vmSshEndpoint vm = listToMaybe
175175 [ ep
176176 | ep <- vmInputEndpoints vm
177177 , endpointName ep == "SSH"
@@ -181,7 +181,7 @@ vmSshEndpoint vm = listToMaybe
181181-- Setup --
182182--------------------------------------------------------------------------------
183183
184−-- | Azure setup
184+-- | Azure setup
185185--
186186-- The documentation of "distributed-process-azure" explains in detail how
187187-- to obtain the SSL client certificate and the private key for your Azure
@@ -201,7 +201,7 @@ data AzureSetup = AzureSetup
201201
202202-- TODO: it's dubious to be transferring private keys, but we transfer them
203203-- over a secure connection and it can be argued that it's safer than actually
204−-- storing the private key on each remote server
204+-- storing the private key on each remote server
205205
206206encodePrivateKey :: PrivateKey -> ByteString
207207encodePrivateKey (PrivRSA pkey) = runPut $ do
@@ -215,10 +215,10 @@ encodePrivateKey (PrivRSA pkey) = runPut $ do
215215 put (RSA.private_qinv pkey)
216216
217217decodePrivateKey :: ByteString -> PrivateKey
218−decodePrivateKey = PrivRSA . runGet getPrivateKey
218+decodePrivateKey = PrivRSA . runGet getPrivateKey
219219 where
220220 getPrivateKey :: Get RSA.PrivateKey
221− getPrivateKey =
221+ getPrivateKey =
222222 RSA.PrivateKey <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get
223223
224224instance Binary AzureSetup where
@@ -226,7 +226,7 @@ instance Binary AzureSetup where
226226 put sid
227227 put (encodeCertificate cert)
228228 put (encodePrivateKey pkey)
229− put url
229+ put url
230230 get = do
231231 sid <- get
232232 Right cert <- decodeCertificate <$> get
@@ -253,13 +253,13 @@ azureSetup sid certPath pkeyPath = do
253253-- High-level API --
254254--------------------------------------------------------------------------------
255255
256−-- | Find available cloud services
256+-- | Find available cloud services
257257cloudServices :: AzureSetup -> IO [CloudService]
258258cloudServices setup = azureExecute setup $ \exec -> do
259259 services <- exec hostedServicesRequest
260260 forM services $ \service -> do
261261 roles <- exec AzureRequest {
262− relativeUrl = "/services/hostedservices/" ++ hostedServiceName service
262+ relativeUrl = "/services/hostedservices/" ++ hostedServiceName service
263263 ++ "?embed-detail=true"
264264 , apiVersion = "2012-03-01"
265265 , parser = proc xml -> do
@@ -273,15 +273,15 @@ cloudServices setup = azureExecute setup $ \exec -> do
273273 return $ CloudService (hostedServiceName service) roles
274274
275275hostedServicesRequest :: AzureRequest HostedService
276−hostedServicesRequest = AzureRequest
276+hostedServicesRequest = AzureRequest
277277 { relativeUrl = "/services/hostedservices"
278278 , apiVersion = "2012-03-01"
279− , parser = arr HostedService
280− . getText
279+ , parser = arr HostedService
280+ . getText
281281 . getXPathTrees "//ServiceName/text()"
282282 }
283283
284−parseEndpoint :: ArrowXml t => t XmlTree Endpoint
284+parseEndpoint :: ArrowXml t => t XmlTree Endpoint
285285parseEndpoint = proc endpoint -> do
286286 name <- getText . getXPathTrees "//Name/text()" -< endpoint
287287 port <- getText . getXPathTrees "//Port/text()" -< endpoint
@@ -299,12 +299,12 @@ data AzureRequest c = AzureRequest {
299299 }
300300
301301azureExecute :: AzureSetup -> ((forall b. AzureRequest b -> ResourceT IO [b]) -> ResourceT IO a) -> IO a
302−azureExecute setup f = withManager (\manager -> f (go manager))
302+azureExecute setup f = withManager (\manager -> f (go manager))
303303 where
304304 go :: Manager -> forall b. AzureRequest b -> ResourceT IO [b]
305305 go manager request = do
306− req <- parseUrl $ baseUrl setup
307− ++ "/" ++ subscriptionId setup
306+ req <- parseUrl $ baseUrl setup
307+ ++ "/" ++ subscriptionId setup
308308 ++ "/" ++ relativeUrl request
309309 let req' = req {
310310 clientCertificates = [ (certificate setup, Just $ privateKey setup) ]
@@ -312,7 +312,7 @@ azureExecute setup f = withManager (\manager -> f (go manager))
312312 , (CI.mk $ BSC.pack "content-type", BSC.pack "application/xml")
313313 ]
314314 }
315− Response _ _ _ lbs <- httpLbs req' manager
315+ Response _ _ _ lbs <- httpLbs req' manager
316316 liftIO . runX $ proc _ -> do
317317 xml <- readString [withValidate no] (BSLC.unpack lbs) -< ()
318318 -- arrIO putStrLn . writeDocumentToString [withIndent yes] -< xml
distributed-process-azure/demos/Echo.hs+8−8
@@ -5,12 +5,12 @@ import System.Environment (getArgs)
55import Control.Monad (unless, forever)
66import Control.Monad.IO.Class (liftIO)
77import Control.Distributed.Process (Process, expect)
8−import Control.Distributed.Process.Closure (remotable, mkClosure)
9−import Control.Distributed.Process.Backend.Azure
8+import Control.Distributed.Process.Closure (remotable, mkClosure)
9+import Control.Distributed.Process.Backend.Azure
1010
1111echoRemote :: () -> Backend -> Process ()
1212echoRemote () _backend = forever $ do
13− str <- expect
13+ str <- expect
1414 remoteSend (str :: String)
1515
1616remotable ['echoRemote]
@@ -29,21 +29,21 @@ main :: IO ()
2929main = do
3030 args <- getArgs
3131 case args of
32− "onvm":args' ->
32+ "onvm":args' ->
3333 -- Pass execution to 'onVmMain' if we are running on the VM
3434 -- ('callOnVM' will provide the right arguments)
3535 onVmMain __remoteTable args'
3636
3737 sid:x509:pkey:user:cloudService:virtualMachine:port:_ -> do
3838 -- Initialize the Azure backend
39− params <- defaultAzureParameters sid x509 pkey
39+ params <- defaultAzureParameters sid x509 pkey
4040 let params' = params { azureSshUserName = user }
4141 backend <- initializeBackend params' cloudService
4242
4343 -- Find the specified virtual machine
4444 Just vm <- findNamedVM backend virtualMachine
45−
45+
4646 -- Run the echo client proper
4747 callOnVM backend vm port $
48− ProcessPair ($(mkClosure 'echoRemote) ())
49− echoLocal
48+ ProcessPair ($(mkClosure 'echoRemote) ())
49+ echoLocal
distributed-process-azure/demos/Fib.hs+8−8
@@ -13,8 +13,8 @@ import Control.Distributed.Process
1313 , receiveChan
1414 , spawnLocal
1515 )
16−import Control.Distributed.Process.Backend.Azure
17−import Control.Distributed.Process.Closure
16+import Control.Distributed.Process.Backend.Azure
17+import Control.Distributed.Process.Closure
1818 ( remotable
1919 , remotableDecl
2020 , mkClosure
@@ -25,7 +25,7 @@ randomElement xs = do
2525 ix <- randomIO
2626 return (xs !! (ix `mod` length xs))
2727
28−remotableDecl [
28+remotableDecl [
2929 [d| dfib :: ([NodeId], SendPort Integer, Integer) -> Process () ;
3030 dfib (_, reply, 0) = sendChan reply 0
3131 dfib (_, reply, 1) = sendChan reply 1
@@ -54,7 +54,7 @@ remotable ['remoteFib]
5454printResult :: LocalProcess ()
5555printResult = do
5656 result <- localExpect :: LocalProcess Integer
57− liftIO $ print result
57+ liftIO $ print result
5858
5959main :: IO ()
6060main = do
@@ -62,13 +62,13 @@ main = do
6262 case args of
6363 "onvm":args' -> onVmMain (__remoteTable . __remoteTableDecl) args'
6464 [sid, x509, pkey, user, cloudService, n] -> do
65− params <- defaultAzureParameters sid x509 pkey
65+ params <- defaultAzureParameters sid x509 pkey
6666 let params' = params { azureSshUserName = user }
6767 backend <- initializeBackend params' cloudService
6868 vms <- findVMs backend
6969 nids <- forM vms $ \vm -> spawnNodeOnVM backend vm "8080"
70− callOnVM backend (head vms) "8081" $
71− ProcessPair ($(mkClosure 'remoteFib) (nids, read n :: Integer))
72− printResult
70+ callOnVM backend (head vms) "8081" $
71+ ProcessPair ($(mkClosure 'remoteFib) (nids, read n :: Integer))
72+ printResult
7373 _ ->
7474 error "Invalid command line arguments"
distributed-process-azure/demos/Ping.hs+21−21
@@ -5,7 +5,7 @@ import Data.Binary (encode, decode)
55import Control.Monad (forever)
66import Control.Monad.IO.Class (liftIO)
77import Control.Exception (try, IOException)
8−import Control.Distributed.Process
8+import Control.Distributed.Process
99 ( Process
1010 , getSelfPid
1111 , expect
@@ -15,30 +15,30 @@ import Control.Distributed.Process
1515 , match
1616 , ProcessMonitorNotification(..)
1717 )
18−import Control.Distributed.Process.Closure (remotable, mkClosure)
19−import Control.Distributed.Process.Backend.Azure
20−import qualified Data.ByteString.Lazy as BSL (readFile, writeFile)
18+import Control.Distributed.Process.Closure (remotable, mkClosure)
19+import Control.Distributed.Process.Backend.Azure
20+import qualified Data.ByteString.Lazy as BSL (readFile, writeFile)
2121
2222pingServer :: () -> Backend -> Process ()
2323pingServer () _backend = do
2424 us <- getSelfPid
2525 liftIO $ BSL.writeFile "pingServer.pid" (encode us)
26− forever $ do
26+ forever $ do
2727 them <- expect
2828 send them ()
2929
30−pingClientRemote :: () -> Backend -> Process ()
30+pingClientRemote :: () -> Backend -> Process ()
3131pingClientRemote () _backend = do
3232 mPingServerEnc <- liftIO $ try (BSL.readFile "pingServer.pid")
3333 case mPingServerEnc of
34− Left err ->
34+ Left err ->
3535 remoteSend $ "Ping server not found: " ++ show (err :: IOException)
36− Right pingServerEnc -> do
36+ Right pingServerEnc -> do
3737 let pingServerPid = decode pingServerEnc
3838 pid <- getSelfPid
39− _ref <- monitor pingServerPid
39+ _ref <- monitor pingServerPid
4040 send pingServerPid pid
41− gotReply <- receiveWait
41+ gotReply <- receiveWait
4242 [ match (\() -> return True)
4343 , match (\(ProcessMonitorNotification {}) -> return False)
4444 ]
@@ -49,26 +49,26 @@ pingClientRemote () _backend = do
4949remotable ['pingClientRemote, 'pingServer]
5050
5151pingClientLocal :: LocalProcess ()
52−pingClientLocal = localExpect >>= liftIO . putStrLn
52+pingClientLocal = localExpect >>= liftIO . putStrLn
5353
5454main :: IO ()
5555main = do
5656 args <- getArgs
5757 case args of
58− "onvm":args' ->
58+ "onvm":args' ->
5959 -- Pass execution to 'onVmMain' if we are running on the VM
6060 onVmMain __remoteTable args'
6161
6262 "list":sid:x509:pkey:_ -> do
6363 -- List all available cloud services
6464 -- (useful, but not strictly necessary for the example)
65− params <- defaultAzureParameters sid x509 pkey
65+ params <- defaultAzureParameters sid x509 pkey
6666 css <- cloudServices (azureSetup params)
6767 mapM_ print css
6868
6969 cmd:sid:x509:pkey:user:cloudService:virtualMachine:port:_ -> do
70− -- Initialize the backend and find the right VM
71− params <- defaultAzureParameters sid x509 pkey
70+ -- Initialize the backend and find the right VM
71+ params <- defaultAzureParameters sid x509 pkey
7272 let params' = params { azureSshUserName = user }
7373 backend <- initializeBackend params' cloudService
7474 Just vm <- findNamedVM backend virtualMachine
@@ -76,10 +76,10 @@ main = do
7676 -- The same binary can behave as the client or the server,
7777 -- depending on the command line arguments
7878 case cmd of
79− "server" -> do
80− pid <- spawnOnVM backend vm port ($(mkClosure 'pingServer) ())
79+ "server" -> do
80+ pid <- spawnOnVM backend vm port ($(mkClosure 'pingServer) ())
8181 putStrLn $ "Ping server started at " ++ show pid
82− "client" ->
83− callOnVM backend vm port $
84− ProcessPair ($(mkClosure 'pingClientRemote) ())
85− pingClientLocal
82+ "client" ->
83+ callOnVM backend vm port $
84+ ProcessPair ($(mkClosure 'pingClientRemote) ())
85+ pingClientLocal
distributed-process-azure/src/Control/Distributed/Process/Backend/Azure.hs+174−174
@@ -3,17 +3,17 @@
33-- Azure cloud service can talk to each other directly using standard Cloud
44-- Haskell primitives (using TCP/IP under the hood); to talk to the remote
55-- machines from your local machine you can use the primitives provided in this
6−-- module (which use ssh under the hood). It looks something like
6+-- module (which use ssh under the hood). It looks something like
77--
88-- > _ _
99-- > ( ` )_
1010-- > ( ) `) Azure cloud service
1111-- > (_ (_ . _) _)
12−-- >
12+-- >
1313-- > |
1414-- > | ssh connection
1515-- > |
16−-- >
16+-- >
1717-- > +---+
1818-- > | | Local machine
1919-- > +---+
@@ -39,27 +39,27 @@
3939-- subsequent virtual machines to the first virtual machine, thereby implicitly
4040-- setting up a Cloud Service.
4141--
42−-- We have only tested Cloud Haskell with Linux based virtual machines;
42+-- We have only tested Cloud Haskell with Linux based virtual machines;
4343-- Windows based virtual machines /might/ work, but you'll be entering
4444-- uncharted territory. Cloud Haskell assumes that all nodes run the same
45−-- binary code; hence, you must use the same OS on all virtual machines,
45+-- binary code; hence, you must use the same OS on all virtual machines,
4646-- /as well as on your local machine/. We use Ubuntu Server 12.04 LTS for our
47−-- tests (running on VirtualBox on our local machine).
47+-- tests (running on VirtualBox on our local machine).
4848--
4949-- When you set up your virtual machine, you can pick an arbitrary virtual
5050-- machine name; these names are for your own use only and do not need to be
5151-- globally unique. Set a username and password; you should use the same
5252-- username on all virtual machines. You should also upload an SSH key for
53−-- authentication (see
53+-- authentication (see
5454-- /Converting OpenSSH keys for use on Windows Azure Linux VM's/,
5555-- <http://utlemming.azurewebsites.net/?p=91>, for
5656-- information on how to convert a standard Linux @id_rsa.pub@ public key to
5757-- X509 format suitable for Azure). For the first VM you create select
5858-- /Standalone Virtual Machine/, and pick an appropriate DNS name. The DNS name
5959-- /does/ have to be globally unique, and will also be the name of the Cloud
60−-- Service. For subsequent virtual machines, select
60+-- Service. For subsequent virtual machines, select
6161-- /Connect to Existing Virtual Machine/ instead and then select the first VM
62−-- you created.
62+-- you created.
6363--
6464-- Once your virtual machines have been set up, you have to make sure that the
6565-- user you created when you created the VM can ssh from any virtual machine to
@@ -91,24 +91,24 @@
9191--
9292-- And to extract the private key:
9393--
94−-- > openssl pkcs12 -in credentials.pfx -nocerts -nodes | openssl rsa -out credentials.private
94+-- > openssl pkcs12 -in credentials.pfx -nocerts -nodes | openssl rsa -out credentials.private
9595--
9696-- (@openssl pkcs12@ outputs the private key in PKCS#8 format (BEGIN PRIVATE
9797-- KEY), but we need it in PKCS#1 format (BEGIN RSA PRIVATE KEY).
98−--
98+--
9999-- [Testing the Setup]
100100--
101101-- Build and install the @distributed-process-azure@ package, making sure to
102102-- pass the @build-demos@ flag to Cabal.
103−--
103+--
104104-- > cabal-dev install distributed-process-azure -f build-demos
105105--
106106-- We can the @cloud-haskell-azure-ping@ demo to test our setup:
107−--
107+--
108108-- > cloud-haskell-azure-ping list \
109109-- > <<your subscription ID>> \
110110-- > /path/to/credentials.x509 \
111−-- > /path/to/credentials.private
111+-- > /path/to/credentials.private
112112--
113113-- (you can find your subscription ID in the @.publishsettings@ file from the previous step).
114114-- If everything went well, this will output something like
@@ -157,7 +157,7 @@
157157-- @RemoteProcess ()@, starts the executable on the remote node, sets up a new
158158-- Cloud Haskell node, and then runs the specified process. The Cloud Haskell
159159-- node will be shut down when the given process terminates. 'RemoteProcess' is
160−-- defined as
160+-- defined as
161161--
162162-- > type RemoteProcess a = Closure (Backend -> Process a)
163163--
@@ -173,7 +173,7 @@
173173-- because the remote process and the local process can communicate through a
174174-- set of primitives provided in this module ('localSend', 'localExpect', and
175175-- 'remoteSend' -- there is no 'remoteExpect'; instead the remote process can
176−-- use the standard Cloud Haskell 'expect' primitive).
176+-- use the standard Cloud Haskell 'expect' primitive).
177177--
178178-- [First Example: Echo]
179179--
@@ -181,45 +181,45 @@
181181-- starts a new Cloud Haskell node on the specified remote virtual machine. It
182182-- then repeatedly waits for input from the user on the local machine, sends
183183-- this to the remote virtual machine which will echo it back, and wait for and
184−-- show the echo.
184+-- show the echo.
185185--
186186-- Before you can try it you will first need to copy the executable (for
187187-- example, using scp, although the Azure backend also provides this natively
188188-- in Haskell). Once that's done, you can run the demo as follows:
189189--
190−-- > cloud-haskell-azure-echo \
191−-- > <<subscription ID>> \
192−-- > /path/to/credentials.x509 \
193−-- > /path/to/credentials.private \
194−-- > <<remote username>> \
195−-- > <<cloud service name>> \
196−-- > <<virtual machine name>> \
197−-- > <<port number>>
190+-- > cloud-haskell-azure-echo \
191+-- > <<subscription ID>> \
192+-- > /path/to/credentials.x509 \
193+-- > /path/to/credentials.private \
194+-- > <<remote username>> \
195+-- > <<cloud service name>> \
196+-- > <<virtual machine name>> \
197+-- > <<port number>>
198198-- > # Everything I type gets echoed back
199199-- > Echo: Everything I type gets echoed back
200200-- > # Until I enter a blank line
201201-- > Echo: Until I enter a blank line
202−-- > #
202+-- > #
203203--
204204-- The full @echo@ demo is
205205--
206206-- > {-# LANGUAGE TemplateHaskell #-}
207−-- >
207+-- >
208208-- > import System.IO (hFlush, stdout)
209209-- > import System.Environment (getArgs)
210210-- > import Control.Monad (unless, forever)
211211-- > import Control.Monad.IO.Class (liftIO)
212212-- > import Control.Distributed.Process (Process, expect)
213−-- > import Control.Distributed.Process.Closure (remotable, mkClosure)
214−-- > import Control.Distributed.Process.Backend.Azure
215−-- >
213+-- > import Control.Distributed.Process.Closure (remotable, mkClosure)
214+-- > import Control.Distributed.Process.Backend.Azure
215+-- >
216216-- > echoRemote :: () -> Backend -> Process ()
217217-- > echoRemote () _backend = forever $ do
218−-- > str <- expect
218+-- > str <- expect
219219-- > remoteSend (str :: String)
220−-- >
220+-- >
221221-- > remotable ['echoRemote]
222−-- >
222+-- >
223223-- > echoLocal :: LocalProcess ()
224224-- > echoLocal = do
225225-- > str <- liftIO $ putStr "# " >> hFlush stdout >> getLine
@@ -229,35 +229,35 @@
229229-- > echo <- localExpect
230230-- > liftIO $ putStrLn echo
231231-- > echoLocal
232−-- >
232+-- >
233233-- > main :: IO ()
234234-- > main = do
235235-- > args <- getArgs
236236-- > case args of
237−-- > "onvm":args' ->
237+-- > "onvm":args' ->
238238-- > -- Pass execution to 'onVmMain' if we are running on the VM
239239-- > -- ('callOnVM' will provide the right arguments)
240240-- > onVmMain __remoteTable args'
241241-- >
242242-- > sid:x509:pkey:user:cloudService:virtualMachine:port:_ -> do
243243-- > -- Initialize the Azure backend
244−-- > params <- defaultAzureParameters sid x509 pkey
244+-- > params <- defaultAzureParameters sid x509 pkey
245245-- > let params' = params { azureSshUserName = user }
246246-- > backend <- initializeBackend params' cloudService
247247-- >
248248-- > -- Find the specified virtual machine
249249-- > Just vm <- findNamedVM backend virtualMachine
250250-- >
251−-- > -- Run the echo client proper
251+-- > -- Run the echo client proper
252252-- > callOnVM backend vm port $
253−-- > ProcessPair ($(mkClosure 'echoRemote) ())
254−-- > echoLocal
255−--
253+-- > ProcessPair ($(mkClosure 'echoRemote) ())
254+-- > echoLocal
255+--
256256-- The most important part of this code is the last three lines
257257--
258258-- > callOnVM backend vm port $
259−-- > ProcessPair ($(mkClosure 'echoRemote) ())
260−-- > echoLocal
259+-- > ProcessPair ($(mkClosure 'echoRemote) ())
260+-- > echoLocal
261261--
262262-- 'callOnVM' creats a new Cloud Haskell node on the specified virtual machine,
263263-- then runs @echoRemote@ on the remote machine and @echoLocal@ on the local
@@ -269,19 +269,19 @@
269269-- 'callOnVM' and 'spawnOnVM'. It uses the latter to
270270-- install a ping server which keeps running in the background; it uses the
271271-- former to run a ping client which sends a request to the ping server and
272−-- outputs the response.
272+-- outputs the response.
273273--
274274-- As with the @echo@ demo, make sure to copy the executable to the remote server first.
275275-- Once that is done, you can start a ping server on a virtual machine using
276276--
277277-- > cloud-haskell-azure-ping server \
278−-- > <<subscription ID>> \
279−-- > /path/to/credentials.x509 \
280−-- > /path/to/credentials.private \
278+-- > <<subscription ID>> \
279+-- > /path/to/credentials.x509 \
280+-- > /path/to/credentials.private \
281281-- > <<remote username>> \
282−-- > <<cloud service name>> \
283−-- > <<virtual machine name>> \
284−-- > <<port number>>
282+-- > <<cloud service name>> \
283+-- > <<virtual machine name>> \
284+-- > <<port number>>
285285--
286286-- As before, when we execute this on our local machine, it starts a new Cloud
287287-- Haskell node on the specified remote virtual machine and then executes the
@@ -294,11 +294,11 @@
294294-- > cloud-haskell-azure-ping client \
295295-- > <<subscription ID>> \
296296-- > /path/to/credentials.x509 \
297−-- > /path/to/credentials.private \
297+-- > /path/to/credentials.private \
298298-- > <<remote username>> \
299−-- > <<cloud service name>> \
300−-- > <<virtual machine name>> \
301−-- > <<DIFFERENT port number>>
299+-- > <<cloud service name>> \
300+-- > <<virtual machine name>> \
301+-- > <<DIFFERENT port number>>
302302-- > Ping server at pid://10.59.224.122:8080:0:2 ok
303303--
304304-- Note that we must pass a different port number, because the client will run
@@ -309,13 +309,13 @@
309309-- this case, through a PID file).
310310--
311311-- > {-# LANGUAGE TemplateHaskell #-}
312−-- >
312+-- >
313313-- > import System.Environment (getArgs)
314314-- > import Data.Binary (encode, decode)
315315-- > import Control.Monad (void, forever)
316316-- > import Control.Monad.IO.Class (liftIO)
317317-- > import Control.Exception (try, IOException)
318−-- > import Control.Distributed.Process
318+-- > import Control.Distributed.Process
319319-- > ( Process
320320-- > , getSelfPid
321321-- > , expect
@@ -325,72 +325,72 @@
325325-- > , match
326326-- > , ProcessMonitorNotification(..)
327327-- > )
328−-- > import Control.Distributed.Process.Closure (remotable, mkClosure)
329−-- > import Control.Distributed.Process.Backend.Azure
330−-- > import qualified Data.ByteString.Lazy as BSL (readFile, writeFile)
331−-- >
328+-- > import Control.Distributed.Process.Closure (remotable, mkClosure)
329+-- > import Control.Distributed.Process.Backend.Azure
330+-- > import qualified Data.ByteString.Lazy as BSL (readFile, writeFile)
331+-- >
332332-- > pingServer :: () -> Backend -> Process ()
333333-- > pingServer () _backend = do
334334-- > us <- getSelfPid
335335-- > liftIO $ BSL.writeFile "pingServer.pid" (encode us)
336−-- > forever $ do
336+-- > forever $ do
337337-- > them <- expect
338338-- > send them ()
339−-- >
340−-- > pingClientRemote :: () -> Backend -> Process ()
339+-- >
340+-- > pingClientRemote :: () -> Backend -> Process ()
341341-- > pingClientRemote () _backend = do
342342-- > mPingServerEnc <- liftIO $ try (BSL.readFile "pingServer.pid")
343343-- > case mPingServerEnc of
344−-- > Left err ->
344+-- > Left err ->
345345-- > remoteSend $ "Ping server not found: " ++ show (err :: IOException)
346−-- > Right pingServerEnc -> do
346+-- > Right pingServerEnc -> do
347347-- > let pingServerPid = decode pingServerEnc
348348-- > pid <- getSelfPid
349−-- > _ref <- monitor pingServerPid
349+-- > _ref <- monitor pingServerPid
350350-- > send pingServerPid pid
351−-- > gotReply <- receiveWait
351+-- > gotReply <- receiveWait
352352-- > [ match (\() -> return True)
353353-- > , match (\(ProcessMonitorNotification {}) -> return False)
354354-- > ]
355355-- > if gotReply
356356-- > then remoteSend $ "Ping server at " ++ show pingServerPid ++ " ok"
357357-- > else remoteSend $ "Ping server at " ++ show pingServerPid ++ " failure"
358−-- >
358+-- >
359359-- > remotable ['pingClientRemote, 'pingServer]
360−-- >
360+-- >
361361-- > pingClientLocal :: LocalProcess ()
362−-- > pingClientLocal = localExpect >>= liftIO . putStrLn
363−-- >
362+-- > pingClientLocal = localExpect >>= liftIO . putStrLn
363+-- >
364364-- > main :: IO ()
365365-- > main = do
366366-- > args <- getArgs
367367-- > case args of
368−-- > "onvm":args' ->
368+-- > "onvm":args' ->
369369-- > -- Pass execution to 'onVmMain' if we are running on the VM
370370-- > onVmMain __remoteTable args'
371371-- >
372372-- > "list":sid:x509:pkey:_ -> do
373373-- > -- List all available cloud services
374374-- > -- (useful, but not strictly necessary for the example)
375−-- > params <- defaultAzureParameters sid x509 pkey
375+-- > params <- defaultAzureParameters sid x509 pkey
376376-- > css <- cloudServices (azureSetup params)
377377-- > mapM_ print css
378378-- >
379379-- > cmd:sid:x509:pkey:user:cloudService:virtualMachine:port:_ -> do
380380-- > -- Initialize the backend and find the right VM
381−-- > params <- defaultAzureParameters sid x509 pkey
381+-- > params <- defaultAzureParameters sid x509 pkey
382382-- > let params' = params { azureSshUserName = user }
383383-- > backend <- initializeBackend params' cloudService
384384-- > Just vm <- findNamedVM backend virtualMachine
385−-- >
386−-- > -- The same binary can behave as the client or the server,
385+-- >
386+-- > -- The same binary can behave as the client or the server,
387387-- > -- depending on the command line arguments
388388-- > case cmd of
389−-- > "server" -> void $ spawnOnVM backend vm port ($(mkClosure 'pingServer) ())
390−-- > "client" -> callOnVM backend vm port $
391−-- > ProcessPair ($(mkClosure 'pingClientRemote) ())
392−-- > pingClientLocal
393−module Control.Distributed.Process.Backend.Azure
389+-- > "server" -> void $ spawnOnVM backend vm port ($(mkClosure 'pingServer) ())
390+-- > "client" -> callOnVM backend vm port $
391+-- > ProcessPair ($(mkClosure 'pingClientRemote) ())
392+-- > pingClientLocal
393+module Control.Distributed.Process.Backend.Azure
394394 ( -- * Initialization
395395 Backend(..)
396396 , AzureParameters(..)
@@ -422,7 +422,7 @@ import Prelude hiding (catch)
422422import System.Environment (getEnv)
423423import System.FilePath ((</>), takeFileName)
424424import System.Environment.Executable (getExecutablePath)
425−import System.IO
425+import System.IO
426426 ( stdout
427427 , hFlush
428428 , hSetBinaryMode
@@ -436,7 +436,7 @@ import qualified System.Posix.Process as Posix (forkProcess, createSession)
436436import Data.Maybe (listToMaybe)
437437import Data.Binary (Binary(get, put), encode, decode, getWord8, putWord8)
438438import Data.Digest.Pure.MD5 (md5, MD5Digest)
439−import qualified Data.ByteString as BSS
439+import qualified Data.ByteString as BSS
440440 ( ByteString
441441 , length
442442 , concat
@@ -444,7 +444,7 @@ import qualified Data.ByteString as BSS
444444 , hGet
445445 )
446446import qualified Data.ByteString.Char8 as BSSC (pack)
447−import qualified Data.ByteString.Lazy as BSL
447+import qualified Data.ByteString.Lazy as BSL
448448 ( ByteString
449449 , readFile
450450 , length
@@ -458,7 +458,7 @@ import Data.Foldable (forM_)
458458import Control.Applicative ((<$>), (<*>))
459459import Control.Monad (void, when)
460460import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask)
461−import Control.Exception
461+import Control.Exception
462462 ( Exception
463463 , catches
464464 , Handler(Handler)
@@ -469,17 +469,17 @@ import Control.Monad.IO.Class (MonadIO, liftIO)
469469import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar, putMVar)
470470
471471-- Azure
472−import Network.Azure.ServiceManagement
472+import Network.Azure.ServiceManagement
473473 ( CloudService(..)
474474 , VirtualMachine(..)
475475 , Endpoint(..)
476476 , AzureSetup
477477 )
478478import qualified Network.Azure.ServiceManagement as Azure
479− ( cloudServices
479+ ( cloudServices
480480 , azureSetup
481481 , vmSshEndpoint
482− )
482+ )
483483
484484-- SSH
485485import qualified Network.SSH.Client.LibSSH2 as SSH
@@ -505,7 +505,7 @@ import qualified Network.SSH.Client.LibSSH2.Errors as SSH
505505 )
506506
507507-- CH
508−import Control.Distributed.Process
508+import Control.Distributed.Process
509509 ( Process
510510 , Closure
511511 , RemoteTable
@@ -520,7 +520,7 @@ import Control.Distributed.Process
520520 , nsendRemote
521521 )
522522import Control.Distributed.Process.Serializable (Serializable)
523−import qualified Control.Distributed.Process.Internal.Types as CH
523+import qualified Control.Distributed.Process.Internal.Types as CH
524524 ( LocalNode
525525 , LocalProcess(processQueue)
526526 , Message
@@ -528,7 +528,7 @@ import qualified Control.Distributed.Process.Internal.Types as CH
528528 , messageToPayload
529529 , createMessage
530530 )
531−import Control.Distributed.Process.Node
531+import Control.Distributed.Process.Node
532532 ( runProcess
533533 , forkProcess
534534 , newLocalNode
@@ -539,7 +539,7 @@ import Network.Transport.TCP (createTransport, defaultTCPParameters)
539539import Network.Transport.Internal (encodeInt32, decodeInt32, prependLength)
540540
541541-- Static
542−import Control.Distributed.Static
542+import Control.Distributed.Static
543543 ( Static
544544 , registerStatic
545545 , staticClosure
@@ -552,18 +552,18 @@ data Backend = Backend {
552552 -- | Find virtual machines
553553 findVMs :: IO [VirtualMachine]
554554 -- | Copy the executable to a virtual machine
555− , copyToVM :: VirtualMachine -> IO ()
555+ , copyToVM :: VirtualMachine -> IO ()
556556 -- | Check the MD5 hash of the remote executable
557− , checkMD5 :: VirtualMachine -> IO Bool
557+ , checkMD5 :: VirtualMachine -> IO Bool
558558 -- | @runOnVM vm port pp@ starts a new CH node on machine @vm@ and then
559559 -- runs the specified process pair. The CH node will shut down when the
560560 -- /local/ process exists. @callOnVM@ returns the returned by the local
561561 -- process on exit.
562− , callOnVM :: forall a. VirtualMachine -> String -> ProcessPair a -> IO a
562+ , callOnVM :: forall a. VirtualMachine -> String -> ProcessPair a -> IO a
563563 -- | Create a new CH node and run the specified process.
564564 -- The CH node will shut down when the /remote/ process exists. @spawnOnVM@
565565 -- returns as soon as the process has been spawned.
566− , spawnOnVM :: VirtualMachine -> String -> RemoteProcess () -> IO ProcessId
566+ , spawnOnVM :: VirtualMachine -> String -> RemoteProcess () -> IO ProcessId
567567 } deriving (Typeable)
568568
569569-- | Azure connection parameters
@@ -588,7 +588,7 @@ instance Binary AzureParameters where
588588 put (azureSshKnownHosts params)
589589 put (azureSshRemotePath params)
590590 put (azureSshLocalPath params)
591− get =
591+ get =
592592 AzureParameters <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get
593593
594594-- | Create default azure parameters
@@ -600,9 +600,9 @@ defaultAzureParameters sid x509 pkey = do
600600 home <- getEnv "HOME"
601601 user <- getEnv "USER"
602602 self <- getExecutablePath
603− setup <- Azure.azureSetup sid x509 pkey
604− return AzureParameters
605− { azureSetup = setup
603+ setup <- Azure.azureSetup sid x509 pkey
604+ return AzureParameters
605+ { azureSetup = setup
606606 , azureSshUserName = user
607607 , azureSshPublicKey = home </> ".ssh" </> "id_rsa.pub"
608608 , azureSshPrivateKey = home </> ".ssh" </> "id_rsa"
@@ -616,10 +616,10 @@ defaultAzureParameters sid x509 pkey = do
616616initializeBackend :: AzureParameters -- ^ Connection parameters
617617 -> String -- ^ Cloud service name
618618 -> IO Backend
619−initializeBackend params cloudService =
619+initializeBackend params cloudService =
620620 return Backend {
621− findVMs = apiFindVMs params cloudService
622− , copyToVM = apiCopyToVM params
621+ findVMs = apiFindVMs params cloudService
622+ , copyToVM = apiCopyToVM params
623623 , checkMD5 = apiCheckMD5 params
624624 , callOnVM = apiCallOnVM params cloudService
625625 , spawnOnVM = apiSpawnOnVM params cloudService
@@ -628,81 +628,81 @@ initializeBackend params cloudService =
628628-- | Find virtual machines
629629apiFindVMs :: AzureParameters -> String -> IO [VirtualMachine]
630630apiFindVMs params cloudService = do
631− css <- Azure.cloudServices (azureSetup params)
631+ css <- Azure.cloudServices (azureSetup params)
632632 case filter ((== cloudService) . cloudServiceName) css of
633633 [cs] -> return $ cloudServiceVMs cs
634634 _ -> return []
635635
636636-- | Start a CH node on the given virtual machine
637637apiCopyToVM :: AzureParameters -> VirtualMachine -> IO ()
638−apiCopyToVM params vm =
638+apiCopyToVM params vm =
639639 void . withSSH2 params vm $ \s -> catchSshError s $
640640 SSH.scpSendFile s 0o700 (azureSshLocalPath params) (azureSshRemotePath params)
641641
642−-- | Call a process on a VM
643−apiCallOnVM :: AzureParameters
642+-- | Call a process on a VM
643+apiCallOnVM :: AzureParameters
644+ -> String
645+ -> VirtualMachine
644646 -> String
645− -> VirtualMachine
646− -> String
647647 -> ProcessPair a
648648 -> IO a
649649apiCallOnVM = runOnVM False
650650
651−apiSpawnOnVM :: AzureParameters
651+apiSpawnOnVM :: AzureParameters
652+ -> String
653+ -> VirtualMachine
652654 -> String
653− -> VirtualMachine
654− -> String
655− -> Closure (Backend -> Process ())
656− -> IO ProcessId
657−apiSpawnOnVM params cloudService vm port rproc =
658− runOnVM True params cloudService vm port $
655+ -> Closure (Backend -> Process ())
656+ -> IO ProcessId
657+apiSpawnOnVM params cloudService vm port rproc =
658+ runOnVM True params cloudService vm port $
659659 ProcessPair rproc localExpect
660−
660+
661661-- | Internal generalization of 'spawnOnVM' and 'callOnVM'
662−runOnVM :: Bool
662+runOnVM :: Bool
663663 -> AzureParameters
664664 -> String
665665 -> VirtualMachine
666666 -> String
667667 -> ProcessPair a
668668 -> IO a
669−runOnVM bg params cloudService vm port ppair =
669+runOnVM bg params cloudService vm port ppair =
670670 withSSH2 params vm $ \s -> do
671671 -- TODO: reduce duplication with apiCallOnVM
672− let exe = "PATH=. " ++ azureSshRemotePath params
672+ let exe = "PATH=. " ++ azureSshRemotePath params
673673 ++ " onvm"
674− ++ " " ++ vmIpAddress vm
674+ ++ " " ++ vmIpAddress vm
675675 ++ " " ++ port
676676 ++ " " ++ cloudService
677− ++ " " ++ show bg
677+ ++ " " ++ show bg
678678 ++ " 2>&1"
679679 let paramsEnc = encode params
680− let rprocEnc = encode (ppairRemote ppair)
680+ let rprocEnc = encode (ppairRemote ppair)
681681 (status, r) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do
682682 SSH.channelExecute ch exe
683683 SSH.writeChannel ch (encodeInt32 (BSL.length rprocEnc))
684− SSH.writeAllChannel ch rprocEnc
684+ SSH.writeAllChannel ch rprocEnc
685685 SSH.writeChannel ch (encodeInt32 (BSL.length paramsEnc))
686− SSH.writeAllChannel ch paramsEnc
686+ SSH.writeAllChannel ch paramsEnc
687687 runLocalProcess (ppairLocal ppair) ch
688− if status == 0
689− then return r
690− else error "runOnVM: Non-zero exit status" -- This would a bug
688+ if status == 0
689+ then return r
690+ else error "runOnVM: Non-zero exit status" -- This would a bug
691691
692692-- | Check the MD5 hash of the executable on the remote machine
693−apiCheckMD5 :: AzureParameters -> VirtualMachine -> IO Bool
693+apiCheckMD5 :: AzureParameters -> VirtualMachine -> IO Bool
694694apiCheckMD5 params vm = do
695695 hash <- localHash params
696696 withSSH2 params vm $ \s -> do
697697 (r, _) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do
698698 SSH.channelExecute ch "md5sum -c --status"
699− SSH.writeChannel ch . BSSC.pack $ show hash ++ " " ++ azureSshRemotePath params
699+ SSH.writeChannel ch . BSSC.pack $ show hash ++ " " ++ azureSshRemotePath params
700700 SSH.channelSendEOF ch
701701 SSH.readAllChannel ch
702702 return (r == 0)
703703
704−withSSH2 :: AzureParameters -> VirtualMachine -> (SSH.Session -> IO a) -> IO a
705−withSSH2 params (Azure.vmSshEndpoint -> Just ep) =
704+withSSH2 :: AzureParameters -> VirtualMachine -> (SSH.Session -> IO a) -> IO a
705+withSSH2 params (Azure.vmSshEndpoint -> Just ep) =
706706 SSH.withSSH2 (azureSshKnownHosts params)
707707 (azureSshPublicKey params)
708708 (azureSshPrivateKey params)
@@ -710,11 +710,11 @@ withSSH2 params (Azure.vmSshEndpoint -> Just ep) =
710710 (azureSshUserName params)
711711 (endpointVip ep)
712712 (read $ endpointPort ep)
713−withSSH2 _ vm =
713+withSSH2 _ vm =
714714 error $ "withSSH2: No SSH endpoint for virtual machine " ++ vmName vm
715715
716716catchSshError :: SSH.Session -> IO a -> IO a
717−catchSshError s io =
717+catchSshError s io =
718718 catches io [ Handler handleErrorCode
719719 , Handler handleNullPointer
720720 ]
@@ -725,12 +725,12 @@ catchSshError s io =
725725 error str
726726
727727 handleNullPointer :: SSH.NULL_POINTER -> IO a
728− handleNullPointer _ = do
728+ handleNullPointer _ = do
729729 (_, str) <- SSH.getLastError s
730730 error str
731−
732−localHash :: AzureParameters -> IO MD5Digest
733−localHash params = md5 <$> BSL.readFile (azureSshLocalPath params)
731+
732+localHash :: AzureParameters -> IO MD5Digest
733+localHash params = md5 <$> BSL.readFile (azureSshLocalPath params)
734734
735735--------------------------------------------------------------------------------
736736-- Utilities --
@@ -738,8 +738,8 @@ localHash params = md5 <$> BSL.readFile (azureSshLocalPath params)
738738
739739-- | Find a virtual machine with a particular name
740740findNamedVM :: Backend -> String -> IO (Maybe VirtualMachine)
741−findNamedVM backend vm =
742− listToMaybe . filter ((== vm) . vmName) <$> findVMs backend
741+findNamedVM backend vm =
742+ listToMaybe . filter ((== vm) . vmName) <$> findVMs backend
743743
744744--------------------------------------------------------------------------------
745745-- Local and remote processes --
@@ -750,10 +750,10 @@ findNamedVM backend vm =
750750-- for messages from the remote process using 'localExpect'. The remote process
751751-- can send messages to the local process using 'remoteSend', and wait for
752752-- messages from the local process using the standard Cloud Haskell primitives.
753−--
753+--
754754-- See also 'callOnVM'.
755755data ProcessPair a = ProcessPair {
756− ppairRemote :: RemoteProcess ()
756+ ppairRemote :: RemoteProcess ()
757757 , ppairLocal :: LocalProcess a
758758 }
759759
@@ -761,22 +761,22 @@ data ProcessPair a = ProcessPair {
761761type RemoteProcess a = Closure (Backend -> Process a)
762762
763763-- | The process to run on the local node (see 'ProcessPair' and 'callOnVM').
764−newtype LocalProcess a = LocalProcess { unLocalProcess :: ReaderT SSH.Channel IO a }
764+newtype LocalProcess a = LocalProcess { unLocalProcess :: ReaderT SSH.Channel IO a }
765765 deriving (Functor, Monad, MonadIO, MonadReader SSH.Channel)
766766
767767runLocalProcess :: LocalProcess a -> SSH.Channel -> IO a
768768runLocalProcess = runReaderT . unLocalProcess
769769
770−-- | Send a messages from the local process to the remote process
770+-- | Send a messages from the local process to the remote process
771771-- (see 'ProcessPair')
772772localSend :: Serializable a => a -> LocalProcess ()
773773localSend x = LocalProcess $ do
774774 ch <- ask
775− liftIO $ mapM_ (SSH.writeChannel ch)
775+ liftIO $ mapM_ (SSH.writeChannel ch)
776776 . prependLength
777− . CH.messageToPayload
778− . CH.createMessage
779− $ x
777+ . CH.messageToPayload
778+ . CH.createMessage
779+ $ x
780780
781781-- | Wait for a message from the remote process (see 'ProcessPair').
782782-- Note that unlike for the standard Cloud Haskell 'expect' it will result in a
@@ -784,14 +784,14 @@ localSend x = LocalProcess $ do
784784--
785785-- Since it is relatively easy for the remote process to mess up the
786786-- communication protocol (for instance, by doing a putStr) we ask for the
787−-- length twice, as some sort of sanity check.
787+-- length twice, as some sort of sanity check.
788788localExpect :: Serializable a => LocalProcess a
789789localExpect = LocalProcess $ do
790790 ch <- ask
791− liftIO $ do
791+ liftIO $ do
792792 isE <- readIntChannel ch
793− len <- readIntChannel ch
794− lenAgain <- readIntChannel ch
793+ len <- readIntChannel ch
794+ lenAgain <- readIntChannel ch
795795 when (len /= lenAgain) $ throwIO (userError "Internal error: protocol violation (perhaps the remote binary is not installed correctly?)")
796796 msg <- readSizeChannel ch len
797797 if isE /= 0
@@ -802,7 +802,7 @@ localExpect = LocalProcess $ do
802802-- 'ProcessPair'). Note that the remote process can use the standard Cloud
803803-- Haskell primitives to /receive/ messages from the local process.
804804remoteSend :: Serializable a => a -> Process ()
805−remoteSend = liftIO . remoteSend'
805+remoteSend = liftIO . remoteSend'
806806
807807remoteSend' :: Serializable a => a -> IO ()
808808remoteSend' = remoteSendFlagged 0
@@ -841,51 +841,51 @@ onVmMain rtable [host, port, cloudService, bg] = do
841841 hSetBinaryMode stdout True
842842 Just rprocEnc <- getWithLength stdin
843843 Just paramsEnc <- getWithLength stdin
844− backend <- initializeBackend (decode paramsEnc) cloudService
845− let rproc = decode rprocEnc
844+ backend <- initializeBackend (decode paramsEnc) cloudService
845+ let rproc = decode rprocEnc
846846 lprocMVar <- newEmptyMVar :: IO (MVar CH.LocalProcess)
847− if read bg
847+ if read bg
848848 then
849849 void . Posix.forkProcess $ do
850850 -- We inherit the file descriptors from the parent, so the SSH
851851 -- session will not be terminated until we close them
852852 void Posix.createSession
853− startCH rproc lprocMVar backend
853+ startCH rproc lprocMVar backend
854854 (\node proc -> runProcess node $ do
855855 us <- getSelfPid
856856 liftIO $ do
857857 remoteSend' us
858858 mapM_ hClose [stdin, stdout, stderr]
859− proc)
859+ proc)
860860 else do
861− startCH rproc lprocMVar backend forkProcess
861+ startCH rproc lprocMVar backend forkProcess
862862 lproc <- readMVar lprocMVar
863863 queueFromHandle stdin (CH.processQueue lproc)
864864 where
865− startCH :: RemoteProcess ()
866− -> MVar CH.LocalProcess
865+ startCH :: RemoteProcess ()
866+ -> MVar CH.LocalProcess
867867 -> Backend
868− -> (CH.LocalNode -> Process () -> IO a)
869− -> IO ()
868+ -> (CH.LocalNode -> Process () -> IO a)
869+ -> IO ()
870870 startCH rproc lprocMVar backend go = do
871− mTransport <- createTransport host port defaultTCPParameters
871+ mTransport <- createTransport host port defaultTCPParameters
872872 case mTransport of
873873 Left err -> remoteThrow err
874− Right transport -> do
874+ Right transport -> do
875875 node <- newLocalNode transport (rtable . __remoteTable $ initRemoteTable)
876− void . go node $ do
876+ void . go node $ do
877877 ask >>= liftIO . putMVar lprocMVar
878878 proc <- unClosure rproc :: Process (Backend -> Process ())
879− catch (proc backend)
879+ catch (proc backend)
880880 (liftIO . (remoteThrow :: SomeException -> IO ()))
881−onVmMain _ _
881+onVmMain _ _
882882 = error "Invalid arguments passed on onVmMain"
883883
884884-- | Read a 4-byte length @l@ and then an @l@-byte payload
885885--
886886-- Returns Nothing on EOF
887887getWithLength :: Handle -> IO (Maybe BSL.ByteString)
888−getWithLength h = do
888+getWithLength h = do
889889 lenEnc <- BSS.hGet h 4
890890 if BSS.length lenEnc < 4
891891 then return Nothing
@@ -898,9 +898,9 @@ getWithLength h = do
898898
899899queueFromHandle :: Handle -> CQueue CH.Message -> IO ()
900900queueFromHandle h q = do
901− mPayload <- getWithLength stdin
901+ mPayload <- getWithLength stdin
902902 forM_ mPayload $ \payload -> do
903− enqueue q $ CH.payloadToMessage (BSL.toChunks payload)
903+ enqueue q $ CH.payloadToMessage (BSL.toChunks payload)
904904 queueFromHandle h q
905905
906906--------------------------------------------------------------------------------
@@ -917,7 +917,7 @@ readSizeChannel ch = go []
917917 go (bs : acc) (size - BSS.length bs)
918918
919919readIntChannel :: SSH.Channel -> IO Int
920−readIntChannel ch =
920+readIntChannel ch =
921921 decodeInt32 . BSS.concat . BSL.toChunks <$> readSizeChannel ch 4
922922
923923--------------------------------------------------------------------------------
@@ -945,7 +945,7 @@ serviceProcess _backend = do
945945 go = do
946946 msg <- expect
947947 case msg of
948− ServiceProcessTerminate ->
948+ ServiceProcessTerminate ->
949949 return ()
950950
951951serviceProcessStatic :: Static (Backend -> Process ())
@@ -953,11 +953,11 @@ serviceProcessStatic = staticLabel "serviceProcess"
953953
954954-- | Start a new Cloud Haskell node on the given virtual machine
955955spawnNodeOnVM :: Backend -> VirtualMachine -> String -> IO NodeId
956−spawnNodeOnVM backend vm port =
956+spawnNodeOnVM backend vm port =
957957 processNodeId <$> spawnOnVM backend vm port (staticClosure serviceProcessStatic)
958958
959959-- | Terminate a node started with 'spawnNodeOnVM'
960−terminateNode :: NodeId -> Process ()
960+terminateNode :: NodeId -> Process ()
961961terminateNode nid = nsendRemote nid "$azureBackendServiceProcess" ServiceProcessTerminate
962962
963963__remoteTable :: RemoteTable -> RemoteTable
distributed-process-demos/src/Common/PrimeFactors.hs+2−2
@@ -6,7 +6,7 @@ module PrimeFactors where
66
77primes :: [Integer]
88primes = primes' (2:[3,5..])
9− where
9+ where
1010 primes' (x:xs) = x : primes' (filter (notDivisorOf x) xs)
1111 notDivisorOf d n = n `mod` d /= 0
1212
@@ -15,7 +15,7 @@ factors qs@(p:ps) n
1515 | n <= 1 = []
1616 | m == 0 = p : factors qs d
1717 | otherwise = factors ps n
18− where
18+ where
1919 (d,m) = n `divMod` p
2020
2121primeFactors :: Integer -> [Integer]
distributed-process-demos/src/MapReduce/CountWords.hs+5−5
@@ -1,5 +1,5 @@
11{-# LANGUAGE TupleSections #-}
2−module CountWords
2+module CountWords
33 ( Document
44 , localCountWords
55 , distrCountWords
@@ -8,8 +8,8 @@ module CountWords
88
99import Control.Distributed.Process
1010import Control.Distributed.Process.Closure
11−import MapReduce
12−import MonoDistrMapReduce hiding (__remoteTable)
11+import MapReduce
12+import MonoDistrMapReduce hiding (__remoteTable)
1313
1414type Document = String
1515type Word = String
@@ -18,7 +18,7 @@ type Frequency = Int
1818countWords :: MapReduce FilePath Document Word Frequency Frequency
1919countWords = MapReduce {
2020 mrMap = const (map (, 1) . words)
21− , mrReduce = const sum
21+ , mrReduce = const sum
2222 }
2323
2424localCountWords :: Map FilePath Document -> Map Word Frequency
@@ -31,4 +31,4 @@ remotable ['countWords_]
3131
3232distrCountWords :: [NodeId] -> Map FilePath Document -> Process (Map Word Frequency)
3333distrCountWords = distrMapReduce ($(mkClosure 'countWords_) ())
34−
34+
distributed-process-demos/src/MapReduce/KMeans.hs+30−30
@@ -1,5 +1,5 @@
11{-# LANGUAGE TupleSections #-}
2−module KMeans
2+module KMeans
33 ( Point
44 , Cluster
55 , localKMeans
@@ -24,37 +24,37 @@ type Cluster = (Double, Double)
2424average :: Fractional a => [a] -> a
2525average xs = sum xs / fromIntegral (length xs)
2626
27−distanceSq :: Point -> Point -> Double
27+distanceSq :: Point -> Point -> Double
2828distanceSq (x1, y1) (x2, y2) = a * a + b * b
2929 where
3030 a = x2 - x1
3131 b = y2 - y1
3232
3333nearest :: Point -> [Cluster] -> Cluster
34−nearest p = minimumBy (compare `on` distanceSq p)
34+nearest p = minimumBy (compare `on` distanceSq p)
3535
3636center :: [Point] -> Point
37−center ps = let (xs, ys) = unzip ps in (average xs, average ys)
37+center ps = let (xs, ys) = unzip ps in (average xs, average ys)
3838
3939kmeans :: Array Int Point -> MapReduce (Int, Int) [Cluster] Cluster Point ([Point], Point)
4040kmeans points = MapReduce {
4141 mrMap = \(lo, hi) cs -> [ let p = points ! i in (nearest p cs, p)
4242 | i <- [lo .. hi]
43− ]
43+ ]
4444 , mrReduce = \_ ps -> (ps, center ps)
4545 }
4646
47−localKMeans :: Array Int Point
48− -> [Cluster]
47+localKMeans :: Array Int Point
48+ -> [Cluster]
4949 -> Int
5050 -> Map Cluster ([Point], Point)
5151localKMeans points cs iterations = go (iterations - 1)
5252 where
5353 mr :: [Cluster] -> Map Cluster ([Point], Point)
5454 mr = localMapReduce (kmeans points) . trivialSegmentation
55−
55+
5656 go :: Int -> Map Cluster ([Point], Point)
57− go 0 = mr cs
57+ go 0 = mr cs
5858 go n = mr . map snd . Map.elems . go $ n - 1
5959
6060 trivialSegmentation :: [Cluster] -> Map (Int, Int) [Cluster]
@@ -68,60 +68,60 @@ dictOut = SerializableDict
6868
6969remotable ['kmeans, 'dictIn, 'dictOut]
7070
71−distrKMeans :: Array Int Point
71+distrKMeans :: Array Int Point
7272 -> [Cluster]
73− -> [NodeId]
73+ -> [NodeId]
7474 -> Int
7575 -> Process (Map Cluster ([Point], Point))
76−distrKMeans points cs mappers iterations =
77− distrMapReduce $(mkStatic 'dictIn)
78− $(mkStatic 'dictOut)
79− ($(mkClosure 'kmeans) points)
76+distrKMeans points cs mappers iterations =
77+ distrMapReduce $(mkStatic 'dictIn)
78+ $(mkStatic 'dictOut)
79+ ($(mkClosure 'kmeans) points)
8080 mappers
8181 (go (iterations - 1))
8282 where
8383 go :: Int
84− -> (Map (Int, Int) [Cluster] -> Process (Map Cluster ([Point], Point)))
84+ -> (Map (Int, Int) [Cluster] -> Process (Map Cluster ([Point], Point)))
8585 -> Process (Map Cluster ([Point], Point))
86− go 0 iteration =
87− iteration (Map.fromList $ map (, cs) segments)
86+ go 0 iteration =
87+ iteration (Map.fromList $ map (, cs) segments)
8888 go n iteration = do
8989 clusters <- go (n - 1) iteration
9090 let centers = map snd $ Map.elems clusters
9191 iteration (Map.fromList $ map (, centers) segments)
92−
92+
9393 segments :: [(Int, Int)]
9494 segments = let (lo, _) = bounds points in dividePoints numPoints lo
9595
9696 dividePoints :: Int -> Int -> [(Int, Int)]
97− dividePoints pointsLeft offset
98− | pointsLeft <= pointsPerMapper = [(offset, offset + pointsLeft - 1)]
97+ dividePoints pointsLeft offset
98+ | pointsLeft <= pointsPerMapper = [(offset, offset + pointsLeft - 1)]
9999 | otherwise = let offset' = offset + pointsPerMapper in
100100 (offset, offset' - 1)
101− : dividePoints (pointsLeft - pointsPerMapper) offset'
101+ : dividePoints (pointsLeft - pointsPerMapper) offset'
102102
103103 pointsPerMapper :: Int
104− pointsPerMapper =
104+ pointsPerMapper =
105105 ceiling (toRational numPoints / toRational (length mappers))
106−
106+
107107 numPoints :: Int
108108 numPoints = let (lo, hi) = bounds points in hi - lo + 1
109109
110110-- | Create a gnuplot data file for the output of the k-means algorithm
111111--
112−-- To plot the data, use
112+-- To plot the data, use
113113--
114114-- > plot "<<filename>>" u 1:2:3 with points palette
115115createGnuPlot :: Map KMeans.Cluster ([KMeans.Point], KMeans.Point) -> Handle -> IO ()
116−createGnuPlot clusters h =
116+createGnuPlot clusters h =
117117 mapM_ printPoint . flatten . zip colors . Map.toList $ clusters
118118 where
119− printPoint (x, y, color) =
119+ printPoint (x, y, color) =
120120 hPutStrLn h $ show x ++ " " ++ show y ++ " " ++ show color
121121
122− flatten :: [(Float, (KMeans.Cluster, ([KMeans.Point], KMeans.Point)))]
122+ flatten :: [(Float, (KMeans.Cluster, ([KMeans.Point], KMeans.Point)))]
123123 -> [(Double, Double, Float)]
124− flatten = concatMap (\(color, (_, (points, _))) -> map (\(x, y) -> (x, y, color)) points)
124+ flatten = concatMap (\(color, (_, (points, _))) -> map (\(x, y) -> (x, y, color)) points)
125125
126126 colors :: [Float]
127− colors = [0, 1 / fromIntegral (Map.size clusters) .. 1]
127+ colors = [0, 1 / fromIntegral (Map.size clusters) .. 1]
distributed-process-demos/src/MapReduce/MapReduce.hs+6−6
@@ -1,5 +1,5 @@
11{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, GADTs #-}
2−module MapReduce
2+module MapReduce
33 ( -- * Map-reduce skeleton and implementation
44 MapReduce(..)
55 , localMapReduce
@@ -31,16 +31,16 @@ data MapReduce k1 v1 k2 v2 v3 = MapReduce {
3131-- /Google’s MapReduce Programming Model---Revisited/ by Ralf Laemmel
3232-- (<http://userpages.uni-koblenz.de/~laemmel/MapReduce/>).
3333localMapReduce :: forall k1 k2 v1 v2 v3. Ord k2 =>
34− MapReduce k1 v1 k2 v2 v3
35− -> Map k1 v1
34+ MapReduce k1 v1 k2 v2 v3
35+ -> Map k1 v1
3636 -> Map k2 v3
3737localMapReduce mr = reducePerKey mr . groupByKey . mapPerKey mr
3838
3939reducePerKey :: MapReduce k1 v1 k2 v2 v3 -> Map k2 [v2] -> Map k2 v3
40−reducePerKey mr = Map.mapWithKey (mrReduce mr)
40+reducePerKey mr = Map.mapWithKey (mrReduce mr)
4141
4242groupByKey :: Ord k2 => [(k2, v2)] -> Map k2 [v2]
43−groupByKey = Map.fromListWith (++) . map (second return)
43+groupByKey = Map.fromListWith (++) . map (second return)
4444
4545mapPerKey :: MapReduce k1 v1 k2 v2 v3 -> Map k1 v1 -> [(k2, v2)]
46−mapPerKey mr = concatMap (uncurry (mrMap mr)) . Map.toList
46+mapPerKey mr = concatMap (uncurry (mrMap mr)) . Map.toList
distributed-process-demos/src/MapReduce/MonoDistrMapReduce.hs+8−8
@@ -17,16 +17,16 @@ mapperProcess :: (ProcessId, ProcessId, Closure (MapReduce String String String
1717mapperProcess (master, workQueue, mrClosure) = do
1818 us <- getSelfPid
1919 mr <- unClosure mrClosure
20− go us mr
20+ go us mr
2121 where
2222 go us mr = do
23− -- Ask the queue for work
23+ -- Ask the queue for work
2424 send workQueue us
25−
25+
2626 -- Wait for a reply; if there is work, do it and repeat; otherwise, exit
27− receiveWait
27+ receiveWait
2828 [ match $ \(key, val) -> send master (mrMap mr key val) >> go us mr
29− , match $ \() -> return ()
29+ , match $ \() -> return ()
3030 ]
3131
3232remotable ['mapperProcess]
@@ -41,7 +41,7 @@ distrMapReduce mrClosure mappers input = do
4141
4242 workQueue <- spawnLocal $ do
4343 -- Return the next bit of work to be done
44− forM_ (Map.toList input) $ \(key, val) -> do
44+ forM_ (Map.toList input) $ \(key, val) -> do
4545 them <- expect
4646 send them (key, val)
4747
@@ -51,10 +51,10 @@ distrMapReduce mrClosure mappers input = do
5151 send them ()
5252
5353 -- Start the mappers
54− forM_ mappers $ \nid -> spawn nid ($(mkClosure 'mapperProcess) (master, workQueue, mrClosure))
54+ forM_ mappers $ \nid -> spawn nid ($(mkClosure 'mapperProcess) (master, workQueue, mrClosure))
5555
5656 -- Wait for the partial results
57− partials <- replicateM (Map.size input) expect
57+ partials <- replicateM (Map.size input) expect
5858
5959 -- We reduce on this node
6060 return (reducePerKey mr . groupByKey . concat $ partials)
distributed-process-demos/src/MapReduce/PolyDistrMapReduce.hs+23−23
@@ -26,65 +26,65 @@ sendDict SerializableDict = send
2626sdictProcessIdPair :: SerializableDict (ProcessId, ProcessId)
2727sdictProcessIdPair = SerializableDict
2828
29−mapperProcess :: forall k1 v1 k2 v2 v3.
29+mapperProcess :: forall k1 v1 k2 v2 v3.
3030 SerializableDict (k1, v1)
3131 -> SerializableDict [(k2, v2)]
3232 -> (ProcessId, ProcessId)
33− -> MapReduce k1 v1 k2 v2 v3
33+ -> MapReduce k1 v1 k2 v2 v3
3434 -> Process ()
35−mapperProcess dictIn dictOut (master, workQueue) mr = getSelfPid >>= go
35+mapperProcess dictIn dictOut (master, workQueue) mr = getSelfPid >>= go
3636 where
3737 go us = do
38− -- Ask the queue for work
38+ -- Ask the queue for work
3939 send workQueue us
40−
40+
4141 -- Wait for a reply; if there is work, do it and repeat; otherwise, exit
42− receiveWait
42+ receiveWait
4343 [ matchDict dictIn $ \(key, val) -> do
4444 sendDict dictOut master (mrMap mr key val)
4545 go us
46− , match $ \() ->
47− return ()
46+ , match $ \() ->
47+ return ()
4848 ]
4949
5050remotable ['mapperProcess, 'sdictProcessIdPair]
5151
52−mapperProcessClosure :: forall k1 v1 k2 v2 v3.
52+mapperProcessClosure :: forall k1 v1 k2 v2 v3.
5353 (Typeable k1, Typeable v1, Typeable k2, Typeable v2, Typeable v3)
5454 => Static (SerializableDict (k1, v1))
5555 -> Static (SerializableDict [(k2, v2)])
56− -> Closure (MapReduce k1 v1 k2 v2 v3)
57− -> ProcessId
58− -> ProcessId
56+ -> Closure (MapReduce k1 v1 k2 v2 v3)
57+ -> ProcessId
58+ -> ProcessId
5959 -> Closure (Process ())
60−mapperProcessClosure dictIn dictOut mr master workQueue =
60+mapperProcessClosure dictIn dictOut mr master workQueue =
6161 closure decoder (encode (master, workQueue)) `closureApply` mr
6262 where
6363 decoder :: Static (ByteString -> MapReduce k1 v1 k2 v2 v3 -> Process ())
64− decoder =
64+ decoder =
6565 ($(mkStatic 'mapperProcess) `staticApply` dictIn `staticApply` dictOut)
66− `staticCompose`
66+ `staticCompose`
6767 staticDecode $(mkStatic 'sdictProcessIdPair)
6868
69−distrMapReduce :: forall k1 k2 v1 v2 v3 a.
69+distrMapReduce :: forall k1 k2 v1 v2 v3 a.
7070 (Serializable k1, Serializable v1, Serializable k2, Serializable v2, Serializable v3, Ord k2)
7171 => Static (SerializableDict (k1, v1))
7272 -> Static (SerializableDict [(k2, v2)])
7373 -> Closure (MapReduce k1 v1 k2 v2 v3)
7474 -> [NodeId]
75− -> ((Map k1 v1 -> Process (Map k2 v3)) -> Process a)
76− -> Process a
75+ -> ((Map k1 v1 -> Process (Map k2 v3)) -> Process a)
76+ -> Process a
7777distrMapReduce dictIn dictOut mr mappers p = do
7878 mr' <- unClosure mr
7979 master <- getSelfPid
8080
8181 workQueue <- spawnChannelLocal $ \queue -> do
8282 let go :: Process ()
83− go = do
83+ go = do
8484 mWork <- receiveChan queue
8585 case mWork of
8686 Just (key, val) -> do
87− -- As long there is work, make it available to the mappers
87+ -- As long there is work, make it available to the mappers
8888 them <- expect
8989 send them (key, val)
9090 go
@@ -100,8 +100,8 @@ distrMapReduce dictIn dictOut mr mappers p = do
100100
101101 -- Start the mappers
102102 let workQueuePid = sendPortProcessId (sendPortId workQueue)
103− forM_ mappers $ \nid ->
104− spawn nid (mapperProcessClosure dictIn dictOut mr master workQueuePid)
103+ forM_ mappers $ \nid ->
104+ spawn nid (mapperProcessClosure dictIn dictOut mr master workQueuePid)
105105
106106 let iteration :: Map k1 v1 -> Process (Map k2 v3)
107107 iteration input = do
@@ -109,7 +109,7 @@ distrMapReduce dictIn dictOut mr mappers p = do
109109 mapM_ (sendChan workQueue . Just) (Map.toList input)
110110
111111 -- Wait for the partial results
112− partials <- replicateM (Map.size input) expect
112+ partials <- replicateM (Map.size input) expect
113113
114114 -- We reduce on this node
115115 return (reducePerKey mr' . groupByKey . concat $ partials)
distributed-process-demos/src/MapReduce/SimpleLocalnet.hs+15−15
@@ -10,53 +10,53 @@ import Data.Map (Map)
1010import Data.Array (Array, listArray)
1111import qualified Data.Map as Map (fromList)
1212
13−import qualified CountWords
13+import qualified CountWords
1414import qualified PolyDistrMapReduce
1515import qualified MonoDistrMapReduce
1616import qualified KMeans
1717
1818rtable :: RemoteTable
19−rtable = PolyDistrMapReduce.__remoteTable
20− . MonoDistrMapReduce.__remoteTable
19+rtable = PolyDistrMapReduce.__remoteTable
20+ . MonoDistrMapReduce.__remoteTable
2121 . CountWords.__remoteTable
2222 . KMeans.__remoteTable
23− $ initRemoteTable
23+ $ initRemoteTable
2424
2525main :: IO ()
2626main = do
2727 args <- getArgs
2828
2929 case args of
30− -- Local word count
30+ -- Local word count
3131 "local" : "count" : files -> do
32− input <- constructInput files
33− print $ CountWords.localCountWords input
32+ input <- constructInput files
33+ print $ CountWords.localCountWords input
3434
3535 -- Distributed word count
3636 "master" : host : port : "count" : files -> do
37− input <- constructInput files
38− backend <- initializeBackend host port rtable
37+ input <- constructInput files
38+ backend <- initializeBackend host port rtable
3939 startMaster backend $ \slaves -> do
40− result <- CountWords.distrCountWords slaves input
41− liftIO $ print result
40+ result <- CountWords.distrCountWords slaves input
41+ liftIO $ print result
4242
4343 -- Local k-means
4444 "local" : "kmeans" : [] -> do
4545 points <- replicateM 50000 randomPoint
4646 withFile "plot.data" WriteMode $ KMeans.createGnuPlot $
47− KMeans.localKMeans (arrayFromList points) (take 5 points) 5
47+ KMeans.localKMeans (arrayFromList points) (take 5 points) 5
4848
4949 -- Distributed k-means
5050 "master" : host : port : "kmeans" : [] -> do
5151 points <- replicateM 50000 randomPoint
52− backend <- initializeBackend host port rtable
52+ backend <- initializeBackend host port rtable
5353 startMaster backend $ \slaves -> do
54− result <- KMeans.distrKMeans (arrayFromList points) (take 5 points) slaves 5
54+ result <- KMeans.distrKMeans (arrayFromList points) (take 5 points) slaves 5
5555 liftIO $ withFile "plot.data" WriteMode $ KMeans.createGnuPlot result
5656
5757 -- Generic slave for distributed examples
5858 "slave" : host : port : [] -> do
59− backend <- initializeBackend host port rtable
59+ backend <- initializeBackend host port rtable
6060 startSlave backend
6161
6262--------------------------------------------------------------------------------
distributed-process-demos/src/MasterSlave/Azure.hs+7−7
@@ -2,13 +2,13 @@ import System.Environment (getArgs)
22import Control.Monad
33import Control.Distributed.Process
44import Control.Distributed.Process.Closure
5−import Control.Distributed.Process.Backend.Azure
5+import Control.Distributed.Process.Backend.Azure
66import qualified MasterSlave
77
88azureMaster :: ([NodeId], Integer) -> Backend -> Process ()
99azureMaster (slaves, n) _backend = do
1010 result <- MasterSlave.master n slaves
11− mapM_ terminateNode slaves
11+ mapM_ terminateNode slaves
1212 remoteSend result
1313
1414remotable ['azureMaster]
@@ -16,7 +16,7 @@ remotable ['azureMaster]
1616printResult :: LocalProcess ()
1717printResult = do
1818 result <- localExpect :: LocalProcess Integer
19− liftIO $ print result
19+ liftIO $ print result
2020
2121main :: IO ()
2222main = do
@@ -24,14 +24,14 @@ main = do
2424 case args of
2525 "onvm":args' -> onVmMain (__remoteTable . MasterSlave.__remoteTable) args'
2626 [sid, x509, pkey, user, cloudService, n] -> do
27− params <- defaultAzureParameters sid x509 pkey
27+ params <- defaultAzureParameters sid x509 pkey
2828 let params' = params { azureSshUserName = user }
2929 backend <- initializeBackend params' cloudService
3030 vms <- findVMs backend
3131 print vms
3232 nids <- forM vms $ \vm -> spawnNodeOnVM backend vm "8080"
33− callOnVM backend (head vms) "8081" $
34− ProcessPair ($(mkClosure 'azureMaster) (nids, read n :: Integer))
35− printResult
33+ callOnVM backend (head vms) "8081" $
34+ ProcessPair ($(mkClosure 'azureMaster) (nids, read n :: Integer))
35+ printResult
3636 _ ->
3737 error "Invalid command line arguments"
distributed-process-demos/src/MasterSlave/MasterSlave.hs+4−4
@@ -16,21 +16,21 @@ sumIntegers = go 0
1616 where
1717 go :: Integer -> Int -> Process Integer
1818 go !acc 0 = return acc
19− go !acc n = do
19+ go !acc n = do
2020 m <- expect
2121 go (acc + m) (n - 1)
2222
2323data SpawnStrategy = SpawnSyncWithReconnect
2424 | SpawnSyncNoReconnect
2525 | SpawnAsync
26− deriving (Show, Read)
26+ deriving (Show, Read)
2727
2828master :: Integer -> SpawnStrategy -> [NodeId] -> Process Integer
2929master n spawnStrategy slaves = do
3030 us <- getSelfPid
3131
32− -- Distribute 1 .. n amongst the slave processes
33− spawnLocal $ case spawnStrategy of
32+ -- Distribute 1 .. n amongst the slave processes
33+ spawnLocal $ case spawnStrategy of
3434 SpawnSyncWithReconnect ->
3535 forM_ (zip [1 .. n] (cycle slaves)) $ \(m, there) -> do
3636 them <- spawn there ($(mkClosure 'slave) (us, m))
distributed-process-demos/src/MasterSlave/SimpleLocalnet.hs+4−4
@@ -6,7 +6,7 @@ import Control.Distributed.Process.Backend.SimpleLocalnet
66import qualified MasterSlave
77
88rtable :: RemoteTable
9−rtable = MasterSlave.__remoteTable initRemoteTable
9+rtable = MasterSlave.__remoteTable initRemoteTable
1010
1111main :: IO ()
1212main = do
@@ -14,12 +14,12 @@ main = do
1414
1515 case args of
1616 ["master", host, port, strN, strSpawnStrategy] -> do
17− backend <- initializeBackend host port rtable
17+ backend <- initializeBackend host port rtable
1818 n <- evaluate $ read strN
1919 spawnStrategy <- evaluate $ read strSpawnStrategy
2020 startMaster backend $ \slaves -> do
2121 result <- MasterSlave.master n spawnStrategy slaves
22− liftIO $ print result
22+ liftIO $ print result
2323 ["slave", host, port] -> do
24− backend <- initializeBackend host port rtable
24+ backend <- initializeBackend host port rtable
2525 startSlave backend
distributed-process-demos/src/TypedWorkPushing/Azure.hs+7−7
@@ -2,13 +2,13 @@ import System.Environment (getArgs)
22import Control.Monad
33import Control.Distributed.Process
44import Control.Distributed.Process.Closure
5−import Control.Distributed.Process.Backend.Azure
5+import Control.Distributed.Process.Backend.Azure
66import qualified MasterSlave
77
88azureMaster :: ([NodeId], Integer) -> Backend -> Process ()
99azureMaster (slaves, n) _backend = do
1010 result <- MasterSlave.master n slaves
11− mapM_ terminateNode slaves
11+ mapM_ terminateNode slaves
1212 remoteSend result
1313
1414remotable ['azureMaster]
@@ -16,7 +16,7 @@ remotable ['azureMaster]
1616printResult :: LocalProcess ()
1717printResult = do
1818 result <- localExpect :: LocalProcess Integer
19− liftIO $ print result
19+ liftIO $ print result
2020
2121main :: IO ()
2222main = do
@@ -24,14 +24,14 @@ main = do
2424 case args of
2525 "onvm":args' -> onVmMain (__remoteTable . MasterSlave.__remoteTable) args'
2626 [sid, x509, pkey, user, cloudService, n] -> do
27− params <- defaultAzureParameters sid x509 pkey
27+ params <- defaultAzureParameters sid x509 pkey
2828 let params' = params { azureSshUserName = user }
2929 backend <- initializeBackend params' cloudService
3030 vms <- findVMs backend
3131 print vms
3232 nids <- forM vms $ \vm -> spawnNodeOnVM backend vm "8080"
33− callOnVM backend (head vms) "8081" $
34− ProcessPair ($(mkClosure 'azureMaster) (nids, read n :: Integer))
35− printResult
33+ callOnVM backend (head vms) "8081" $
34+ ProcessPair ($(mkClosure 'azureMaster) (nids, read n :: Integer))
35+ printResult
3636 _ ->
3737 error "Invalid command line arguments"
distributed-process-demos/src/TypedWorkPushing/SimpleLocalnet.hs+4−4
@@ -5,7 +5,7 @@ import Control.Distributed.Process.Backend.SimpleLocalnet
55import qualified TypedWorkPushing
66
77rtable :: RemoteTable
8−rtable = TypedWorkPushing.__remoteTable initRemoteTable
8+rtable = TypedWorkPushing.__remoteTable initRemoteTable
99
1010main :: IO ()
1111main = do
@@ -13,10 +13,10 @@ main = do
1313
1414 case args of
1515 ["master", host, port, n] -> do
16− backend <- initializeBackend host port rtable
16+ backend <- initializeBackend host port rtable
1717 startMaster backend $ \slaves -> do
1818 result <- TypedWorkPushing.master (read n) slaves
19− liftIO $ print result
19+ liftIO $ print result
2020 ["slave", host, port] -> do
21− backend <- initializeBackend host port rtable
21+ backend <- initializeBackend host port rtable
2222 startSlave backend
distributed-process-demos/src/TypedWorkPushing/TypedWorkPushing.hs+7−7
@@ -7,7 +7,7 @@ import PrimeFactors
77
88slave :: SendPort Integer -> ReceivePort Integer -> Process ()
99slave results todo = forever $ do
10− n <- receiveChan todo
10+ n <- receiveChan todo
1111 sendChan results (numPrimeFactors n)
1212
1313sdictInteger :: SerializableDict Integer
@@ -22,20 +22,20 @@ sumIntegers rport = go 0
2222 go :: Integer -> Int -> Process Integer
2323 go !acc 0 = return acc
2424 go !acc n = do
25− m <- receiveChan rport
25+ m <- receiveChan rport
2626 go (acc + m) (n - 1)
2727
2828master :: Integer -> [NodeId] -> Process Integer
2929master n slaves = do
3030 (sport, rport) <- newChan
3131
32− -- Start slave processes
33− slaveProcesses <- forM slaves $ \nid ->
32+ -- Start slave processes
33+ slaveProcesses <- forM slaves $ \nid ->
3434 spawnChannel $(mkStatic 'sdictInteger) nid ($(mkClosure 'slave) sport)
3535
36− -- Distribute 1 .. n amongst the slave processes
37− spawnLocal $ forM_ (zip [1 .. n] (cycle slaveProcesses)) $
38− \(m, them) -> sendChan them m
36+ -- Distribute 1 .. n amongst the slave processes
37+ spawnLocal $ forM_ (zip [1 .. n] (cycle slaveProcesses)) $
38+ \(m, them) -> sendChan them m
3939
4040 -- Wait for the result
4141 sumIntegers rport (fromIntegral n)
distributed-process-demos/src/WorkPushing/Azure.hs+7−7
@@ -2,13 +2,13 @@ import System.Environment (getArgs)
22import Control.Monad
33import Control.Distributed.Process
44import Control.Distributed.Process.Closure
5−import Control.Distributed.Process.Backend.Azure
5+import Control.Distributed.Process.Backend.Azure
66import qualified MasterSlave
77
88azureMaster :: ([NodeId], Integer) -> Backend -> Process ()
99azureMaster (slaves, n) _backend = do
1010 result <- MasterSlave.master n slaves
11− mapM_ terminateNode slaves
11+ mapM_ terminateNode slaves
1212 remoteSend result
1313
1414remotable ['azureMaster]
@@ -16,7 +16,7 @@ remotable ['azureMaster]
1616printResult :: LocalProcess ()
1717printResult = do
1818 result <- localExpect :: LocalProcess Integer
19− liftIO $ print result
19+ liftIO $ print result
2020
2121main :: IO ()
2222main = do
@@ -24,14 +24,14 @@ main = do
2424 case args of
2525 "onvm":args' -> onVmMain (__remoteTable . MasterSlave.__remoteTable) args'
2626 [sid, x509, pkey, user, cloudService, n] -> do
27− params <- defaultAzureParameters sid x509 pkey
27+ params <- defaultAzureParameters sid x509 pkey
2828 let params' = params { azureSshUserName = user }
2929 backend <- initializeBackend params' cloudService
3030 vms <- findVMs backend
3131 print vms
3232 nids <- forM vms $ \vm -> spawnNodeOnVM backend vm "8080"
33− callOnVM backend (head vms) "8081" $
34− ProcessPair ($(mkClosure 'azureMaster) (nids, read n :: Integer))
35− printResult
33+ callOnVM backend (head vms) "8081" $
34+ ProcessPair ($(mkClosure 'azureMaster) (nids, read n :: Integer))
35+ printResult
3636 _ ->
3737 error "Invalid command line arguments"
distributed-process-demos/src/WorkPushing/SimpleLocalnet.hs+4−4
@@ -5,7 +5,7 @@ import Control.Distributed.Process.Backend.SimpleLocalnet
55import qualified WorkPushing
66
77rtable :: RemoteTable
8−rtable = WorkPushing.__remoteTable initRemoteTable
8+rtable = WorkPushing.__remoteTable initRemoteTable
99
1010main :: IO ()
1111main = do
@@ -13,10 +13,10 @@ main = do
1313
1414 case args of
1515 ["master", host, port, n] -> do
16− backend <- initializeBackend host port rtable
16+ backend <- initializeBackend host port rtable
1717 startMaster backend $ \slaves -> do
1818 result <- WorkPushing.master (read n) slaves
19− liftIO $ print result
19+ liftIO $ print result
2020 ["slave", host, port] -> do
21− backend <- initializeBackend host port rtable
21+ backend <- initializeBackend host port rtable
2222 startSlave backend
distributed-process-demos/src/WorkPushing/WorkPushing.hs+4−4
@@ -26,12 +26,12 @@ master :: Integer -> [NodeId] -> Process Integer
2626master n slaves = do
2727 us <- getSelfPid
2828
29− -- Start slave processes
29+ -- Start slave processes
3030 slaveProcesses <- forM slaves $ \nid -> spawn nid ($(mkClosure 'slave) us)
3131
32− -- Distribute 1 .. n amongst the slave processes
33− spawnLocal $ forM_ (zip [1 .. n] (cycle slaveProcesses)) $
34− \(m, them) -> send them m
32+ -- Distribute 1 .. n amongst the slave processes
33+ spawnLocal $ forM_ (zip [1 .. n] (cycle slaveProcesses)) $
34+ \(m, them) -> send them m
3535
3636 -- Wait for the result
3737 sumIntegers (fromIntegral n)
distributed-process-demos/src/WorkStealing/SimpleLocalnet.hs+4−4
@@ -5,7 +5,7 @@ import Control.Distributed.Process.Backend.SimpleLocalnet
55import qualified WorkStealing
66
77rtable :: RemoteTable
8−rtable = WorkStealing.__remoteTable initRemoteTable
8+rtable = WorkStealing.__remoteTable initRemoteTable
99
1010main :: IO ()
1111main = do
@@ -13,10 +13,10 @@ main = do
1313
1414 case args of
1515 ["master", host, port, n] -> do
16− backend <- initializeBackend host port rtable
16+ backend <- initializeBackend host port rtable
1717 startMaster backend $ \slaves -> do
1818 result <- WorkStealing.master (read n) slaves
19− liftIO $ print result
19+ liftIO $ print result
2020 ["slave", host, port] -> do
21− backend <- initializeBackend host port rtable
21+ backend <- initializeBackend host port rtable
2222 startSlave backend
distributed-process-demos/src/WorkStealing/WorkStealing.hs+8−8
@@ -11,11 +11,11 @@ slave (master, workQueue) = do
1111 go us
1212 where
1313 go us = do
14− -- Ask the queue for work
14+ -- Ask the queue for work
1515 send workQueue us
16−
17− -- If there is work, do it, otherwise terminate
18− receiveWait
16+
17+ -- If there is work, do it, otherwise terminate
18+ receiveWait
1919 [ match $ \n -> send master (numPrimeFactors n) >> go us
2020 , match $ \() -> return ()
2121 ]
@@ -37,17 +37,17 @@ master n slaves = do
3737 us <- getSelfPid
3838
3939 workQueue <- spawnLocal $ do
40− -- Reply with the next bit of work to be done
40+ -- Reply with the next bit of work to be done
4141 forM_ [1 .. n] $ \m -> do
42− them <- expect
43− send them m
42+ them <- expect
43+ send them m
4444
4545 -- Once all the work is done, tell the slaves to terminate
4646 forever $ do
4747 pid <- expect
4848 send pid ()
4949
50− -- Start slave processes
50+ -- Start slave processes
5151 forM_ slaves $ \nid -> spawn nid ($(mkClosure 'slave) (us, workQueue))
5252
5353 -- Wait for the result
distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hs+52−52
@@ -3,41 +3,41 @@
33-- get you going with Cloud Haskell quickly without imposing any structure
44-- on your application.
55--
6−-- To simplify getting started we provide special support for /master/ and
6+-- To simplify getting started we provide special support for /master/ and
77-- /slave/ nodes (see 'startSlave' and 'startMaster'). Use of these functions
88-- is completely optional; you can use the local backend without making use
99-- of the predefined master and slave nodes.
10−--
10+--
1111-- [Minimal example]
1212--
1313-- > import System.Environment (getArgs)
1414-- > import Control.Distributed.Process
1515-- > import Control.Distributed.Process.Node (initRemoteTable)
1616-- > import Control.Distributed.Process.Backend.SimpleLocalnet
17−-- >
17+-- >
1818-- > master :: Backend -> [NodeId] -> Process ()
1919-- > master backend slaves = do
2020-- > -- Do something interesting with the slaves
2121-- > liftIO . putStrLn $ "Slaves: " ++ show slaves
2222-- > -- Terminate the slaves when the master terminates (this is optional)
2323-- > terminateAllSlaves backend
24−-- >
24+-- >
2525-- > main :: IO ()
2626-- > main = do
2727-- > args <- getArgs
28−-- >
28+-- >
2929-- > case args of
3030-- > ["master", host, port] -> do
31−-- > backend <- initializeBackend host port initRemoteTable
31+-- > backend <- initializeBackend host port initRemoteTable
3232-- > startMaster backend (master backend)
3333-- > ["slave", host, port] -> do
34−-- > backend <- initializeBackend host port initRemoteTable
34+-- > backend <- initializeBackend host port initRemoteTable
3535-- > startSlave backend
36−--
36+--
3737-- [Compiling and Running]
3838--
3939-- Save to @example.hs@ and compile using
40−--
40+--
4141-- > ghc -threaded example.hs
4242--
4343-- Fire up some slave nodes (for the example, we run them on a single machine):
@@ -68,7 +68,7 @@
6868-- master on a fifth node (or on any of the four machines that run the slave
6969-- nodes).
7070--
71−-- It is important that every node has a unique (hostname, port number) pair,
71+-- It is important that every node has a unique (hostname, port number) pair,
7272-- and that the hostname you use to initialize the node can be resolved by
7373-- peer nodes. In other words, if you start a node and pass hostname @localhost@
7474-- then peer nodes won't be able to reach it because @localhost@ will resolve
@@ -79,10 +79,10 @@
7979-- If you try the above example and the master process cannot find any slaves,
8080-- then it might be that your firewall settings do not allow for UDP multicast
8181-- (in particular, the default iptables on some Linux distributions might not
82−-- allow it).
82+-- allow it).
8383{-# OPTIONS_GHC -fno-warn-orphans #-}
8484module Control.Distributed.Process.Backend.SimpleLocalnet
85− ( -- * Initialization
85+ ( -- * Initialization
8686 Backend(..)
8787 , initializeBackend
8888 -- * Slave nodes
@@ -128,13 +128,13 @@ import Control.Distributed.Process
128128 , unmonitor
129129 , NodeMonitorNotification(..)
130130 )
131−import qualified Control.Distributed.Process.Node as Node
131+import qualified Control.Distributed.Process.Node as Node
132132 ( LocalNode
133133 , newLocalNode
134134 , localNodeId
135135 , runProcess
136136 )
137−import qualified Network.Transport.TCP as NT
137+import qualified Network.Transport.TCP as NT
138138 ( createTransport
139139 , defaultTCPParameters
140140 )
@@ -142,7 +142,7 @@ import qualified Network.Transport as NT (Transport)
142142import qualified Network.Socket as N (HostName, ServiceName, SockAddr)
143143import Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast (initMulticast)
144144
145−-- | Local backend
145+-- | Local backend
146146data Backend = Backend {
147147 -- | Create a new local node
148148 newLocalNode :: IO Node.LocalNode
@@ -164,64 +164,64 @@ data BackendState = BackendState {
164164-- | Initialize the backend
165165initializeBackend :: N.HostName -> N.ServiceName -> RemoteTable -> IO Backend
166166initializeBackend host port rtable = do
167− mTransport <- NT.createTransport host port NT.defaultTCPParameters
167+ mTransport <- NT.createTransport host port NT.defaultTCPParameters
168168 (recv, send) <- initMulticast "224.0.0.99" 9999 1024
169169 (_, backendState) <- fixIO $ \ ~(tid, _) -> do
170− backendState <- newMVar BackendState
171− { _localNodes = []
170+ backendState <- newMVar BackendState
171+ { _localNodes = []
172172 , _peers = Set.empty
173173 , discoveryDaemon = tid
174174 }
175− tid' <- forkIO $ peerDiscoveryDaemon backendState recv send
175+ tid' <- forkIO $ peerDiscoveryDaemon backendState recv send
176176 return (tid', backendState)
177177 case mTransport of
178178 Left err -> throw err
179− Right transport ->
179+ Right transport ->
180180 let backend = Backend {
181− newLocalNode = apiNewLocalNode transport rtable backendState
181+ newLocalNode = apiNewLocalNode transport rtable backendState
182182 , findPeers = apiFindPeers send backendState
183− , redirectLogsHere = apiRedirectLogsHere backend
183+ , redirectLogsHere = apiRedirectLogsHere backend
184184 }
185185 in return backend
186186
187187-- | Create a new local node
188−apiNewLocalNode :: NT.Transport
189− -> RemoteTable
188+apiNewLocalNode :: NT.Transport
189+ -> RemoteTable
190190 -> MVar BackendState
191191 -> IO Node.LocalNode
192192apiNewLocalNode transport rtable backendState = do
193− localNode <- Node.newLocalNode transport rtable
193+ localNode <- Node.newLocalNode transport rtable
194194 modifyMVar_ backendState $ return . (localNodes ^: (localNode :))
195195 return localNode
196196
197197-- | Peer discovery
198−apiFindPeers :: (PeerDiscoveryMsg -> IO ())
199− -> MVar BackendState
198+apiFindPeers :: (PeerDiscoveryMsg -> IO ())
199+ -> MVar BackendState
200200 -> Int
201201 -> IO [NodeId]
202202apiFindPeers send backendState delay = do
203− send PeerDiscoveryRequest
204− threadDelay delay
205− Set.toList . (^. peers) <$> readMVar backendState
203+ send PeerDiscoveryRequest
204+ threadDelay delay
205+ Set.toList . (^. peers) <$> readMVar backendState
206206
207−data PeerDiscoveryMsg =
208− PeerDiscoveryRequest
207+data PeerDiscoveryMsg =
208+ PeerDiscoveryRequest
209209 | PeerDiscoveryReply NodeId
210210
211211instance Binary PeerDiscoveryMsg where
212212 put PeerDiscoveryRequest = putWord8 0
213213 put (PeerDiscoveryReply nid) = putWord8 1 >> put nid
214214 get = do
215− header <- getWord8
215+ header <- getWord8
216216 case header of
217217 0 -> return PeerDiscoveryRequest
218218 1 -> PeerDiscoveryReply <$> get
219219 _ -> fail "PeerDiscoveryMsg.get: invalid"
220220
221221-- | Respond to peer discovery requests sent by other nodes
222−peerDiscoveryDaemon :: MVar BackendState
222+peerDiscoveryDaemon :: MVar BackendState
223223 -> IO (PeerDiscoveryMsg, N.SockAddr)
224− -> (PeerDiscoveryMsg -> IO ())
224+ -> (PeerDiscoveryMsg -> IO ())
225225 -> IO ()
226226peerDiscoveryDaemon backendState recv send = forever go
227227 where
@@ -230,7 +230,7 @@ peerDiscoveryDaemon backendState recv send = forever go
230230 case msg of
231231 PeerDiscoveryRequest -> do
232232 nodes <- (^. localNodes) <$> readMVar backendState
233− forM_ nodes $ send . PeerDiscoveryReply . Node.localNodeId
233+ forM_ nodes $ send . PeerDiscoveryReply . Node.localNodeId
234234 PeerDiscoveryReply nid ->
235235 modifyMVar_ backendState $ return . (peers ^: Set.insert nid)
236236
@@ -243,7 +243,7 @@ apiRedirectLogsHere :: Backend -> Process ()
243243apiRedirectLogsHere backend = do
244244 mLogger <- whereis "logger"
245245 forM_ mLogger $ \logger -> do
246− nids <- liftIO $ findPeers backend 1000000
246+ nids <- liftIO $ findPeers backend 1000000
247247 forM_ nids $ \nid -> reregisterRemoteAsync nid "logger" logger -- ignore async response
248248
249249--------------------------------------------------------------------------------
@@ -254,12 +254,12 @@ apiRedirectLogsHere backend = do
254254--
255255-- This datatype is not exposed; instead, we expose primitives for dealing
256256-- with slaves.
257−data SlaveControllerMsg =
257+data SlaveControllerMsg =
258258 SlaveTerminate
259259 deriving (Typeable, Show)
260260
261261instance Binary SlaveControllerMsg where
262− put SlaveTerminate = putWord8 0
262+ put SlaveTerminate = putWord8 0
263263 get = do
264264 header <- getWord8
265265 case header of
@@ -273,8 +273,8 @@ instance Binary SlaveControllerMsg where
273273-- the process or call terminateSlave from another node.
274274startSlave :: Backend -> IO ()
275275startSlave backend = do
276− node <- newLocalNode backend
277− Node.runProcess node slaveController
276+ node <- newLocalNode backend
277+ Node.runProcess node slaveController
278278
279279-- | The slave controller interprets 'SlaveControllerMsg's
280280slaveController :: Process ()
@@ -295,26 +295,26 @@ terminateSlave nid = nsendRemote nid "slaveController" SlaveTerminate
295295-- | Find slave nodes
296296findSlaves :: Backend -> Process [NodeId]
297297findSlaves backend = do
298− nodes <- liftIO $ findPeers backend 1000000
298+ nodes <- liftIO $ findPeers backend 1000000
299299 -- Fire of asynchronous requests for the slave controller
300300 refs <- forM nodes $ \nid -> do
301− whereisRemoteAsync nid "slaveController"
301+ whereisRemoteAsync nid "slaveController"
302302 ref <- monitorNode nid
303303 return (nid, ref)
304304 -- Wait for the replies
305− catMaybes <$> replicateM (length nodes) (
306− receiveWait
305+ catMaybes <$> replicateM (length nodes) (
306+ receiveWait
307307 [ matchIf (\(WhereIsReply label _) -> label == "slaveController")
308− (\(WhereIsReply _ mPid) ->
308+ (\(WhereIsReply _ mPid) ->
309309 case mPid of
310− Nothing ->
310+ Nothing ->
311311 return Nothing
312312 Just pid -> do
313313 let nid = processNodeId pid
314314 Just ref = lookup nid refs
315− unmonitor ref
315+ unmonitor ref
316316 return (Just nid))
317− , match (\(NodeMonitorNotification {}) -> return Nothing)
317+ , match (\(NodeMonitorNotification {}) -> return Nothing)
318318 ])
319319
320320-- | Terminate all slaves
@@ -330,15 +330,15 @@ terminateAllSlaves backend = do
330330
331331-- | 'startMaster' finds all slaves /currently/ available on the local network,
332332-- redirects all log messages to itself, and then calls the specified process,
333−-- passing the list of slaves nodes.
333+-- passing the list of slaves nodes.
334334--
335335-- Terminates when the specified process terminates. If you want to terminate
336−-- the slaves when the master terminates, you should manually call
336+-- the slaves when the master terminates, you should manually call
337337-- 'terminateAllSlaves'.
338338--
339339-- If you start more slave nodes after having started the master node, you can
340340-- discover them with later calls to 'findSlaves', but be aware that you will
341−-- need to call 'redirectLogHere' to redirect their logs to the master node.
341+-- need to call 'redirectLogHere' to redirect their logs to the master node.
342342--
343343-- Note that you can use functionality of "SimpleLocalnet" directly (through
344344-- 'Backend'), instead of using 'startMaster'/'startSlave', if the master/slave
distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet/Internal/Multicast.hs+19−19
@@ -8,7 +8,7 @@ import qualified Data.Map as Map (empty)
88import Data.Binary (Binary, decode, encode)
99import Data.IORef (IORef, newIORef, readIORef, modifyIORef)
1010import qualified Data.ByteString as BSS (ByteString, concat)
11−import qualified Data.ByteString.Lazy as BSL
11+import qualified Data.ByteString.Lazy as BSL
1212 ( ByteString
1313 , empty
1414 , append
@@ -38,10 +38,10 @@ import Network.Multicast (multicastSender, multicastReceiver)
3838--
3939-- NOTE: By rights the two functions should be "locally" polymorphic in 'a',
4040-- but this requires impredicative types.
41−initMulticast :: forall a. Binary a
41+initMulticast :: forall a. Binary a
4242 => HostName -- ^ Multicast IP
4343 -> PortNumber -- ^ Port number
44− -> Int -- ^ Maximum message size
44+ -> Int -- ^ Maximum message size
4545 -> IO (IO (a, SockAddr), a -> IO ())
4646initMulticast host port bufferSize = do
4747 (sendSock, sendAddr) <- multicastSender host port
@@ -50,8 +50,8 @@ initMulticast host port bufferSize = do
5050 return (recvBinary readSock st bufferSize, writer sendSock sendAddr)
5151 where
5252 writer :: forall a. Binary a => Socket -> SockAddr -> a -> IO ()
53− writer sock addr val = do
54− let bytes = encode val
53+ writer sock addr val = do
54+ let bytes = encode val
5555 len = encodeInt32 (BSL.length bytes)
5656 NBS.sendManyTo sock (len : BSL.toChunks bytes) addr
5757
@@ -59,7 +59,7 @@ initMulticast host port bufferSize = do
5959-- UDP multicast read, dealing with multiple senders --
6060--------------------------------------------------------------------------------
6161
62−type UDPState = Map SockAddr BSL.ByteString
62+type UDPState = Map SockAddr BSL.ByteString
6363
6464#if MIN_VERSION_network(2,4,0)
6565-- network-2.4.0 provides the Ord instance for us
@@ -72,16 +72,16 @@ bufferFor :: SockAddr -> Accessor UDPState BSL.ByteString
7272bufferFor = DAC.mapDefault BSL.empty
7373
7474bufferAppend :: SockAddr -> BSS.ByteString -> UDPState -> UDPState
75−bufferAppend addr bytes =
76− bufferFor addr ^: flip BSL.append (BSL.fromChunks [bytes])
75+bufferAppend addr bytes =
76+ bufferFor addr ^: flip BSL.append (BSL.fromChunks [bytes])
7777
7878recvBinary :: Binary a => Socket -> IORef UDPState -> Int -> IO (a, SockAddr)
7979recvBinary sock st bufferSize = do
8080 (bytes, addr) <- recvWithLength sock st bufferSize
8181 return (decode bytes, addr)
8282
83−recvWithLength :: Socket
84− -> IORef UDPState
83+recvWithLength :: Socket
84+ -> IORef UDPState
8585 -> Int
8686 -> IO (BSL.ByteString, SockAddr)
8787recvWithLength sock st bufferSize = do
@@ -93,13 +93,13 @@ recvWithLength sock st bufferSize = do
9393-- Receive all bytes currently in the buffer
9494recvAll :: Socket -> IORef UDPState -> Int -> IO SockAddr
9595recvAll sock st bufferSize = do
96− (bytes, addr) <- NBS.recvFrom sock bufferSize
96+ (bytes, addr) <- NBS.recvFrom sock bufferSize
9797 modifyIORef st $ bufferAppend addr bytes
9898 return addr
99−
100−recvExact :: Socket
101− -> Int
102− -> IORef UDPState
99+
100+recvExact :: Socket
101+ -> Int
102+ -> IORef UDPState
103103 -> Int
104104 -> IO (BSL.ByteString, SockAddr)
105105recvExact sock n st bufferSize = do
@@ -113,16 +113,16 @@ recvExactFrom :: SockAddr
113113 -> IORef UDPState
114114 -> Int
115115 -> IO BSL.ByteString
116−recvExactFrom addr sock n st bufferSize = go
116+recvExactFrom addr sock n st bufferSize = go
117117 where
118118 go :: IO BSL.ByteString
119119 go = do
120− accAddr <- (^. bufferFor addr) <$> readIORef st
121− if BSL.length accAddr >= fromIntegral n
120+ accAddr <- (^. bufferFor addr) <$> readIORef st
121+ if BSL.length accAddr >= fromIntegral n
122122 then do
123123 let (bytes, accAddr') = BSL.splitAt (fromIntegral n) accAddr
124124 modifyIORef st $ bufferFor addr ^= accAddr'
125125 return bytes
126− else do
126+ else do
127127 _ <- recvAll sock st bufferSize
128128 go
distributed-process-simplelocalnet/tests/TestSimpleLocalnet.hs+3−3
@@ -15,10 +15,10 @@ main = do
1515
1616 case args of
1717 ["master", host, port] -> do
18− backend <- initializeBackend host port initRemoteTable
18+ backend <- initializeBackend host port initRemoteTable
1919 startMaster backend (master backend)
2020 ["slave", host, port] -> do
21− backend <- initializeBackend host port initRemoteTable
21+ backend <- initializeBackend host port initRemoteTable
2222 startSlave backend
23− _ ->
23+ _ ->
2424 putStrLn $ "usage: " ++ prog ++ " (master | slave) host port"
distributed-process-simplelocalnet/tests/runTestSimpleLocalnet.hs+4−4
@@ -1,11 +1,11 @@
11#!/bin/bash
22TestSimpleLocalnet=dist/build/TestSimpleLocalnet/TestSimpleLocalnet
3−$TestSimpleLocalnet slave 127.0.0.1 8080 &
3+$TestSimpleLocalnet slave 127.0.0.1 8080 &
44sleep 1
5−$TestSimpleLocalnet slave 127.0.0.1 8081 &
5+$TestSimpleLocalnet slave 127.0.0.1 8081 &
66sleep 1
7−$TestSimpleLocalnet slave 127.0.0.1 8082 &
7+$TestSimpleLocalnet slave 127.0.0.1 8082 &
88sleep 1
9−$TestSimpleLocalnet slave 127.0.0.1 8083 &
9+$TestSimpleLocalnet slave 127.0.0.1 8083 &
1010sleep 1
1111$TestSimpleLocalnet master 127.0.0.1 8084
distributed-process/benchmarks/Channels.hs+4−4
@@ -23,11 +23,11 @@ pingClient n them = do
2323 receiveChan rc
2424 liftIO . putStrLn $ "Did " ++ show n ++ " pings"
2525
26−initialProcess :: String -> Process ()
26+initialProcess :: String -> Process ()
2727initialProcess "SERVER" = do
2828 us <- getSelfPid
2929 liftIO $ BSL.writeFile "pingServer.pid" (encode us)
30− pingServer
30+ pingServer
3131initialProcess "CLIENT" = do
3232 n <- liftIO $ getLine
3333 them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"
@@ -37,5 +37,5 @@ main :: IO ()
3737main = do
3838 [role, host, port] <- getArgs
3939 Right transport <- createTransport host port defaultTCPParameters
40− node <- newLocalNode transport initRemoteTable
41− runProcess node $ initialProcess role
40+ node <- newLocalNode transport initRemoteTable
41+ runProcess node $ initialProcess role
distributed-process/benchmarks/Latency.hs+4−4
@@ -18,11 +18,11 @@ pingClient n them = do
1818 replicateM_ n $ send them us >> (expect :: Process ())
1919 liftIO . putStrLn $ "Did " ++ show n ++ " pings"
2020
21−initialProcess :: String -> Process ()
21+initialProcess :: String -> Process ()
2222initialProcess "SERVER" = do
2323 us <- getSelfPid
2424 liftIO $ BSL.writeFile "pingServer.pid" (encode us)
25− pingServer
25+ pingServer
2626initialProcess "CLIENT" = do
2727 n <- liftIO $ getLine
2828 them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"
@@ -32,5 +32,5 @@ main :: IO ()
3232main = do
3333 [role, host, port] <- getArgs
3434 Right transport <- createTransport host port defaultTCPParameters
35− node <- newLocalNode transport initRemoteTable
36− runProcess node $ initialProcess role
35+ node <- newLocalNode transport initRemoteTable
36+ runProcess node $ initialProcess role
distributed-process/benchmarks/Spawns.hs+4−4
@@ -12,7 +12,7 @@ import qualified Data.ByteString.Lazy as BSL
1212counter :: Process ()
1313counter = go 0
1414 where
15− go :: Int -> Process ()
15+ go :: Int -> Process ()
1616 go !n = do
1717 b <- expect
1818 case b of
@@ -27,7 +27,7 @@ count n them = do
2727 n' <- expect
2828 liftIO $ print (n == n')
2929
30−initialProcess :: String -> Process ()
30+initialProcess :: String -> Process ()
3131initialProcess "SERVER" = do
3232 us <- getSelfPid
3333 liftIO $ BSL.writeFile "counter.pid" (encode us)
@@ -41,5 +41,5 @@ main :: IO ()
4141main = do
4242 [role, host, port] <- getArgs
4343 Right transport <- createTransport host port defaultTCPParameters
44− node <- newLocalNode transport initRemoteTable
45− runProcess node $ initialProcess role
44+ node <- newLocalNode transport initRemoteTable
45+ runProcess node $ initialProcess role
distributed-process/benchmarks/Throughput.hs+7−7
@@ -14,8 +14,8 @@ data SizedList a = SizedList { size :: Int , elems :: [a] }
1414
1515instance Binary a => Binary (SizedList a) where
1616 put (SizedList sz xs) = put sz >> mapM_ put xs
17− get = do
18− sz <- get
17+ get = do
18+ sz <- get
1919 xs <- getMany sz
2020 return (SizedList sz xs)
2121
@@ -37,9 +37,9 @@ nats = \n -> SizedList n (aux n)
3737counter :: Process ()
3838counter = go 0
3939 where
40− go :: Int -> Process ()
40+ go :: Int -> Process ()
4141 go !n =
42− receiveWait
42+ receiveWait
4343 [ match $ \xs -> go (n + size (xs :: SizedList Int))
4444 , match $ \them -> send them n >> go 0
4545 ]
@@ -52,7 +52,7 @@ count (packets, sz) them = do
5252 n' <- expect
5353 liftIO $ print (packets * sz, n' == packets * sz)
5454
55−initialProcess :: String -> Process ()
55+initialProcess :: String -> Process ()
5656initialProcess "SERVER" = do
5757 us <- getSelfPid
5858 liftIO $ BSL.writeFile "counter.pid" (encode us)
@@ -66,5 +66,5 @@ main :: IO ()
6666main = do
6767 [role, host, port] <- getArgs
6868 Right transport <- createTransport host port defaultTCPParameters
69− node <- newLocalNode transport initRemoteTable
70− runProcess node $ initialProcess role
69+ node <- newLocalNode transport initRemoteTable
70+ runProcess node $ initialProcess role
distributed-process/benchmarks/remote/Latency.hs+3−3
@@ -18,15 +18,15 @@ pingClient n them = do
1818 replicateM_ n $ send them us >> (expect :: ProcessM ())
1919 liftIO . putStrLn $ "Did " ++ show n ++ " pings"
2020
21−initialProcess :: String -> ProcessM ()
21+initialProcess :: String -> ProcessM ()
2222initialProcess "SERVER" = do
2323 us <- getSelfPid
2424 liftIO $ BSL.writeFile "pingServer.pid" (encode us)
25− pingServer
25+ pingServer
2626initialProcess "CLIENT" = do
2727 n <- liftIO $ getLine
2828 them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"
2929 pingClient (read n) them
3030
3131main :: IO ()
32−main = remoteInit (Just "config") [] initialProcess
32+main = remoteInit (Just "config") [] initialProcess
distributed-process/benchmarks/remote/Throughput.hs+3−3
@@ -10,7 +10,7 @@ import Remote
1010counter :: ProcessM ()
1111counter = go 0
1212 where
13− go :: Int -> ProcessM ()
13+ go :: Int -> ProcessM ()
1414 go !n = do
1515 b <- expect
1616 case b of
@@ -25,7 +25,7 @@ count n them = do
2525 n' <- expect
2626 liftIO $ print (n == n')
2727
28−initialProcess :: String -> ProcessM ()
28+initialProcess :: String -> ProcessM ()
2929initialProcess "SERVER" = do
3030 us <- getSelfPid
3131 liftIO $ BSL.writeFile "counter.pid" (encode us)
@@ -36,4 +36,4 @@ initialProcess "CLIENT" = do
3636 count (read n) them
3737
3838main :: IO ()
39−main = remoteInit (Just "config") [] initialProcess
39+main = remoteInit (Just "config") [] initialProcess
distributed-process/src/Control/Distributed/Process.hs+42−42
@@ -1,14 +1,14 @@
11-- | [Cloud Haskell]
2−--
3−-- This is an implementation of Cloud Haskell, as described in
2+--
3+-- This is an implementation of Cloud Haskell, as described in
44-- /Towards Haskell in the Cloud/ by Jeff Epstein, Andrew Black, and Simon
55-- Peyton Jones
66-- (<http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/>),
77-- although some of the details are different. The precise message passing
88-- semantics are based on /A unified semantics for future Erlang/ by Hans
99-- Svensson, Lars-Åke Fredlund and Clara Benac Earle.
10−module Control.Distributed.Process
11− ( -- * Basic types
10+module Control.Distributed.Process
11+ ( -- * Basic types
1212 ProcessId
1313 , NodeId
1414 , Process
@@ -17,7 +17,7 @@ module Control.Distributed.Process
1717 , sendPortProcessId
1818 , liftIO -- Reexported for convenience
1919 -- * Basic messaging
20− , send
20+ , send
2121 , expect
2222 , expectTimeout
2323 -- * Channels
@@ -37,7 +37,7 @@ module Control.Distributed.Process
3737 , match
3838 , matchIf
3939 , matchUnknown
40− , AbstractMessage(..)
40+ , AbstractMessage(..)
4141 , matchAny
4242 -- * Process management
4343 , spawn
@@ -102,7 +102,7 @@ module Control.Distributed.Process
102102 , spawnMonitor
103103 , spawnChannel
104104 , DidSpawn(..)
105− -- * Local versions of 'spawn'
105+ -- * Local versions of 'spawn'
106106 , spawnLocal
107107 , spawnChannelLocal
108108 -- * Reconnecting
@@ -119,7 +119,7 @@ import Control.Monad.IO.Class (liftIO)
119119import Control.Applicative ((<$>))
120120import Control.Monad.Reader (ask)
121121import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
122−import Control.Distributed.Static
122+import Control.Distributed.Static
123123 ( Closure
124124 , closure
125125 , Static
@@ -127,7 +127,7 @@ import Control.Distributed.Static
127127 , closureCompose
128128 , staticClosure
129129 )
130−import Control.Distributed.Process.Internal.Types
130+import Control.Distributed.Process.Internal.Types
131131 ( NodeId(..)
132132 , ProcessId(..)
133133 , Process(..)
@@ -154,8 +154,8 @@ import Control.Distributed.Process.Internal.Closure.BuiltIn
154154 ( sdictSendPort
155155 , sndStatic
156156 , idCP
157− , seqCP
158− , bindCP
157+ , seqCP
158+ , bindCP
159159 , splitCP
160160 , cpLink
161161 , cpSend
@@ -164,7 +164,7 @@ import Control.Distributed.Process.Internal.Closure.BuiltIn
164164 )
165165import Control.Distributed.Process.Internal.Primitives
166166 ( -- Basic messaging
167− send
167+ send
168168 , expect
169169 -- Channels
170170 , newChan
@@ -179,7 +179,7 @@ import Control.Distributed.Process.Internal.Primitives
179179 , match
180180 , matchIf
181181 , matchUnknown
182− , AbstractMessage(..)
182+ , AbstractMessage(..)
183183 , matchAny
184184 -- Process management
185185 , terminate
@@ -231,7 +231,7 @@ import Control.Distributed.Process.Internal.Primitives
231231import Control.Distributed.Process.Node (forkProcess)
232232
233233-- INTERNAL NOTES
234−--
234+--
235235-- 1. 'send' never fails. If you want to know that the remote process received
236236-- your message, you will need to send an explicit acknowledgement. If you
237237-- want to know when the remote process failed, you will need to monitor
@@ -269,17 +269,17 @@ import Control.Distributed.Process.Node (forkProcess)
269269-- http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf
270270--
271271-- The precise semantics for message passing is based on
272−--
272+--
273273-- [2] "A Unified Semantics for Future Erlang", Hans Svensson, Lars-Ake Fredlund
274274-- and Clara Benac Earle (not freely available online, unfortunately)
275275--
276276-- Some pointers to related documentation about Erlang, for comparison and
277−-- inspiration:
277+-- inspiration:
278278--
279279-- [3] "Programming Distributed Erlang Applications: Pitfalls and Recipes",
280−-- Hans Svensson and Lars-Ake Fredlund
280+-- Hans Svensson and Lars-Ake Fredlund
281281-- http://man.lupaworld.com/content/develop/p37-svensson.pdf
282−-- [4] The Erlang manual, sections "Message Sending" and "Send"
282+-- [4] The Erlang manual, sections "Message Sending" and "Send"
283283-- http://www.erlang.org/doc/reference_manual/processes.html#id82409
284284-- http://www.erlang.org/doc/reference_manual/expressions.html#send
285285-- [5] Questions "Is the order of message reception guaranteed?" and
@@ -297,9 +297,9 @@ import Control.Distributed.Process.Node (forkProcess)
297297-- | Spawn a process
298298--
299299-- For more information about 'Closure', see
300−-- "Control.Distributed.Process.Closure".
300+-- "Control.Distributed.Process.Closure".
301301--
302−-- See also 'call'.
302+-- See also 'call'.
303303spawn :: NodeId -> Closure (Process ()) -> Process ProcessId
304304spawn nid proc = do
305305 us <- getSelfPid
@@ -316,7 +316,7 @@ spawn nid proc = do
316316
317317-- | Spawn a process and link to it
318318--
319−-- Note that this is just the sequential composition of 'spawn' and 'link'.
319+-- Note that this is just the sequential composition of 'spawn' and 'link'.
320320-- (The "Unified" semantics that underlies Cloud Haskell does not even support
321321-- a synchronous link operation)
322322spawnLink :: NodeId -> Closure (Process ()) -> Process ProcessId
@@ -333,16 +333,16 @@ spawnMonitor nid proc = do
333333 return (pid, ref)
334334
335335-- | Run a process remotely and wait for it to reply
336−--
336+--
337337-- We monitor the remote process: if it dies before it can send a reply, we die
338338-- too.
339339--
340340-- For more information about 'Static', 'SerializableDict', and 'Closure', see
341−-- "Control.Distributed.Process.Closure".
341+-- "Control.Distributed.Process.Closure".
342342--
343−-- See also 'spawn'.
343+-- See also 'spawn'.
344344call :: Serializable a => Static (SerializableDict a) -> NodeId -> Closure (Process a) -> Process a
345−call dict nid proc = do
345+call dict nid proc = do
346346 us <- getSelfPid
347347 (pid, mRef) <- spawnMonitor nid (proc `bindCP` cpSend dict us)
348348 -- We are guaranteed to receive the reply before the monitor notification
@@ -355,25 +355,25 @@ call dict nid proc = do
355355 ]
356356 case mResult of
357357 Right a -> do
358− -- Wait for the monitor message so that we the mailbox doesn't grow
359− receiveWait
358+ -- Wait for the monitor message so that we the mailbox doesn't grow
359+ receiveWait
360360 [ matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)
361361 (\(ProcessMonitorNotification {}) -> return ())
362362 ]
363363 -- Clean up connection to pid
364364 reconnect pid
365365 return a
366− Left err ->
367− fail $ "call: remote process died: " ++ show err
366+ Left err ->
367+ fail $ "call: remote process died: " ++ show err
368368
369369-- | Spawn a child process, have the child link to the parent and the parent
370370-- monitor the child
371−spawnSupervised :: NodeId
372− -> Closure (Process ())
371+spawnSupervised :: NodeId
372+ -> Closure (Process ())
373373 -> Process (ProcessId, MonitorRef)
374374spawnSupervised nid proc = do
375375 us <- getSelfPid
376− them <- spawn nid (cpLink us `seqCP` proc)
376+ them <- spawn nid (cpLink us `seqCP` proc)
377377 ref <- monitor them
378378 return (them, ref)
379379
@@ -381,19 +381,19 @@ spawnSupervised nid proc = do
381381-- the corresponding 'SendPort'.
382382spawnChannel :: forall a. Typeable a => Static (SerializableDict a)
383383 -> NodeId
384− -> Closure (ReceivePort a -> Process ())
384+ -> Closure (ReceivePort a -> Process ())
385385 -> Process (SendPort a)
386386spawnChannel dict nid proc = do
387387 us <- getSelfPid
388− spawn nid (go us)
388+ spawn nid (go us)
389389 expect
390390 where
391391 go :: ProcessId -> Closure (Process ())
392− go pid = cpNewChan dict
393− `bindCP`
392+ go pid = cpNewChan dict
393+ `bindCP`
394394 (cpSend (sdictSendPort dict) pid `splitCP` proc)
395395 `bindCP`
396− (idCP `closureCompose` staticClosure sndStatic)
396+ (idCP `closureCompose` staticClosure sndStatic)
397397
398398--------------------------------------------------------------------------------
399399-- Local versions of spawn --
@@ -402,16 +402,16 @@ spawnChannel dict nid proc = do
402402-- | Spawn a process on the local node
403403spawnLocal :: Process () -> Process ProcessId
404404spawnLocal proc = do
405− node <- processNode <$> ask
405+ node <- processNode <$> ask
406406 liftIO $ forkProcess node proc
407407
408408-- | Create a new typed channel, spawn a process on the local node, passing it
409409-- the receive port, and return the send port
410410spawnChannelLocal :: Serializable a
411− => (ReceivePort a -> Process ())
411+ => (ReceivePort a -> Process ())
412412 -> Process (SendPort a)
413−spawnChannelLocal proc = do
414− node <- processNode <$> ask
413+spawnChannelLocal proc = do
414+ node <- processNode <$> ask
415415 liftIO $ do
416416 mvar <- newEmptyMVar
417417 forkProcess node $ do
@@ -420,4 +420,4 @@ spawnChannelLocal proc = do
420420 (sport, rport) <- newChan
421421 liftIO $ putMVar mvar sport
422422 proc rport
423− takeMVar mvar
423+ takeMVar mvar
distributed-process/src/Control/Distributed/Process/Closure.hs+39−39
@@ -15,15 +15,15 @@
1515-- > f = ...
1616--
1717-- you can use a Template Haskell splice to create a static version of 'f':
18−--
18+--
1919-- > $(mkStatic 'f) :: forall a1 .. an. (Typeable a1, .., Typeable an) => Static T
20−--
20+--
2121-- Every module that you write that contains calls to 'mkStatic' needs to
2222-- have a call to 'remotable':
2323--
2424-- > remotable [ 'f, 'g, ... ]
2525--
26−-- where you must pass every function (or other value) that you pass as an
26+-- where you must pass every function (or other value) that you pass as an
2727-- argument to 'mkStatic'. The call to 'remotable' will create a definition
2828--
2929-- > __remoteTable :: RemoteTable -> RemoteTable
@@ -32,12 +32,12 @@
3232-- Cloud Haskell. You should have (at most) one call to 'remotable' per module,
3333-- and compose all created functions when initializing Cloud Haskell:
3434--
35−-- > let rtable :: RemoteTable
35+-- > let rtable :: RemoteTable
3636-- > rtable = M1.__remoteTable
3737-- > . M2.__remoteTable
3838-- > . ...
3939-- > . Mn.__remoteTable
40−-- > $ initRemoteTable
40+-- > $ initRemoteTable
4141--
4242-- NOTE: If you get a type error from ghc along these lines
4343--
@@ -52,19 +52,19 @@
5252--
5353-- > call :: Serializable a => Static (SerializableDict a) -> NodeId -> Closure (Process a) -> Process a
5454--
55−-- Given some serializable type 'T' you can define
55+-- Given some serializable type 'T' you can define
5656--
5757-- > sdictT :: SerializableDict T
5858-- > sdictT = SerializableDict
5959--
6060-- and then have
61−--
61+--
6262-- > $(mkStatic 'sdictT) :: Static (SerializableDict T)
6363--
6464-- However, since these dictionaries are so frequently required Cloud Haskell
6565-- provides special support for them. When you call 'remotable' on a
6666-- /monomorphic/ function @f :: T1 -> T2@
67−--
67+--
6868-- > remotable ['f]
6969--
7070-- then a serialization dictionary is automatically created for you, which you
@@ -80,26 +80,26 @@
8080--
8181-- Suppose you have a process
8282--
83−-- > isPrime :: Integer -> Process Bool
83+-- > isPrime :: Integer -> Process Bool
8484--
85−-- Then
85+-- Then
8686--
8787-- > $(mkClosure 'isPrime) :: Integer -> Closure (Process Bool)
8888--
89−-- which you can then 'call', for example, to have a remote node check if
89+-- which you can then 'call', for example, to have a remote node check if
9090-- a number is prime.
9191--
9292-- In general, if you have a /monomorphic/ function
9393--
9494-- > f :: T1 -> T2
95−--
95+--
9696-- then
9797--
9898-- > $(mkClosure 'f) :: T1 -> Closure T2
9999--
100100-- provided that 'T1' is serializable (*) (remember to pass 'f' to 'remotable').
101101--
102−-- (You can also create closures manually--see the documentation of
102+-- (You can also create closures manually--see the documentation of
103103-- "Control.Distributed.Static" for examples.)
104104--
105105-- [Example]
@@ -114,34 +114,34 @@
114114-- > import Control.Distributed.Process.Closure
115115-- > import Control.Distributed.Process.Backend.SimpleLocalnet
116116-- > import Control.Distributed.Process.Node (initRemoteTable)
117−-- >
117+-- >
118118-- > isPrime :: Integer -> Process Bool
119119-- > isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..]
120120-- > where
121121-- > sieve :: [Integer] -> [Integer]
122122-- > sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]
123−-- >
123+-- >
124124-- > remotable ['isPrime]
125−-- >
125+-- >
126126-- > master :: [NodeId] -> Process ()
127127-- > master [] = liftIO $ putStrLn "no slaves"
128128-- > master (slave:_) = do
129129-- > isPrime79 <- call $(functionTDict 'isPrime) slave ($(mkClosure 'isPrime) (79 :: Integer))
130−-- > liftIO $ print isPrime79
131−-- >
130+-- > liftIO $ print isPrime79
131+-- >
132132-- > main :: IO ()
133133-- > main = do
134134-- > args <- getArgs
135135-- > case args of
136136-- > ["master", host, port] -> do
137−-- > backend <- initializeBackend host port rtable
138−-- > startMaster backend master
137+-- > backend <- initializeBackend host port rtable
138+-- > startMaster backend master
139139-- > ["slave", host, port] -> do
140−-- > backend <- initializeBackend host port rtable
140+-- > backend <- initializeBackend host port rtable
141141-- > startSlave backend
142142-- > where
143143-- > rtable :: RemoteTable
144−-- > rtable = __remoteTable initRemoteTable
144+-- > rtable = __remoteTable initRemoteTable
145145--
146146-- [Notes]
147147--
@@ -150,34 +150,34 @@
150150-- a priori if 'T1' is serializable or not due to a bug in the Template
151151-- Haskell libraries (<http://hackage.haskell.org/trac/ghc/ticket/7066>)
152152--
153−-- (**) Even though 'call' is passed an explicit serialization
154−-- dictionary, we still need the 'Serializable' constraint because
153+-- (**) Even though 'call' is passed an explicit serialization
154+-- dictionary, we still need the 'Serializable' constraint because
155155-- 'Static' is not the /true/ static. If it was, we could 'unstatic'
156156-- the dictionary and pattern match on it to bring the 'Typeable'
157157-- instance into scope, but unless proper 'static' support is added to
158−-- ghc we need both the type class argument and the explicit dictionary.
159−module Control.Distributed.Process.Closure
158+-- ghc we need both the type class argument and the explicit dictionary.
159+module Control.Distributed.Process.Closure
160160 ( -- * Serialization dictionaries (and their static versions)
161161 SerializableDict(..)
162162 , staticDecode
163163 , sdictUnit
164164 , sdictProcessId
165165 , sdictSendPort
166− -- * The CP type and associated combinators
166+ -- * The CP type and associated combinators
167167 , CP
168168 , idCP
169169 , splitCP
170170 , returnCP
171− , bindCP
172− , seqCP
173− -- * CP versions of Cloud Haskell primitives
171+ , bindCP
172+ , seqCP
173+ -- * CP versions of Cloud Haskell primitives
174174 , cpLink
175175 , cpUnlink
176176 , cpSend
177177 , cpExpect
178178 , cpNewChan
179−#ifdef TemplateHaskellSupport
180− -- * Template Haskell support for creating static values and closures
179+#ifdef TemplateHaskellSupport
180+ -- * Template Haskell support for creating static values and closures
181181 , remotable
182182 , remotableDecl
183183 , mkStatic
@@ -185,7 +185,7 @@ module Control.Distributed.Process.Closure
185185 , functionSDict
186186 , functionTDict
187187#endif
188− ) where
188+ ) where
189189
190190import Control.Distributed.Process.Serializable (SerializableDict(..))
191191import Control.Distributed.Process.Internal.Closure.BuiltIn
@@ -194,22 +194,22 @@ import Control.Distributed.Process.Internal.Closure.BuiltIn
194194 , sdictUnit
195195 , sdictProcessId
196196 , sdictSendPort
197− -- The CP type and associated combinators
197+ -- The CP type and associated combinators
198198 , CP
199199 , idCP
200200 , splitCP
201201 , returnCP
202− , bindCP
203− , seqCP
204− -- CP versions of Cloud Haskell primitives
202+ , bindCP
203+ , seqCP
204+ -- CP versions of Cloud Haskell primitives
205205 , cpLink
206206 , cpUnlink
207207 , cpSend
208208 , cpExpect
209209 , cpNewChan
210210 )
211−#ifdef TemplateHaskellSupport
212−import Control.Distributed.Process.Internal.Closure.TH
211+#ifdef TemplateHaskellSupport
212+import Control.Distributed.Process.Internal.Closure.TH
213213 ( remotable
214214 , remotableDecl
215215 , mkStatic
distributed-process/src/Control/Distributed/Process/Internal/CQueue.hs+20−20
@@ -1,6 +1,6 @@
11-- | Concurrent queue for single reader, single writer
22{-# LANGUAGE MagicHash, UnboxedTuples #-}
3−module Control.Distributed.Process.Internal.CQueue
3+module Control.Distributed.Process.Internal.CQueue
44 ( CQueue
55 , BlockSpec(..)
66 , newCQueue
@@ -10,7 +10,7 @@ module Control.Distributed.Process.Internal.CQueue
1010 ) where
1111
1212import Prelude hiding (length, reverse)
13−import Control.Concurrent.STM
13+import Control.Concurrent.STM
1414 ( atomically
1515 , TChan
1616 , newTChan
@@ -21,7 +21,7 @@ import Control.Concurrent.STM
2121import Control.Applicative ((<$>), (<*>))
2222import Control.Exception (mask, onException)
2323import System.Timeout (timeout)
24−import Control.Distributed.Process.Internal.StrictMVar
24+import Control.Distributed.Process.Internal.StrictMVar
2525 ( StrictMVar(StrictMVar)
2626 , newMVar
2727 , takeMVar
@@ -33,7 +33,7 @@ import Control.Distributed.Process.Internal.StrictList
3333 , reverse'
3434 )
3535import GHC.MVar (MVar(MVar))
36−import GHC.IO (IO(IO))
36+import GHC.IO (IO(IO))
3737import GHC.Prim (mkWeak#)
3838import GHC.Weak (Weak(Weak))
3939
@@ -48,9 +48,9 @@ newCQueue = CQueue <$> newMVar Nil <*> atomically newTChan
4848--
4949-- Enqueue is strict.
5050enqueue :: CQueue a -> a -> IO ()
51−enqueue (CQueue _arrived incoming) !a = atomically $ writeTChan incoming a
51+enqueue (CQueue _arrived incoming) !a = atomically $ writeTChan incoming a
5252
53−data BlockSpec =
53+data BlockSpec =
5454 NonBlocking
5555 | Blocking
5656 | Timeout Int
@@ -59,35 +59,35 @@ data BlockSpec =
5959--
6060-- The timeout (if any) is applied only to waiting for incoming messages, not
6161-- to checking messages that have already arrived
62−dequeue :: forall a b.
62+dequeue :: forall a b.
6363 CQueue a -- ^ Queue
64− -> BlockSpec -- ^ Blocking behaviour
64+ -> BlockSpec -- ^ Blocking behaviour
6565 -> [a -> Maybe b] -- ^ List of matches
6666 -> IO (Maybe b) -- ^ 'Nothing' only on timeout
67−dequeue (CQueue arrived incoming) blockSpec matches = go
68− where
67+dequeue (CQueue arrived incoming) blockSpec matches = go
68+ where
6969 go :: IO (Maybe b)
7070 go = mask $ \restore -> do
71− arr <- takeMVar arrived
71+ arr <- takeMVar arrived
7272 -- We first check the arrived messages. If we get interrupted during this
7373 -- search, we just put the MVar back (we haven't read from the Chan yet)
7474 (arr', mb) <- onException (restore (checkArrived Nil arr))
75− (putMVar arrived arr)
75+ (putMVar arrived arr)
7676 case (mb, blockSpec) of
77− (Just b, _) -> do
77+ (Just b, _) -> do
7878 putMVar arrived arr'
7979 return (Just b)
8080 (Nothing, NonBlocking) ->
8181 checkNonBlocking arr'
8282 (Nothing, Blocking) ->
83− Just <$> checkBlocking arr'
83+ Just <$> checkBlocking arr'
8484 (Nothing, Timeout n) ->
8585 timeout n $ checkBlocking arr'
8686
8787 -- We reverse the accumulator on return only if we find a match
8888 checkArrived :: StrictList a -> StrictList a -> IO (StrictList a, Maybe b)
8989 checkArrived acc Nil = return (acc, Nothing)
90− checkArrived acc (Cons x xs) =
90+ checkArrived acc (Cons x xs) =
9191 case check x of
9292 Just y -> return (reverse' acc xs, Just y)
9393 Nothing -> checkArrived (Cons x acc) xs
@@ -95,15 +95,15 @@ dequeue (CQueue arrived incoming) blockSpec matches = go
9595 -- If we call checkBlocking there may or may not be a timeout
9696 checkBlocking :: StrictList a -> IO b
9797 checkBlocking acc = do
98− -- readTChan is a blocking call, and hence is interruptable. If it is
99− -- interrupted, we put the value of the accumulator in 'arrived'
98+ -- readTChan is a blocking call, and hence is interruptable. If it is
99+ -- interrupted, we put the value of the accumulator in 'arrived'
100100 -- (as opposed to the original value), so that no messages get lost
101101 -- (hence the low-level structure using mask rather than modifyMVar)
102102 x <- onException (atomically $ readTChan incoming)
103103 (putMVar arrived $ reverse acc)
104104 case check x of
105105 Nothing -> checkBlocking (Cons x acc)
106− Just y -> putMVar arrived (reverse acc) >> return y
106+ Just y -> putMVar arrived (reverse acc) >> return y
107107
108108 -- checkNonBlocking is only called if there is no timeout
109109 checkNonBlocking :: StrictList a -> IO (Maybe b)
@@ -115,9 +115,9 @@ dequeue (CQueue arrived incoming) blockSpec matches = go
115115 Just x -> case check x of
116116 Nothing -> checkNonBlocking (Cons x acc)
117117 Just y -> putMVar arrived (reverse acc) >> return (Just y)
118−
118+
119119 check :: a -> Maybe b
120− check = checkMatches matches
120+ check = checkMatches matches
121121
122122 checkMatches :: [a -> Maybe b] -> a -> Maybe b
123123 checkMatches [] _ = Nothing
distributed-process/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs+41−41
@@ -1,5 +1,5 @@
1−module Control.Distributed.Process.Internal.Closure.BuiltIn
2− ( -- * Remote table
1+module Control.Distributed.Process.Internal.Closure.BuiltIn
2+ ( -- * Remote table
33 remoteTable
44 -- * Static dictionaries and associated operations
55 , staticDecode
@@ -8,14 +8,14 @@ module Control.Distributed.Process.Internal.Closure.BuiltIn
88 , sdictSendPort
99 -- * Some static values
1010 , sndStatic
11− -- * The CP type and associated combinators
11+ -- * The CP type and associated combinators
1212 , CP
1313 , idCP
1414 , splitCP
1515 , returnCP
16− , bindCP
17− , seqCP
18− -- * CP versions of Cloud Haskell primitives
16+ , bindCP
17+ , seqCP
18+ -- * CP versions of Cloud Haskell primitives
1919 , cpLink
2020 , cpUnlink
2121 , cpSend
@@ -25,11 +25,11 @@ module Control.Distributed.Process.Internal.Closure.BuiltIn
2525 , cpDelay
2626 ) where
2727
28−import Data.ByteString.Lazy (ByteString)
28+import Data.ByteString.Lazy (ByteString)
2929import Data.Binary (decode, encode)
3030import Data.Rank1Typeable (Typeable, ANY, ANY1, ANY2, ANY3, ANY4)
3131import Data.Rank1Dynamic (toDynamic)
32−import Control.Distributed.Static
32+import Control.Distributed.Static
3333 ( RemoteTable
3434 , registerStatic
3535 , Static
@@ -42,18 +42,18 @@ import Control.Distributed.Static
4242 , staticCompose
4343 , staticClosure
4444 )
45−import Control.Distributed.Process.Serializable
45+import Control.Distributed.Process.Serializable
4646 ( SerializableDict(..)
4747 , Serializable
4848 )
49−import Control.Distributed.Process.Internal.Types
49+import Control.Distributed.Process.Internal.Types
5050 ( Process
5151 , ProcessId
5252 , SendPort
5353 , ReceivePort
5454 , ProcessMonitorNotification(ProcessMonitorNotification)
5555 )
56−import Control.Distributed.Process.Internal.Primitives
56+import Control.Distributed.Process.Internal.Primitives
5757 ( link
5858 , unlink
5959 , send
@@ -71,10 +71,10 @@ import Control.Distributed.Process.Internal.Primitives
7171--------------------------------------------------------------------------------
7272
7373remoteTable :: RemoteTable -> RemoteTable
74−remoteTable =
74+remoteTable =
7575 registerStatic "$decodeDict" (toDynamic (decodeDict :: SerializableDict ANY -> ByteString -> ANY))
7676 . registerStatic "$sdictUnit" (toDynamic (SerializableDict :: SerializableDict ()))
77− . registerStatic "$sdictProcessId" (toDynamic (SerializableDict :: SerializableDict ProcessId))
77+ . registerStatic "$sdictProcessId" (toDynamic (SerializableDict :: SerializableDict ProcessId))
7878 . registerStatic "$sdictSendPort_" (toDynamic (sdictSendPort_ :: SerializableDict ANY -> SerializableDict (SendPort ANY)))
7979 . registerStatic "$returnProcess" (toDynamic (return :: ANY -> Process ANY))
8080 . registerStatic "$seqProcess" (toDynamic ((>>) :: Process ANY1 -> Process ANY2 -> Process ANY2))
@@ -119,23 +119,23 @@ remoteTable =
119119-- See module documentation of "Control.Distributed.Process.Closure" for an
120120-- example.
121121staticDecode :: Typeable a => Static (SerializableDict a) -> Static (ByteString -> a)
122−staticDecode dict = decodeDictStatic `staticApply` dict
122+staticDecode dict = decodeDictStatic `staticApply` dict
123123 where
124124 decodeDictStatic :: Typeable a => Static (SerializableDict a -> ByteString -> a)
125125 decodeDictStatic = staticLabel "$decodeDict"
126126
127−-- | Serialization dictionary for '()'
127+-- | Serialization dictionary for '()'
128128sdictUnit :: Static (SerializableDict ())
129−sdictUnit = staticLabel "$sdictUnit"
129+sdictUnit = staticLabel "$sdictUnit"
130130
131−-- | Serialization dictionary for 'ProcessId'
131+-- | Serialization dictionary for 'ProcessId'
132132sdictProcessId :: Static (SerializableDict ProcessId)
133−sdictProcessId = staticLabel "$sdictProcessId"
133+sdictProcessId = staticLabel "$sdictProcessId"
134134
135135-- | Serialization dictionary for 'SendPort'
136−sdictSendPort :: Typeable a
136+sdictSendPort :: Typeable a
137137 => Static (SerializableDict a) -> Static (SerializableDict (SendPort a))
138−sdictSendPort = staticApply (staticLabel "$sdictSendPort_")
138+sdictSendPort = staticApply (staticLabel "$sdictSendPort_")
139139
140140--------------------------------------------------------------------------------
141141-- Static values --
@@ -154,20 +154,20 @@ type CP a b = Closure (a -> Process b)
154154returnProcessStatic :: Typeable a => Static (a -> Process a)
155155returnProcessStatic = staticLabel "$returnProcess"
156156
157−-- | 'CP' version of 'Control.Category.id'
157+-- | 'CP' version of 'Control.Category.id'
158158idCP :: Typeable a => CP a a
159159idCP = staticClosure returnProcessStatic
160160
161161-- | 'CP' version of ('Control.Arrow.***')
162−splitCP :: (Typeable a, Typeable b, Typeable c, Typeable d)
162+splitCP :: (Typeable a, Typeable b, Typeable c, Typeable d)
163163 => CP a c -> CP b d -> CP (a, b) (c, d)
164164splitCP p q = cpSplitStatic `closureApplyStatic` p `closureApply` q
165165 where
166166 cpSplitStatic :: Static ((a -> Process c) -> (b -> Process d) -> (a, b) -> Process (c, d))
167− cpSplitStatic = staticLabel "$cpSplit"
167+ cpSplitStatic = staticLabel "$cpSplit"
168168
169169-- | 'CP' version of 'Control.Monad.return'
170−returnCP :: forall a. Serializable a
170+returnCP :: forall a. Serializable a
171171 => Static (SerializableDict a) -> a -> Closure (Process a)
172172returnCP dict x = closure decoder (encode x)
173173 where
@@ -179,18 +179,18 @@ returnCP dict x = closure decoder (encode x)
179179-- | 'CP' version of ('Control.Monad.>>')
180180seqCP :: (Typeable a, Typeable b)
181181 => Closure (Process a) -> Closure (Process b) -> Closure (Process b)
182−seqCP p q = seqProcessStatic `closureApplyStatic` p `closureApply` q
182+seqCP p q = seqProcessStatic `closureApplyStatic` p `closureApply` q
183183 where
184184 seqProcessStatic :: (Typeable a, Typeable b)
185185 => Static (Process a -> Process b -> Process b)
186186 seqProcessStatic = staticLabel "$seqProcess"
187187
188−-- | (Not quite the) 'CP' version of ('Control.Monad.>>=')
188+-- | (Not quite the) 'CP' version of ('Control.Monad.>>=')
189189bindCP :: forall a b. (Typeable a, Typeable b)
190190 => Closure (Process a) -> CP a b -> Closure (Process b)
191−bindCP x f = bindProcessStatic `closureApplyStatic` x `closureApply` f
191+bindCP x f = bindProcessStatic `closureApplyStatic` x `closureApply` f
192192 where
193− bindProcessStatic :: (Typeable a, Typeable b)
193+ bindProcessStatic :: (Typeable a, Typeable b)
194194 => Static (Process a -> (a -> Process b) -> Process b)
195195 bindProcessStatic = staticLabel "$bindProcess"
196196
@@ -203,7 +203,7 @@ decodeProcessIdStatic = staticLabel "$decodeProcessId"
203203
204204-- | 'CP' version of 'link'
205205cpLink :: ProcessId -> Closure (Process ())
206−cpLink = closure (linkStatic `staticCompose` decodeProcessIdStatic) . encode
206+cpLink = closure (linkStatic `staticCompose` decodeProcessIdStatic) . encode
207207 where
208208 linkStatic :: Static (ProcessId -> Process ())
209209 linkStatic = staticLabel "$link"
@@ -216,18 +216,18 @@ cpUnlink = closure (unlinkStatic `staticCompose` decodeProcessIdStatic) . encode
216216 unlinkStatic = staticLabel "$unlink"
217217
218218-- | 'CP' version of 'send'
219−cpSend :: forall a. Typeable a
220− => Static (SerializableDict a) -> ProcessId -> CP a ()
219+cpSend :: forall a. Typeable a
220+ => Static (SerializableDict a) -> ProcessId -> CP a ()
221221cpSend dict pid = closure decoder (encode pid)
222222 where
223223 decoder :: Static (ByteString -> a -> Process ())
224224 decoder = (sendDictStatic `staticApply` dict)
225− `staticCompose`
226− decodeProcessIdStatic
225+ `staticCompose`
226+ decodeProcessIdStatic
227227
228− sendDictStatic :: Typeable a
228+ sendDictStatic :: Typeable a
229229 => Static (SerializableDict a -> ProcessId -> a -> Process ())
230− sendDictStatic = staticLabel "$sendDict"
230+ sendDictStatic = staticLabel "$sendDict"
231231
232232-- | 'CP' version of 'expect'
233233cpExpect :: Typeable a => Static (SerializableDict a) -> Closure (Process a)
@@ -237,14 +237,14 @@ cpExpect dict = staticClosure (expectDictStatic `staticApply` dict)
237237 expectDictStatic = staticLabel "$expectDict"
238238
239239-- | 'CP' version of 'newChan'
240−cpNewChan :: Typeable a
241− => Static (SerializableDict a)
240+cpNewChan :: Typeable a
241+ => Static (SerializableDict a)
242242 -> Closure (Process (SendPort a, ReceivePort a))
243243cpNewChan dict = staticClosure (newChanDictStatic `staticApply` dict)
244244 where
245− newChanDictStatic :: Typeable a
245+ newChanDictStatic :: Typeable a
246246 => Static (SerializableDict a -> Process (SendPort a, ReceivePort a))
247− newChanDictStatic = staticLabel "$newChanDict"
247+ newChanDictStatic = staticLabel "$newChanDict"
248248
249249--------------------------------------------------------------------------------
250250-- Support for spawn --
@@ -252,7 +252,7 @@ cpNewChan dict = staticClosure (newChanDictStatic `staticApply` dict)
252252
253253-- | @delay them p@ is a process that waits for a signal (a message of type @()@)
254254-- from 'them' (origin is not verified) before proceeding as @p@. In order to
255−-- avoid waiting forever, @delay them p@ monitors 'them'. If it receives a
255+-- avoid waiting forever, @delay them p@ monitors 'them'. If it receives a
256256-- monitor message instead it simply terminates.
257257delay :: ProcessId -> Process () -> Process ()
258258delay them p = do
@@ -269,7 +269,7 @@ cpDelay = closureApply . cpDelay'
269269 where
270270 cpDelay' :: ProcessId -> Closure (Process () -> Process ())
271271 cpDelay' pid = closure decoder (encode pid)
272−
272+
273273 decoder :: Static (ByteString -> Process () -> Process ())
274274 decoder = delayStatic `staticCompose` decodeProcessIdStatic
275275
distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs+56−56
@@ -1,6 +1,6 @@
11-- | Template Haskell support
22{-# LANGUAGE TemplateHaskell #-}
3−module Control.Distributed.Process.Internal.Closure.TH
3+module Control.Distributed.Process.Internal.Closure.TH
44 ( -- * User-level API
55 remotable
66 , remotableDecl
@@ -12,7 +12,7 @@ module Control.Distributed.Process.Internal.Closure.TH
1212
1313import Prelude hiding (succ, any)
1414import Control.Applicative ((<$>))
15−import Language.Haskell.TH
15+import Language.Haskell.TH
1616 ( -- Q monad and operations
1717 Q
1818 , reify
@@ -42,7 +42,7 @@ import Language.Haskell.TH
4242 , funD
4343 , sigD
4444 )
45−import Data.Maybe (catMaybes)
45+import Data.Maybe (catMaybes)
4646import Data.Binary (encode)
4747import Data.Generics (everywhereM, mkM, gmapM)
4848import Data.Rank1Dynamic (toDynamic)
@@ -51,7 +51,7 @@ import Data.Rank1Typeable
5151 , Succ
5252 , TypVar
5353 )
54−import Control.Distributed.Static
54+import Control.Distributed.Static
5555 ( RemoteTable
5656 , registerStatic
5757 , Static
@@ -60,7 +60,7 @@ import Control.Distributed.Static
6060 , staticCompose
6161 )
6262import Control.Distributed.Process.Internal.Types (Process)
63−import Control.Distributed.Process.Serializable
63+import Control.Distributed.Process.Serializable
6464 ( SerializableDict(SerializableDict)
6565 )
6666import Control.Distributed.Process.Internal.Closure.BuiltIn (staticDecode)
@@ -71,12 +71,12 @@ import Control.Distributed.Process.Internal.Closure.BuiltIn (staticDecode)
7171
7272-- | Create the closure, decoder, and metadata definitions for the given list
7373-- of functions
74−remotable :: [Name] -> Q [Dec]
74+remotable :: [Name] -> Q [Dec]
7575remotable ns = do
76− types <- mapM getType ns
77− (closures, inserts) <- unzip <$> mapM generateDefs types
76+ types <- mapM getType ns
77+ (closures, inserts) <- unzip <$> mapM generateDefs types
7878 rtable <- createMetaData (mkName "__remoteTable") (concat inserts)
79− return $ concat closures ++ rtable
79+ return $ concat closures ++ rtable
8080
8181-- | Like 'remotable', but parameterized by the declaration of a function
8282-- instead of the function name. So where for 'remotable' you'd do
@@ -106,9 +106,9 @@ remotableDecl :: [Q [Dec]] -> Q [Dec]
106106remotableDecl qDecs = do
107107 decs <- concat <$> sequence qDecs
108108 let types = catMaybes (map typeOf decs)
109− (closures, inserts) <- unzip <$> mapM generateDefs types
109+ (closures, inserts) <- unzip <$> mapM generateDefs types
110110 rtable <- createMetaData (mkName "__remoteTableDecl") (concat inserts)
111− return $ decs ++ concat closures ++ rtable
111+ return $ decs ++ concat closures ++ rtable
112112 where
113113 typeOf :: Dec -> Maybe (Name, Type)
114114 typeOf (SigD name typ) = Just (name, typ)
@@ -116,15 +116,15 @@ remotableDecl qDecs = do
116116
117117-- | Construct a static value.
118118--
119−-- If @f : forall a1 .. an. T@
120−-- then @$(mkStatic 'f) :: forall a1 .. an. Static T@.
121−-- Be sure to pass 'f' to 'remotable'.
119+-- If @f : forall a1 .. an. T@
120+-- then @$(mkStatic 'f) :: forall a1 .. an. Static T@.
121+-- Be sure to pass 'f' to 'remotable'.
122122mkStatic :: Name -> Q Exp
123123mkStatic = varE . staticName
124124
125−-- | If @f : T1 -> T2@ is a monomorphic function
125+-- | If @f : T1 -> T2@ is a monomorphic function
126126-- then @$(functionSDict 'f) :: Static (SerializableDict T1)@.
127−--
127+--
128128-- Be sure to pass 'f' to 'remotable'.
129129functionSDict :: Name -> Q Exp
130130functionSDict = varE . sdictName
@@ -136,13 +136,13 @@ functionSDict = varE . sdictName
136136functionTDict :: Name -> Q Exp
137137functionTDict = varE . tdictName
138138
139−-- | If @f : T1 -> T2@ then @$(mkClosure 'f) :: T1 -> Closure T2@.
139+-- | If @f : T1 -> T2@ then @$(mkClosure 'f) :: T1 -> Closure T2@.
140140--
141−-- TODO: The current version of mkClosure is too polymorphic
141+-- TODO: The current version of mkClosure is too polymorphic
142142-- (@forall a. Binary a => a -> Closure T2).
143143mkClosure :: Name -> Q Exp
144−mkClosure n =
145− [| closure ($(mkStatic n) `staticCompose` staticDecode $(functionSDict n))
144+mkClosure n =
145+ [| closure ($(mkStatic n) `staticCompose` staticDecode $(functionSDict n))
146146 . encode
147147 |]
148148
@@ -152,8 +152,8 @@ mkClosure n =
152152
153153-- | Generate the code to add the metadata to the CH runtime
154154createMetaData :: Name -> [Q Exp] -> Q [Dec]
155−createMetaData name is =
156− sequence [ sigD name [t| RemoteTable -> RemoteTable |]
155+createMetaData name is =
156+ sequence [ sigD name [t| RemoteTable -> RemoteTable |]
157157 , sfnD name (compose is)
158158 ]
159159
@@ -163,52 +163,52 @@ generateDefs (origName, fullType) = do
163163 let (typVars, typ') = case fullType of ForallT vars [] mono -> (vars, mono)
164164 _ -> ([], fullType)
165165
166− -- The main "static" entry
167− (static, register) <- makeStatic typVars typ'
168−
169− -- If n :: T1 -> T2, static serializable dictionary for T1
166+ -- The main "static" entry
167+ (static, register) <- makeStatic typVars typ'
168+
169+ -- If n :: T1 -> T2, static serializable dictionary for T1
170170 -- TODO: we should check if arg is an instance of Serializable, but we cannot
171171 -- http://hackage.haskell.org/trac/ghc/ticket/7066
172172 (sdict, registerSDict) <- case (typVars, typ') of
173− ([], ArrowT `AppT` arg `AppT` _res) ->
173+ ([], ArrowT `AppT` arg `AppT` _res) ->
174174 makeDict (sdictName origName) arg
175− _ ->
175+ _ ->
176176 return ([], [])
177−
177+
178178 -- If n :: T1 -> Process T2, static serializable dictionary for T2
179179 -- TODO: check if T2 is serializable (same as above)
180180 (tdict, registerTDict) <- case (typVars, typ') of
181− ([], ArrowT `AppT` _arg `AppT` (proc' `AppT` res)) | proc' == proc ->
182− makeDict (tdictName origName) res
181+ ([], ArrowT `AppT` _arg `AppT` (proc' `AppT` res)) | proc' == proc ->
182+ makeDict (tdictName origName) res
183183 _ ->
184184 return ([], [])
185−
185+
186186 return ( concat [static, sdict, tdict]
187187 , concat [register, registerSDict, registerTDict]
188188 )
189189 where
190190 makeStatic :: [TyVarBndr] -> Type -> Q ([Dec], [Q Exp])
191− makeStatic typVars typ = do
191+ makeStatic typVars typ = do
192192 static <- generateStatic origName typVars typ
193− let dyn = case typVars of
193+ let dyn = case typVars of
194194 [] -> [| toDynamic $(varE origName) |]
195195 _ -> [| toDynamic ($(varE origName) :: $(monomorphize typVars typ)) |]
196196 return ( static
197197 , [ [| registerStatic $(showFQN origName) $dyn |] ]
198198 )
199199
200− makeDict :: Name -> Type -> Q ([Dec], [Q Exp])
200+ makeDict :: Name -> Type -> Q ([Dec], [Q Exp])
201201 makeDict dictName typ = do
202− sdict <- generateDict dictName typ
202+ sdict <- generateDict dictName typ
203203 let dyn = [| toDynamic (SerializableDict :: SerializableDict $(return typ)) |]
204204 return ( sdict
205− , [ [| registerStatic $(showFQN dictName) $dyn |] ]
205+ , [ [| registerStatic $(showFQN dictName) $dyn |] ]
206206 )
207207
208208-- | Turn a polymorphic type into a monomorphic type using ANY and co
209209monomorphize :: [TyVarBndr] -> Type -> Q Type
210−monomorphize tvs =
211− let subst = zip (map tyVarBndrName tvs) anys
210+monomorphize tvs =
211+ let subst = zip (map tyVarBndrName tvs) anys
212212 in everywhereM (mkM (applySubst subst))
213213 where
214214 anys :: [Q Type]
@@ -219,34 +219,34 @@ monomorphize tvs =
219219
220220 zero :: Q Type
221221 zero = [t| Zero |]
222−
222+
223223 succ :: Q Type -> Q Type
224224 succ t = [t| Succ $t |]
225−
225+
226226 applySubst :: [(Name, Q Type)] -> Type -> Q Type
227− applySubst s (VarT n) =
228− case lookup n s of
227+ applySubst s (VarT n) =
228+ case lookup n s of
229229 Nothing -> return (VarT n)
230230 Just t -> t
231231 applySubst s t = gmapM (mkM (applySubst s)) t
232232
233−-- | Generate a static value
233+-- | Generate a static value
234234generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec]
235235generateStatic n xs typ = do
236236 staticTyp <- [t| Static |]
237237 sequence
238− [ sigD (staticName n) $
239− return (ForallT xs
240− (map typeable xs)
238+ [ sigD (staticName n) $
239+ return (ForallT xs
240+ (map typeable xs)
241241 (staticTyp `AppT` typ)
242242 )
243243 , sfnD (staticName n) [| staticLabel $(showFQN n) |]
244244 ]
245245 where
246246 typeable :: TyVarBndr -> Pred
247− typeable tv = ClassP (mkName "Typeable") [VarT (tyVarBndrName tv)]
247+ typeable tv = ClassP (mkName "Typeable") [VarT (tyVarBndrName tv)]
248248
249−-- | Generate a serialization dictionary with name 'n' for type 'typ'
249+-- | Generate a serialization dictionary with name 'n' for type 'typ'
250250generateDict :: Name -> Type -> Q [Dec]
251251generateDict n typ = do
252252 sequence
@@ -270,7 +270,7 @@ tdictName n = mkName $ nameBase n ++ "__tdict"
270270-- | Compose a set of expressions
271271compose :: [Q Exp] -> Q Exp
272272compose [] = [| id |]
273−compose [e] = e
273+compose [e] = e
274274compose (e:es) = [| $e . $(compose es) |]
275275
276276-- | Literal string as an expression
@@ -279,17 +279,17 @@ stringE = litE . stringL
279279
280280-- | Look up the "original name" (module:name) and type of a top-level function
281281getType :: Name -> Q (Name, Type)
282−getType name = do
282+getType name = do
283283 info <- reify name
284− case info of
284+ case info of
285285 VarI origName typ _ _ -> return (origName, typ)
286286 _ -> fail $ show name ++ " not found"
287287
288288-- | Variation on 'funD' which takes a single expression to define the function
289289sfnD :: Name -> Q Exp -> Q Dec
290−sfnD n e = funD n [clause [] (normalB e) []]
291−
292−-- | The name of a type variable binding occurrence
290+sfnD n e = funD n [clause [] (normalB e) []]
291+
292+-- | The name of a type variable binding occurrence
293293tyVarBndrName :: TyVarBndr -> Name
294294tyVarBndrName (PlainTV n) = n
295295tyVarBndrName (KindedTV n _) = n
@@ -299,7 +299,7 @@ tyVarBndrName (KindedTV n _) = n
299299-- We ignore the module part of the Name argument (which may or may not exist)
300300-- because we construct various names (`staticName`, `sdictName`, `tdictName`)
301301-- and those names certainly won't have Module components.
302−showFQN :: Name -> Q Exp
302+showFQN :: Name -> Q Exp
303303showFQN n = do
304304 loc <- location
305305 stringE (loc_module loc ++ "." ++ nameBase n)
distributed-process/src/Control/Distributed/Process/Internal/Messaging.hs+42−42
@@ -2,8 +2,8 @@ module Control.Distributed.Process.Internal.Messaging
22 ( sendPayload
33 , sendBinary
44 , sendMessage
5− , disconnect
6− , closeImplicitReconnections
5+ , disconnect
6+ , closeImplicitReconnections
77 , impliesDeathOf
88 ) where
99
@@ -15,7 +15,7 @@ import qualified Data.ByteString as BSS (ByteString)
1515import Control.Distributed.Process.Internal.StrictMVar (withMVar, modifyMVar_)
1616import Control.Concurrent.Chan (writeChan)
1717import Control.Monad (unless)
18−import qualified Network.Transport as NT
18+import qualified Network.Transport as NT
1919 ( Connection
2020 , send
2121 , defaultConnectHints
@@ -23,7 +23,7 @@ import qualified Network.Transport as NT
2323 , Reliability(ReliableOrdered)
2424 , close
2525 )
26−import Control.Distributed.Process.Internal.Types
26+import Control.Distributed.Process.Internal.Types
2727 ( LocalNode(localState, localEndPoint, localCtrlChan)
2828 , Identifier
2929 , localConnections
@@ -44,14 +44,14 @@ import Control.Distributed.Process.Internal.Types
4444import Control.Distributed.Process.Serializable (Serializable)
4545
4646--------------------------------------------------------------------------------
47−-- Message sending --
47+-- Message sending --
4848--------------------------------------------------------------------------------
4949
50−sendPayload :: LocalNode
50+sendPayload :: LocalNode
5151 -> Identifier
5252 -> Identifier
5353 -> ImplicitReconnect
54− -> [BSS.ByteString]
54+ -> [BSS.ByteString]
5555 -> IO ()
5656sendPayload node from to implicitReconnect payload = do
5757 mConn <- connBetween node from to implicitReconnect
@@ -59,53 +59,53 @@ sendPayload node from to implicitReconnect payload = do
5959 Just conn -> do
6060 didSend <- NT.send conn payload
6161 case didSend of
62− Left _err -> return False
63− Right () -> return True
62+ Left _err -> return False
63+ Right () -> return True
6464 Nothing -> return False
6565 unless didSend $ do
6666 writeChan (localCtrlChan node) NCMsg
67− { ctrlMsgSender = to
67+ { ctrlMsgSender = to
6868 , ctrlMsgSignal = Died to DiedDisconnect
6969 }
7070
71−sendBinary :: Binary a
72− => LocalNode
73− -> Identifier
74− -> Identifier
71+sendBinary :: Binary a
72+ => LocalNode
73+ -> Identifier
74+ -> Identifier
7575 -> ImplicitReconnect
76− -> a
76+ -> a
7777 -> IO ()
78−sendBinary node from to implicitReconnect
78+sendBinary node from to implicitReconnect
7979 = sendPayload node from to implicitReconnect . BSL.toChunks . encode
8080
81−sendMessage :: Serializable a
82− => LocalNode
83− -> Identifier
84− -> Identifier
81+sendMessage :: Serializable a
82+ => LocalNode
83+ -> Identifier
84+ -> Identifier
8585 -> ImplicitReconnect
86− -> a
86+ -> a
8787 -> IO ()
88−sendMessage node from to implicitReconnect =
88+sendMessage node from to implicitReconnect =
8989 sendPayload node from to implicitReconnect . messageToPayload . createMessage
9090
91−setupConnBetween :: LocalNode
92− -> Identifier
93− -> Identifier
94− -> ImplicitReconnect
91+setupConnBetween :: LocalNode
92+ -> Identifier
93+ -> Identifier
94+ -> ImplicitReconnect
9595 -> IO (Maybe NT.Connection)
9696setupConnBetween node from to implicitReconnect = do
97− mConn <- NT.connect endPoint
98− (nodeAddress . nodeOf $ to)
99− NT.ReliableOrdered
97+ mConn <- NT.connect endPoint
98+ (nodeAddress . nodeOf $ to)
99+ NT.ReliableOrdered
100100 NT.defaultConnectHints
101− case mConn of
101+ case mConn of
102102 Right conn -> do
103103 didSend <- NT.send conn (BSL.toChunks . encode $ to)
104104 case didSend of
105105 Left _ ->
106106 return Nothing
107107 Right () -> do
108− modifyMVar_ nodeState $ return .
108+ modifyMVar_ nodeState $ return .
109109 (localConnectionBetween from to ^= Just (conn, implicitReconnect))
110110 return $ Just conn
111111 Left _ ->
@@ -114,33 +114,33 @@ setupConnBetween node from to implicitReconnect = do
114114 endPoint = localEndPoint node
115115 nodeState = localState node
116116
117−connBetween :: LocalNode
118− -> Identifier
119− -> Identifier
117+connBetween :: LocalNode
118+ -> Identifier
119+ -> Identifier
120120 -> ImplicitReconnect
121121 -> IO (Maybe NT.Connection)
122122connBetween node from to implicitReconnect = do
123123 mConn <- withMVar nodeState $ return . (^. localConnectionBetween from to)
124124 case mConn of
125− Just (conn, _) ->
125+ Just (conn, _) ->
126126 return $ Just conn
127− Nothing ->
128− setupConnBetween node from to implicitReconnect
127+ Nothing ->
128+ setupConnBetween node from to implicitReconnect
129129 where
130130 nodeState = localState node
131131
132132disconnect :: LocalNode -> Identifier -> Identifier -> IO ()
133133disconnect node from to =
134− modifyMVar_ (localState node) $ \st ->
134+ modifyMVar_ (localState node) $ \st ->
135135 case st ^. localConnectionBetween from to of
136− Nothing ->
136+ Nothing ->
137137 return st
138138 Just (conn, _) -> do
139− NT.close conn
139+ NT.close conn
140140 return (localConnectionBetween from to ^= Nothing $ st)
141141
142142closeImplicitReconnections :: LocalNode -> Identifier -> IO ()
143−closeImplicitReconnections node to =
143+closeImplicitReconnections node to =
144144 modifyMVar_ (localState node) $ \st -> do
145145 let shouldClose (_, to') (_, WithImplicitReconnect) = to `impliesDeathOf` to'
146146 shouldClose _ _ = False
@@ -153,7 +153,7 @@ closeImplicitReconnections node to =
153153impliesDeathOf :: Identifier
154154 -> Identifier
155155 -> Bool
156−NodeIdentifier nid `impliesDeathOf` NodeIdentifier nid' =
156+NodeIdentifier nid `impliesDeathOf` NodeIdentifier nid' =
157157 nid' == nid
158158NodeIdentifier nid `impliesDeathOf` ProcessIdentifier pid =
159159 processNodeId pid == nid
distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+93−93
@@ -1,10 +1,10 @@
11-- | Cloud Haskell primitives
22--
3−-- We define these in a separate module so that we don't have to rely on
3+-- We define these in a separate module so that we don't have to rely on
44-- the closure combinators
5−module Control.Distributed.Process.Internal.Primitives
5+module Control.Distributed.Process.Internal.Primitives
66 ( -- * Basic messaging
7− send
7+ send
88 , expect
99 -- * Channels
1010 , newChan
@@ -19,7 +19,7 @@ module Control.Distributed.Process.Internal.Primitives
1919 , match
2020 , matchIf
2121 , matchUnknown
22− , AbstractMessage(..)
22+ , AbstractMessage(..)
2323 , matchAny
2424 -- * Process management
2525 , terminate
@@ -84,13 +84,13 @@ import Control.Monad.IO.Class (MonadIO, liftIO)
8484import Control.Applicative ((<$>))
8585import Control.Exception (Exception, throwIO, SomeException)
8686import qualified Control.Exception as Ex (catch, mask)
87−import Control.Distributed.Process.Internal.StrictMVar
87+import Control.Distributed.Process.Internal.StrictMVar
8888 ( StrictMVar
8989 , modifyMVar
9090 , modifyMVar_
9191 )
9292import Control.Concurrent.Chan (writeChan)
93−import Control.Concurrent.STM
93+import Control.Concurrent.STM
9494 ( STM
9595 , TVar
9696 , atomically
@@ -105,7 +105,7 @@ import Data.Accessor ((^.), (^:), (^=))
105105import Control.Distributed.Static (Closure, Static)
106106import Data.Rank1Typeable (Typeable)
107107import qualified Control.Distributed.Static as Static (unstatic, unclosure)
108−import Control.Distributed.Process.Internal.Types
108+import Control.Distributed.Process.Internal.Types
109109 ( NodeId(..)
110110 , ProcessId(..)
111111 , LocalNode(..)
@@ -116,7 +116,7 @@ import Control.Distributed.Process.Internal.Types
116116 , SpawnRef(..)
117117 , NCMsg(..)
118118 , ProcessSignal(..)
119− , monitorCounter
119+ , monitorCounter
120120 , spawnCounter
121121 , SendPort(..)
122122 , ReceivePort(..)
@@ -139,13 +139,13 @@ import Control.Distributed.Process.Internal.Types
139139 , LocalSendPortId
140140 , messageToPayload
141141 )
142−import Control.Distributed.Process.Internal.Messaging
142+import Control.Distributed.Process.Internal.Messaging
143143 ( sendMessage
144144 , sendBinary
145145 , sendPayload
146146 , disconnect
147− )
148−import Control.Distributed.Process.Internal.WeakTQueue
147+ )
148+import Control.Distributed.Process.Internal.WeakTQueue
149149 ( newTQueueIO
150150 , readTQueue
151151 , mkWeakTQueue
@@ -160,16 +160,16 @@ send :: Serializable a => ProcessId -> a -> Process ()
160160-- This requires a lookup on every send. If we want to avoid that we need to
161161-- modify serializable to allow for stateful (IO) deserialization
162162send them msg = do
163− proc <- ask
164− liftIO $ sendMessage (processNode proc)
165− (ProcessIdentifier (processId proc))
163+ proc <- ask
164+ liftIO $ sendMessage (processNode proc)
165+ (ProcessIdentifier (processId proc))
166166 (ProcessIdentifier them)
167167 NoImplicitReconnect
168168 msg
169169
170170-- | Wait for a message of a specific type
171171expect :: forall a. Serializable a => Process a
172−expect = receiveWait [match return]
172+expect = receiveWait [match return]
173173
174174--------------------------------------------------------------------------------
175175-- Channels --
@@ -178,17 +178,17 @@ expect = receiveWait [match return]
178178-- | Create a new typed channel
179179newChan :: Serializable a => Process (SendPort a, ReceivePort a)
180180newChan = do
181− proc <- ask
181+ proc <- ask
182182 liftIO . modifyMVar (processState proc) $ \st -> do
183183 let lcid = st ^. channelCounter
184184 let cid = SendPortId { sendPortProcessId = processId proc
185185 , sendPortLocalId = lcid
186186 }
187− let sport = SendPort cid
187+ let sport = SendPort cid
188188 chan <- liftIO newTQueueIO
189189 chan' <- mkWeakTQueue chan $ finalizer (processState proc) lcid
190190 let rport = ReceivePort $ readTQueue chan
191− let tch = TypedChannel chan'
191+ let tch = TypedChannel chan'
192192 return ( (channelCounter ^: (+ 1))
193193 . (typedChannelWithId lcid ^= Just tch)
194194 $ st
@@ -196,7 +196,7 @@ newChan = do
196196 )
197197 where
198198 finalizer :: StrictMVar LocalProcessState -> LocalSendPortId -> IO ()
199− finalizer st lcid = modifyMVar_ st $
199+ finalizer st lcid = modifyMVar_ st $
200200 return . (typedChannelWithId lcid ^= Nothing)
201201
202202-- | Send a message on a typed channel
@@ -205,24 +205,24 @@ sendChan (SendPort cid) msg = do
205205 proc <- ask
206206 liftIO $ sendBinary (processNode proc)
207207 (ProcessIdentifier (processId proc))
208− (SendPortIdentifier cid)
208+ (SendPortIdentifier cid)
209209 NoImplicitReconnect
210− msg
210+ msg
211211
212212-- | Wait for a message on a typed channel
213213receiveChan :: Serializable a => ReceivePort a -> Process a
214−receiveChan = liftIO . atomically . receiveSTM
214+receiveChan = liftIO . atomically . receiveSTM
215215
216−-- | Like 'receiveChan' but with a timeout. If the timeout is 0, do a
216+-- | Like 'receiveChan' but with a timeout. If the timeout is 0, do a
217217-- non-blocking check for a message.
218218receiveChanTimeout :: Serializable a => Int -> ReceivePort a -> Process (Maybe a)
219−receiveChanTimeout 0 ch = liftIO . atomically $
219+receiveChanTimeout 0 ch = liftIO . atomically $
220220 (Just <$> receiveSTM ch) `orElse` return Nothing
221−receiveChanTimeout n ch = liftIO . timeout n . atomically $
221+receiveChanTimeout n ch = liftIO . timeout n . atomically $
222222 receiveSTM ch
223223
224224-- | Merge a list of typed channels.
225−--
225+--
226226-- The result port is left-biased: if there are messages available on more
227227-- than one port, the first available message is returned.
228228mergePortsBiased :: Serializable a => [ReceivePort a] -> Process (ReceivePort a)
@@ -233,7 +233,7 @@ mergePortsBiased = return . ReceivePort. foldr1 orElse . map receiveSTM
233233mergePortsRR :: Serializable a => [ReceivePort a] -> Process (ReceivePort a)
234234mergePortsRR = \ps -> do
235235 psVar <- liftIO . atomically $ newTVar (map receiveSTM ps)
236− return $ ReceivePort (rr psVar)
236+ return $ ReceivePort (rr psVar)
237237 where
238238 rotate :: [a] -> [a]
239239 rotate [] = []
@@ -242,12 +242,12 @@ mergePortsRR = \ps -> do
242242 rr :: TVar [STM a] -> STM a
243243 rr psVar = do
244244 ps <- readTVar psVar
245− a <- foldr1 orElse ps
245+ a <- foldr1 orElse ps
246246 writeTVar psVar (rotate ps)
247247 return a
248248
249249--------------------------------------------------------------------------------
250−-- Advanced messaging --
250+-- Advanced messaging --
251251--------------------------------------------------------------------------------
252252
253253-- | Opaque type used in 'receiveWait' and 'receiveTimeout'
@@ -261,7 +261,7 @@ receiveWait ms = do
261261 proc
262262
263263-- | Like 'receiveWait' but with a timeout.
264−--
264+--
265265-- If the timeout is zero do a non-blocking check for matching messages. A
266266-- non-zero timeout is applied only when waiting for incoming messages (that is,
267267-- /after/ we have checked the messages that are already in the mailbox).
@@ -276,16 +276,16 @@ receiveTimeout t ms = do
276276
277277-- | Match against any message of the right type
278278match :: forall a b. Serializable a => (a -> Process b) -> Match b
279−match = matchIf (const True)
279+match = matchIf (const True)
280280
281281-- | Match against any message of the right type that satisfies a predicate
282282matchIf :: forall a b. Serializable a => (a -> Bool) -> (a -> Process b) -> Match b
283−matchIf c p = Match $ \msg ->
283+matchIf c p = Match $ \msg ->
284284 case messageFingerprint msg == fingerprint (undefined :: a) of
285285 True | c decoded -> Just (p decoded)
286286 where
287287 decoded :: a
288− -- Make sure the value is fully decoded so that we don't hang to
288+ -- Make sure the value is fully decoded so that we don't hang to
289289 -- bytestrings when the process calling 'matchIf' doesn't process
290290 -- the values immediately
291291 !decoded = decode (messageEncoding msg)
@@ -298,7 +298,7 @@ data AbstractMessage = AbstractMessage {
298298-- | Match against an arbitrary message
299299matchAny :: forall b. (AbstractMessage -> Process b) -> Match b
300300matchAny p = Match $ Just . p . abstract
301− where
301+ where
302302 abstract :: Message -> AbstractMessage
303303 abstract msg = AbstractMessage {
304304 forward = \them -> do
@@ -306,7 +306,7 @@ matchAny p = Match $ Just . p . abstract
306306 liftIO $ sendPayload (processNode proc)
307307 (ProcessIdentifier (processId proc))
308308 (ProcessIdentifier them)
309− NoImplicitReconnect
309+ NoImplicitReconnect
310310 (messageToPayload msg)
311311 }
312312
@@ -330,11 +330,11 @@ terminate = liftIO $ throwIO ProcessTerminationException
330330
331331-- | Our own process ID
332332getSelfPid :: Process ProcessId
333−getSelfPid = processId <$> ask
333+getSelfPid = processId <$> ask
334334
335335-- | Get the node ID of our local node
336336getSelfNode :: Process NodeId
337−getSelfNode = localNodeId . processNode <$> ask
337+getSelfNode = localNodeId . processNode <$> ask
338338
339339--------------------------------------------------------------------------------
340340-- Monitoring and linking --
@@ -354,7 +354,7 @@ getSelfNode = localNodeId . processNode <$> ask
354354-- > unlink pidB -- Unlink again
355355--
356356-- doesn't quite do what one might expect: if process B sends a message to
357−-- process A, and /subsequently terminates/, then process A might or might not
357+-- process A, and /subsequently terminates/, then process A might or might not
358358-- be terminated too, depending on whether the exception is thrown before or
359359-- after the 'unlink' (i.e., this code has a race condition).
360360--
@@ -369,7 +369,7 @@ link = sendCtrlMsg Nothing . Link . ProcessIdentifier
369369
370370-- | Monitor another process (asynchronous)
371371--
372−-- When process A monitors process B (that is, process A calls
372+-- When process A monitors process B (that is, process A calls
373373-- @monitor pidB@) then process A will receive a 'ProcessMonitorNotification'
374374-- when process B terminates (normally or abnormally), or when process A gets
375375-- disconnected from process B. You receive this message like any other (using
@@ -377,27 +377,27 @@ link = sendCtrlMsg Nothing . Link . ProcessIdentifier
377377-- 'DiedDisconnect', etc.).
378378--
379379-- Every call to 'monitor' returns a new monitor reference 'MonitorRef'; if
380−-- multiple monitors are set up, multiple notifications will be delivered
380+-- multiple monitors are set up, multiple notifications will be delivered
381381-- and monitors can be disabled individually using 'unmonitor'.
382−monitor :: ProcessId -> Process MonitorRef
383−monitor = monitor' . ProcessIdentifier
382+monitor :: ProcessId -> Process MonitorRef
383+monitor = monitor' . ProcessIdentifier
384384
385−-- | Remove a link
385+-- | Remove a link
386386--
387387-- This is synchronous in the sense that once it returns you are guaranteed
388388-- that no exception will be raised if the remote process dies. However, it is
389−-- asynchronous in the sense that we do not wait for a response from the remote
389+-- asynchronous in the sense that we do not wait for a response from the remote
390390-- node.
391391unlink :: ProcessId -> Process ()
392392unlink pid = do
393393 unlinkAsync pid
394− receiveWait [ matchIf (\(DidUnlinkProcess pid') -> pid' == pid)
395− (\_ -> return ())
394+ receiveWait [ matchIf (\(DidUnlinkProcess pid') -> pid' == pid)
395+ (\_ -> return ())
396396 ]
397397
398−-- | Remove a node link
398+-- | Remove a node link
399399--
400−-- This has the same synchronous/asynchronous nature as 'unlink'.
400+-- This has the same synchronous/asynchronous nature as 'unlink'.
401401unlinkNode :: NodeId -> Process ()
402402unlinkNode nid = do
403403 unlinkNodeAsync nid
@@ -407,7 +407,7 @@ unlinkNode nid = do
407407
408408-- | Remove a channel (send port) link
409409--
410−-- This has the same synchronous/asynchronous nature as 'unlink'.
410+-- This has the same synchronous/asynchronous nature as 'unlink'.
411411unlinkPort :: SendPort a -> Process ()
412412unlinkPort sport = do
413413 unlinkPortAsync sport
@@ -415,9 +415,9 @@ unlinkPort sport = do
415415 (\_ -> return ())
416416 ]
417417
418−-- | Remove a monitor
418+-- | Remove a monitor
419419--
420−-- This has the same synchronous/asynchronous nature as 'unlink'.
420+-- This has the same synchronous/asynchronous nature as 'unlink'.
421421unmonitor :: MonitorRef -> Process ()
422422unmonitor ref = do
423423 unmonitorAsync ref
@@ -433,11 +433,11 @@ unmonitor ref = do
433433catch :: Exception e => Process a -> (e -> Process a) -> Process a
434434catch p h = do
435435 lproc <- ask
436− liftIO $ Ex.catch (runLocalProcess lproc p) (runLocalProcess lproc . h)
436+ liftIO $ Ex.catch (runLocalProcess lproc p) (runLocalProcess lproc . h)
437437
438−-- | Lift 'Control.Exception.mask'
438+-- | Lift 'Control.Exception.mask'
439439mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b
440−mask p = do
440+mask p = do
441441 lproc <- ask
442442 liftIO $ Ex.mask $ \restore ->
443443 runLocalProcess lproc (p (liftRestore lproc restore))
@@ -465,7 +465,7 @@ bracket_ before after thing = bracket before (const after) (const thing)
465465
466466-- | Lift 'Control.Exception.finally'
467467finally :: Process a -> Process b -> Process a
468−finally a sequel = bracket_ (return ()) sequel a
468+finally a sequel = bracket_ (return ()) sequel a
469469
470470--------------------------------------------------------------------------------
471471-- Auxiliary API --
@@ -473,10 +473,10 @@ finally a sequel = bracket_ (return ()) sequel a
473473
474474-- | Like 'expect' but with a timeout
475475expectTimeout :: forall a. Serializable a => Int -> Process (Maybe a)
476−expectTimeout n = receiveTimeout n [match return]
476+expectTimeout n = receiveTimeout n [match return]
477477
478478-- | Asynchronous version of 'spawn'
479−--
479+--
480480-- ('spawn' is defined in terms of 'spawnAsync' and 'expect')
481481spawnAsync :: NodeId -> Closure (Process ()) -> Process SpawnRef
482482spawnAsync nid proc = do
@@ -486,41 +486,41 @@ spawnAsync nid proc = do
486486
487487-- | Monitor a node (asynchronous)
488488monitorNode :: NodeId -> Process MonitorRef
489−monitorNode =
489+monitorNode =
490490 monitor' . NodeIdentifier
491491
492492-- | Monitor a typed channel (asynchronous)
493493monitorPort :: forall a. Serializable a => SendPort a -> Process MonitorRef
494−monitorPort (SendPort cid) =
495− monitor' (SendPortIdentifier cid)
494+monitorPort (SendPort cid) =
495+ monitor' (SendPortIdentifier cid)
496496
497497-- | Remove a monitor (asynchronous)
498498unmonitorAsync :: MonitorRef -> Process ()
499−unmonitorAsync =
499+unmonitorAsync =
500500 sendCtrlMsg Nothing . Unmonitor
501501
502502-- | Link to a node (asynchronous)
503503linkNode :: NodeId -> Process ()
504−linkNode = link' . NodeIdentifier
504+linkNode = link' . NodeIdentifier
505505
506506-- | Link to a channel (asynchronous)
507507linkPort :: SendPort a -> Process ()
508−linkPort (SendPort cid) =
508+linkPort (SendPort cid) =
509509 link' (SendPortIdentifier cid)
510510
511511-- | Remove a process link (asynchronous)
512512unlinkAsync :: ProcessId -> Process ()
513−unlinkAsync =
513+unlinkAsync =
514514 sendCtrlMsg Nothing . Unlink . ProcessIdentifier
515515
516516-- | Remove a node link (asynchronous)
517517unlinkNodeAsync :: NodeId -> Process ()
518−unlinkNodeAsync =
518+unlinkNodeAsync =
519519 sendCtrlMsg Nothing . Unlink . NodeIdentifier
520520
521521-- | Remove a channel (send port) link (asynchronous)
522522unlinkPortAsync :: SendPort a -> Process ()
523−unlinkPortAsync (SendPort cid) =
523+unlinkPortAsync (SendPort cid) =
524524 sendCtrlMsg Nothing . Unlink $ SendPortIdentifier cid
525525
526526--------------------------------------------------------------------------------
@@ -573,12 +573,12 @@ registerImpl force label pid = do
573573--
574574-- See comments in 'whereisRemoteAsync'
575575registerRemoteAsync :: NodeId -> String -> ProcessId -> Process ()
576−registerRemoteAsync nid label pid =
577− sendCtrlMsg (Just nid) (Register label nid (Just pid) False)
576+registerRemoteAsync nid label pid =
577+ sendCtrlMsg (Just nid) (Register label nid (Just pid) False)
578578
579579reregisterRemoteAsync :: NodeId -> String -> ProcessId -> Process ()
580−reregisterRemoteAsync nid label pid =
581− sendCtrlMsg (Just nid) (Register label nid (Just pid) True)
580+reregisterRemoteAsync nid label pid =
581+ sendCtrlMsg (Just nid) (Register label nid (Just pid) True)
582582
583583-- | Remove a process from the local registry (asynchronous).
584584-- This version will wait until a response is gotten from the
@@ -594,12 +594,12 @@ unregister label = do
594594-- | Deal with the result from an attempted registration or unregistration
595595-- by throwing an exception if necessary
596596handleRegistrationReply :: String -> Bool -> Process ()
597−handleRegistrationReply label ok =
597+handleRegistrationReply label ok =
598598 when (not ok) $
599599 liftIO $ throwIO $ ProcessRegistrationException label
600600
601601-- | Remove a process from a remote registry (asynchronous).
602−--
602+--
603603-- Reply wil come in the form of a 'RegisterReply' message
604604--
605605-- See comments in 'whereisRemoteAsync'
@@ -617,25 +617,25 @@ whereis label = do
617617
618618-- | Query a remote process registry (asynchronous)
619619--
620−-- Reply will come in the form of a 'WhereIsReply' message.
620+-- Reply will come in the form of a 'WhereIsReply' message.
621621--
622622-- There is currently no synchronous version of 'whereisRemoteAsync': if
623623-- you implement one yourself, be sure to take into account that the remote
624624-- node might die or get disconnect before it can respond (i.e. you should
625−-- use 'monitorNode' and take appropriate action when you receive a
625+-- use 'monitorNode' and take appropriate action when you receive a
626626-- 'NodeMonitorNotification').
627627whereisRemoteAsync :: NodeId -> String -> Process ()
628−whereisRemoteAsync nid label =
628+whereisRemoteAsync nid label =
629629 sendCtrlMsg (Just nid) (WhereIs label)
630630
631−-- | Named send to a process in the local registry (asynchronous)
631+-- | Named send to a process in the local registry (asynchronous)
632632nsend :: Serializable a => String -> a -> Process ()
633−nsend label msg =
633+nsend label msg =
634634 sendCtrlMsg Nothing (NamedSend label (createMessage msg))
635635
636636-- | Named send to a process in a remote registry (asynchronous)
637637nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()
638−nsendRemote nid label msg =
638+nsendRemote nid label msg =
639639 sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))
640640
641641--------------------------------------------------------------------------------
@@ -653,9 +653,9 @@ unStatic static = do
653653-- | Resolve a closure
654654unClosure :: Typeable a => Closure a -> Process a
655655unClosure closure = do
656− rtable <- remoteTable . processNode <$> ask
656+ rtable <- remoteTable . processNode <$> ask
657657 case Static.unclosure rtable closure of
658− Left err -> fail $ "Could not resolve closure: " ++ err
658+ Left err -> fail $ "Could not resolve closure: " ++ err
659659 Right x -> return x
660660
661661--------------------------------------------------------------------------------
@@ -666,11 +666,11 @@ unClosure closure = do
666666-- message passing. However, when network connections get disrupted this
667667-- illusion cannot always be maintained. Once a network connection breaks (even
668668-- temporarily) no further communication on that connection will be possible.
669−-- For example, if process A sends a message to process B, and A is then
669+-- For example, if process A sends a message to process B, and A is then
670670-- notified (by monitor notification) that it got disconnected from B, A will
671−-- not be able to send any further messages to B, /unless/ A explicitly
671+-- not be able to send any further messages to B, /unless/ A explicitly
672672-- indicates that it is acceptable to attempt to reconnect to B using the
673−-- Cloud Haskell 'reconnect' primitive.
673+-- Cloud Haskell 'reconnect' primitive.
674674--
675675-- Importantly, when A calls 'reconnect' it acknowledges that some messages to
676676-- B might have been lost. For instance, if A sends messages m1 and m2 to B,
@@ -690,7 +690,7 @@ reconnect them = do
690690
691691-- | Reconnect to a sendport. See 'reconnect' for more information.
692692reconnectPort :: SendPort a -> Process ()
693−reconnectPort them = do
693+reconnectPort them = do
694694 us <- getSelfPid
695695 node <- processNode <$> ask
696696 liftIO $ disconnect node (ProcessIdentifier us) (SendPortIdentifier (sendPortId them))
@@ -702,10 +702,10 @@ reconnectPort them = do
702702getMonitorRefFor :: Identifier -> Process MonitorRef
703703getMonitorRefFor ident = do
704704 proc <- ask
705− liftIO $ modifyMVar (processState proc) $ \st -> do
706− let counter = st ^. monitorCounter
705+ liftIO $ modifyMVar (processState proc) $ \st -> do
706+ let counter = st ^. monitorCounter
707707 return ( monitorCounter ^: (+ 1) $ st
708− , MonitorRef ident counter
708+ , MonitorRef ident counter
709709 )
710710
711711getSpawnRef :: Process SpawnRef
@@ -720,7 +720,7 @@ getSpawnRef = do
720720-- | Monitor a process/node/channel
721721monitor' :: Identifier -> Process MonitorRef
722722monitor' ident = do
723− monitorRef <- getMonitorRefFor ident
723+ monitorRef <- getMonitorRefFor ident
724724 sendCtrlMsg Nothing $ Monitor monitorRef
725725 return monitorRef
726726
@@ -730,17 +730,17 @@ link' = sendCtrlMsg Nothing . Link
730730
731731-- Send a control message
732732sendCtrlMsg :: Maybe NodeId -- ^ Nothing for the local node
733− -> ProcessSignal -- ^ Message to send
733+ -> ProcessSignal -- ^ Message to send
734734 -> Process ()
735−sendCtrlMsg mNid signal = do
735+sendCtrlMsg mNid signal = do
736736 proc <- ask
737− let msg = NCMsg { ctrlMsgSender = ProcessIdentifier (processId proc)
737+ let msg = NCMsg { ctrlMsgSender = ProcessIdentifier (processId proc)
738738 , ctrlMsgSignal = signal
739739 }
740740 case mNid of
741741 Nothing -> do
742− ctrlChan <- localCtrlChan . processNode <$> ask
743− liftIO $ writeChan ctrlChan msg
742+ ctrlChan <- localCtrlChan . processNode <$> ask
743+ liftIO $ writeChan ctrlChan msg
744744 Just nid ->
745745 liftIO $ sendBinary (processNode proc)
746746 (ProcessIdentifier (processId proc))
distributed-process/src/Control/Distributed/Process/Internal/StrictContainerAccessors.hs+1−1
@@ -1,4 +1,4 @@
1−module Control.Distributed.Process.Internal.StrictContainerAccessors
1+module Control.Distributed.Process.Internal.StrictContainerAccessors
22 ( mapMaybe
33 , mapDefault
44 ) where
distributed-process/src/Control/Distributed/Process/Internal/StrictList.hs+4−4
@@ -1,7 +1,7 @@
11-- | Spine and element strict list
2−module Control.Distributed.Process.Internal.StrictList
2+module Control.Distributed.Process.Internal.StrictList
33 ( StrictList(Cons, Nil)
4− , length
4+ , length
55 , reverse
66 , reverse'
77 ) where
@@ -16,10 +16,10 @@ length Nil = 0
1616length (Cons _ xs) = 1 + length xs
1717
1818-- | Reverse a strict list
19−reverse :: StrictList a -> StrictList a
19+reverse :: StrictList a -> StrictList a
2020reverse xs = reverse' xs Nil
2121
2222-- | @reverseStrict' xs ys@ is 'reverse xs ++ ys' if they were lists
23−reverse' :: StrictList a -> StrictList a -> StrictList a
23+reverse' :: StrictList a -> StrictList a -> StrictList a
2424reverse' Nil ys = ys
2525reverse' (Cons x xs) ys = reverse' xs (Cons x ys)
distributed-process/src/Control/Distributed/Process/Internal/StrictMVar.hs+4−4
@@ -1,6 +1,6 @@
11-- | Like Control.Concurrent.MVar.Strict but reduce to HNF, not NF
22{-# LANGUAGE MagicHash, UnboxedTuples #-}
3−module Control.Distributed.Process.Internal.StrictMVar
3+module Control.Distributed.Process.Internal.StrictMVar
44 ( StrictMVar(StrictMVar)
55 , newEmptyMVar
66 , newMVar
@@ -15,7 +15,7 @@ module Control.Distributed.Process.Internal.StrictMVar
1515import Control.Applicative ((<$>))
1616import Control.Monad ((>=>))
1717import Control.Exception (evaluate)
18−import qualified Control.Concurrent.MVar as MVar
18+import qualified Control.Concurrent.MVar as MVar
1919 ( MVar
2020 , newEmptyMVar
2121 , newMVar
@@ -26,7 +26,7 @@ import qualified Control.Concurrent.MVar as MVar
2626 , modifyMVar
2727 )
2828import GHC.MVar (MVar(MVar))
29−import GHC.IO (IO(IO))
29+import GHC.IO (IO(IO))
3030import GHC.Prim (mkWeak#)
3131import GHC.Weak (Weak(Weak))
3232
@@ -48,7 +48,7 @@ withMVar :: StrictMVar a -> (a -> IO b) -> IO b
4848withMVar (StrictMVar v) = MVar.withMVar v
4949
5050modifyMVar_ :: StrictMVar a -> (a -> IO a) -> IO ()
51−modifyMVar_ (StrictMVar v) f = MVar.modifyMVar_ v (f >=> evaluate)
51+modifyMVar_ (StrictMVar v) f = MVar.modifyMVar_ v (f >=> evaluate)
5252
5353modifyMVar :: StrictMVar a -> (a -> IO (a, b)) -> IO b
5454modifyMVar (StrictMVar v) f = MVar.modifyMVar v (f >=> evaluateFst)
distributed-process/src/Control/Distributed/Process/Internal/Types.hs+69−69
@@ -1,10 +1,10 @@
11-- | Types used throughout the Cloud Haskell framework
22--
3−-- We collect all types used internally in a single module because
3+-- We collect all types used internally in a single module because
44-- many of these data types are mutually recursive and cannot be split across
55-- modules.
66module Control.Distributed.Process.Internal.Types
7− ( -- * Node and process identifiers
7+ ( -- * Node and process identifiers
88 NodeId(..)
99 , LocalProcessId(..)
1010 , ProcessId(..)
@@ -21,17 +21,17 @@ module Control.Distributed.Process.Internal.Types
2121 , runLocalProcess
2222 , ImplicitReconnect(..)
2323 -- * Typed channels
24− , LocalSendPortId
24+ , LocalSendPortId
2525 , SendPortId(..)
2626 , TypedChannel(..)
2727 , SendPort(..)
2828 , ReceivePort(..)
29− -- * Messages
29+ -- * Messages
3030 , Message(..)
3131 , createMessage
3232 , messageToPayload
3333 , payloadToMessage
34− -- * Node controller user-visible data types
34+ -- * Node controller user-visible data types
3535 , MonitorRef(..)
3636 , ProcessMonitorNotification(..)
3737 , NodeMonitorNotification(..)
@@ -49,7 +49,7 @@ module Control.Distributed.Process.Internal.Types
4949 , DidSpawn(..)
5050 , WhereIsReply(..)
5151 , RegisterReply(..)
52− -- * Node controller internal data types
52+ -- * Node controller internal data types
5353 , NCMsg(..)
5454 , ProcessSignal(..)
5555 -- * Accessors
@@ -72,7 +72,7 @@ import Data.Int (Int32)
7272import Data.Typeable (Typeable)
7373import Data.Binary (Binary(put, get), putWord8, getWord8, encode)
7474import qualified Data.ByteString as BSS (ByteString, concat, copy)
75−import qualified Data.ByteString.Lazy as BSL
75+import qualified Data.ByteString.Lazy as BSL
7676 ( ByteString
7777 , toChunks
7878 , splitAt
@@ -89,7 +89,7 @@ import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)
8989import Control.Applicative (Applicative, Alternative, (<$>), (<*>))
9090import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)
9191import Control.Monad.IO.Class (MonadIO)
92−import Control.Distributed.Process.Serializable
92+import Control.Distributed.Process.Serializable
9393 ( Fingerprint
9494 , Serializable
9595 , fingerprint
@@ -108,38 +108,38 @@ import qualified Control.Distributed.Process.Internal.StrictContainerAccessors a
108108-- Node and process identifiers --
109109--------------------------------------------------------------------------------
110110
111−-- | Node identifier
111+-- | Node identifier
112112newtype NodeId = NodeId { nodeAddress :: NT.EndPointAddress }
113113 deriving (Eq, Ord, Binary, Typeable)
114114
115115instance Show NodeId where
116− show (NodeId addr) = "nid://" ++ show addr
116+ show (NodeId addr) = "nid://" ++ show addr
117117
118118-- | A local process ID consists of a seed which distinguishes processes from
119119-- different instances of the same local node and a counter
120−data LocalProcessId = LocalProcessId
120+data LocalProcessId = LocalProcessId
121121 { lpidUnique :: {-# UNPACK #-} !Int32
122122 , lpidCounter :: {-# UNPACK #-} !Int32
123123 }
124124 deriving (Eq, Ord, Typeable, Show)
125125
126126-- | Process identifier
127−data ProcessId = ProcessId
127+data ProcessId = ProcessId
128128 { -- | The ID of the node the process is running on
129129 processNodeId :: !NodeId
130130 -- | Node-local identifier for the process
131− , processLocalId :: {-# UNPACK #-} !LocalProcessId
131+ , processLocalId :: {-# UNPACK #-} !LocalProcessId
132132 }
133133 deriving (Eq, Ord, Typeable)
134134
135135instance Show ProcessId where
136− show (ProcessId (NodeId addr) (LocalProcessId _ lid))
136+ show (ProcessId (NodeId addr) (LocalProcessId _ lid))
137137 = "pid://" ++ show addr ++ ":" ++ show lid
138138
139−-- | Union of all kinds of identifiers
140−data Identifier =
139+-- | Union of all kinds of identifiers
140+data Identifier =
141141 NodeIdentifier !NodeId
142− | ProcessIdentifier !ProcessId
142+ | ProcessIdentifier !ProcessId
143143 | SendPortIdentifier !SendPortId
144144 deriving (Eq, Ord)
145145
@@ -161,7 +161,7 @@ firstNonReservedProcessId :: Int32
161161firstNonReservedProcessId = 1
162162
163163nullProcessId :: NodeId -> ProcessId
164−nullProcessId nid =
164+nullProcessId nid =
165165 ProcessId { processNodeId = nid
166166 , processLocalId = LocalProcessId { lpidUnique = 0
167167 , lpidCounter = 0
@@ -173,39 +173,39 @@ nullProcessId nid =
173173--------------------------------------------------------------------------------
174174
175175-- | Local nodes
176−data LocalNode = LocalNode
176+data LocalNode = LocalNode
177177 { -- | 'NodeId' of the node
178178 localNodeId :: !NodeId
179− -- | The network endpoint associated with this node
180− , localEndPoint :: !NT.EndPoint
181− -- | Local node state
179+ -- | The network endpoint associated with this node
180+ , localEndPoint :: !NT.EndPoint
181+ -- | Local node state
182182 , localState :: !(StrictMVar LocalNodeState)
183183 -- | Channel for the node controller
184184 , localCtrlChan :: !(Chan NCMsg)
185185 -- | Runtime lookup table for supporting closures
186186 -- TODO: this should be part of the CH state, not the local endpoint state
187− , remoteTable :: !RemoteTable
187+ , remoteTable :: !RemoteTable
188188 }
189189
190190data ImplicitReconnect = WithImplicitReconnect | NoImplicitReconnect
191191 deriving (Eq, Show)
192192
193193-- | Local node state
194−data LocalNodeState = LocalNodeState
194+data LocalNodeState = LocalNodeState
195195 { -- | Processes running on this node
196196 _localProcesses :: !(Map LocalProcessId LocalProcess)
197− -- | Counter to assign PIDs
197+ -- | Counter to assign PIDs
198198 , _localPidCounter :: !Int32
199199 -- | The 'unique' value used to create PIDs (so that processes on
200200 -- restarted nodes have new PIDs)
201201 , _localPidUnique :: !Int32
202202 -- | Outgoing connections
203− , _localConnections :: !(Map (Identifier, Identifier)
203+ , _localConnections :: !(Map (Identifier, Identifier)
204204 (NT.Connection, ImplicitReconnect))
205205 }
206206
207207-- | Processes running on our local node
208−data LocalProcess = LocalProcess
208+data LocalProcess = LocalProcess
209209 { processQueue :: !(CQueue Message)
210210 , processWeakQ :: !(Weak (CQueue Message))
211211 , processId :: !ProcessId
@@ -214,7 +214,7 @@ data LocalProcess = LocalProcess
214214 , processNode :: !LocalNode
215215 }
216216
217−-- | Deconstructor for 'Process' (not exported to the public API)
217+-- | Deconstructor for 'Process' (not exported to the public API)
218218runLocalProcess :: LocalProcess -> Process a -> IO a
219219runLocalProcess lproc proc = runReaderT (unProcess proc) lproc
220220
@@ -227,8 +227,8 @@ data LocalProcessState = LocalProcessState
227227 }
228228
229229-- | The Cloud Haskell 'Process' type
230−newtype Process a = Process {
231− unProcess :: ReaderT LocalProcess IO a
230+newtype Process a = Process {
231+ unProcess :: ReaderT LocalProcess IO a
232232 }
233233 deriving (Functor, Monad, MonadIO, MonadReader LocalProcess, Typeable, Applicative)
234234
@@ -251,15 +251,15 @@ data SendPortId = SendPortId {
251251 deriving (Eq, Ord)
252252
253253instance Show SendPortId where
254− show (SendPortId (ProcessId (NodeId addr) (LocalProcessId _ plid)) clid)
254+ show (SendPortId (ProcessId (NodeId addr) (LocalProcessId _ plid)) clid)
255255 = "cid://" ++ show addr ++ ":" ++ show plid ++ ":" ++ show clid
256256
257257data TypedChannel = forall a. Serializable a => TypedChannel (Weak (TQueue a))
258258
259259-- | The send send of a typed channel (serializable)
260−newtype SendPort a = SendPort {
260+newtype SendPort a = SendPort {
261261 -- | The (unique) ID of this send port
262− sendPortId :: SendPortId
262+ sendPortId :: SendPortId
263263 }
264264 deriving (Typeable, Binary, Show, Eq, Ord)
265265
@@ -271,13 +271,13 @@ newtype ReceivePort a = ReceivePort { receiveSTM :: STM a }
271271 deriving (Typeable, Functor, Applicative, Alternative, Monad)
272272
273273{-
274−data ReceivePort a =
274+data ReceivePort a =
275275 -- | A single receive port
276276 ReceivePortSingle (TQueue a)
277− -- | A left-biased combination of receive ports
278− | ReceivePortBiased [ReceivePort a]
277+ -- | A left-biased combination of receive ports
278+ | ReceivePortBiased [ReceivePort a]
279279 -- | A round-robin combination of receive ports
280− | ReceivePortRR (TVar [ReceivePort a])
280+ | ReceivePortRR (TVar [ReceivePort a])
281281 deriving Typeable
282282-}
283283
@@ -286,13 +286,13 @@ data ReceivePort a =
286286--------------------------------------------------------------------------------
287287
288288-- | Messages consist of their typeRep fingerprint and their encoding
289−data Message = Message
290− { messageFingerprint :: !Fingerprint
289+data Message = Message
290+ { messageFingerprint :: !Fingerprint
291291 , messageEncoding :: !BSL.ByteString
292292 }
293293
294294instance Show Message where
295− show (Message fp enc) = show enc ++ " :: " ++ showFingerprint fp []
295+ show (Message fp enc) = show enc ++ " :: " ++ showFingerprint fp []
296296
297297-- | Turn any serialiable term into a message
298298createMessage :: Serializable a => a -> Message
@@ -304,26 +304,26 @@ messageToPayload (Message fp enc) = encodeFingerprint fp : BSL.toChunks enc
304304
305305-- | Deserialize a message
306306payloadToMessage :: [BSS.ByteString] -> Message
307−payloadToMessage payload = Message fp (copy msg)
307+payloadToMessage payload = Message fp (copy msg)
308308 where
309309 encFp :: BSL.ByteString
310310 msg :: BSL.ByteString
311− (encFp, msg) = BSL.splitAt (fromIntegral sizeOfFingerprint)
312− $ BSL.fromChunks payload
311+ (encFp, msg) = BSL.splitAt (fromIntegral sizeOfFingerprint)
312+ $ BSL.fromChunks payload
313313
314314 fp :: Fingerprint
315315 fp = decodeFingerprint . BSS.concat . BSL.toChunks $ encFp
316316
317317 copy :: BSL.ByteString -> BSL.ByteString
318318 copy (BSL.Chunk bs BSL.Empty) = BSL.Chunk (BSS.copy bs) BSL.Empty
319− copy bsl = BSL.fromChunks . return . BSS.concat . BSL.toChunks $ bsl
319+ copy bsl = BSL.fromChunks . return . BSS.concat . BSL.toChunks $ bsl
320320
321321--------------------------------------------------------------------------------
322322-- Node controller user-visible data types --
323323--------------------------------------------------------------------------------
324324
325−-- | MonitorRef is opaque for regular Cloud Haskell processes
326−data MonitorRef = MonitorRef
325+-- | MonitorRef is opaque for regular Cloud Haskell processes
326+data MonitorRef = MonitorRef
327327 { -- | ID of the entity to be monitored
328328 monitorRefIdent :: !Identifier
329329 -- | Unique to distinguish multiple monitor requests by the same process
@@ -332,39 +332,39 @@ data MonitorRef = MonitorRef
332332 deriving (Eq, Ord, Show)
333333
334334-- | Message sent by process monitors
335−data ProcessMonitorNotification =
335+data ProcessMonitorNotification =
336336 ProcessMonitorNotification !MonitorRef !ProcessId !DiedReason
337337 deriving (Typeable, Show)
338338
339339-- | Message sent by node monitors
340−data NodeMonitorNotification =
340+data NodeMonitorNotification =
341341 NodeMonitorNotification !MonitorRef !NodeId !DiedReason
342342 deriving (Typeable, Show)
343343
344344-- | Message sent by channel (port) monitors
345−data PortMonitorNotification =
345+data PortMonitorNotification =
346346 PortMonitorNotification !MonitorRef !SendPortId !DiedReason
347347 deriving (Typeable, Show)
348348
349349-- | Exceptions thrown when a linked process dies
350−data ProcessLinkException =
350+data ProcessLinkException =
351351 ProcessLinkException !ProcessId !DiedReason
352352 deriving (Typeable, Show)
353353
354354-- | Exception thrown when a linked node dies
355−data NodeLinkException =
355+data NodeLinkException =
356356 NodeLinkException !NodeId !DiedReason
357357 deriving (Typeable, Show)
358358
359359-- | Exception thrown when a linked channel (port) dies
360−data PortLinkException =
360+data PortLinkException =
361361 PortLinkException !SendPortId !DiedReason
362362 deriving (Typeable, Show)
363363
364364-- | Exception thrown when a process attempts to register
365365-- a process under an already-registered name or to
366366-- unregister a name that hasn't been registered
367−data ProcessRegistrationException =
367+data ProcessRegistrationException =
368368 ProcessRegistrationException !String
369369 deriving (Typeable, Show)
370370
@@ -374,7 +374,7 @@ instance Exception PortLinkException
374374instance Exception ProcessRegistrationException
375375
376376-- | Why did a process die?
377−data DiedReason =
377+data DiedReason =
378378 -- | Normal termination
379379 DiedNormal
380380 -- | The process exited with an exception
@@ -384,7 +384,7 @@ data DiedReason =
384384 | DiedDisconnect
385385 -- | The process node died
386386 | DiedNodeDown
387− -- | Invalid (process/node/channel) identifier
387+ -- | Invalid (process/node/channel) identifier
388388 | DiedUnknownId
389389 deriving (Show, Eq)
390390
@@ -401,7 +401,7 @@ newtype DidUnlinkNode = DidUnlinkNode NodeId
401401 deriving (Typeable, Binary)
402402
403403-- | (Asynchronous) reply from unlinkPort
404−newtype DidUnlinkPort = DidUnlinkPort SendPortId
404+newtype DidUnlinkPort = DidUnlinkPort SendPortId
405405 deriving (Typeable, Binary)
406406
407407-- | 'SpawnRef' are used to return pids of spawned processes
@@ -425,20 +425,20 @@ data RegisterReply = RegisterReply String Bool
425425--------------------------------------------------------------------------------
426426
427427-- | Messages to the node controller
428−data NCMsg = NCMsg
429− { ctrlMsgSender :: !Identifier
428+data NCMsg = NCMsg
429+ { ctrlMsgSender :: !Identifier
430430 , ctrlMsgSignal :: !ProcessSignal
431431 }
432432 deriving Show
433433
434434-- | Signals to the node controller (see 'NCMsg')
435435data ProcessSignal =
436− Link !Identifier
437− | Unlink !Identifier
436+ Link !Identifier
437+ | Unlink !Identifier
438438 | Monitor !MonitorRef
439439 | Unmonitor !MonitorRef
440440 | Died Identifier !DiedReason
441− | Spawn !(Closure (Process ())) !SpawnRef
441+ | Spawn !(Closure (Process ())) !SpawnRef
442442 | WhereIs !String
443443 | Register !String !NodeId !(Maybe ProcessId) !Bool -- Use 'Nothing' to unregister, use True to force reregister
444444 | NamedSend !String !Message
@@ -480,12 +480,12 @@ instance Binary ProcessSignal where
480480 put (Link pid) = putWord8 0 >> put pid
481481 put (Unlink pid) = putWord8 1 >> put pid
482482 put (Monitor ref) = putWord8 2 >> put ref
483− put (Unmonitor ref) = putWord8 3 >> put ref
483+ put (Unmonitor ref) = putWord8 3 >> put ref
484484 put (Died who reason) = putWord8 4 >> put who >> put reason
485485 put (Spawn proc ref) = putWord8 5 >> put proc >> put ref
486486 put (WhereIs label) = putWord8 6 >> put label
487487 put (Register label nid pid force) = putWord8 7 >> put label >> put nid >> put pid >> put force
488− put (NamedSend label msg) = putWord8 8 >> put label >> put (messageToPayload msg)
488+ put (NamedSend label msg) = putWord8 8 >> put label >> put (messageToPayload msg)
489489 get = do
490490 header <- getWord8
491491 case header of
@@ -502,7 +502,7 @@ instance Binary ProcessSignal where
502502
503503instance Binary DiedReason where
504504 put DiedNormal = putWord8 0
505− put (DiedException e) = putWord8 1 >> put e
505+ put (DiedException e) = putWord8 1 >> put e
506506 put DiedDisconnect = putWord8 2
507507 put DiedNodeDown = putWord8 3
508508 put DiedUnknownId = putWord8 4
@@ -513,7 +513,7 @@ instance Binary DiedReason where
513513 1 -> DiedException <$> get
514514 2 -> return DiedDisconnect
515515 3 -> return DiedNodeDown
516− 4 -> return DiedUnknownId
516+ 4 -> return DiedUnknownId
517517 _ -> fail "DiedReason.get: invalid"
518518
519519instance Binary DidSpawn where
@@ -522,18 +522,18 @@ instance Binary DidSpawn where
522522
523523instance Binary SendPortId where
524524 put cid = put (sendPortProcessId cid) >> put (sendPortLocalId cid)
525− get = SendPortId <$> get <*> get
525+ get = SendPortId <$> get <*> get
526526
527527instance Binary Identifier where
528528 put (ProcessIdentifier pid) = putWord8 0 >> put pid
529529 put (NodeIdentifier nid) = putWord8 1 >> put nid
530530 put (SendPortIdentifier cid) = putWord8 2 >> put cid
531531 get = do
532− header <- getWord8
532+ header <- getWord8
533533 case header of
534534 0 -> ProcessIdentifier <$> get
535535 1 -> NodeIdentifier <$> get
536− 2 -> SendPortIdentifier <$> get
536+ 2 -> SendPortIdentifier <$> get
537537 _ -> fail "Identifier.get: invalid"
538538
539539instance Binary WhereIsReply where
@@ -541,7 +541,7 @@ instance Binary WhereIsReply where
541541 get = WhereIsReply <$> get <*> get
542542
543543instance Binary RegisterReply where
544− put (RegisterReply label ok) = put label >> put ok
544+ put (RegisterReply label ok) = put label >> put ok
545545 get = RegisterReply <$> get <*> get
546546
547547--------------------------------------------------------------------------------
distributed-process/src/Control/Distributed/Process/Internal/WeakTQueue.hs+2−2
@@ -21,7 +21,7 @@ module Control.Distributed.Process.Internal.WeakTQueue (
2121import Prelude hiding (read)
2222import GHC.Conc
2323import Data.Typeable (Typeable)
24−import GHC.IO (IO(IO))
24+import GHC.IO (IO(IO))
2525import GHC.Prim (mkWeak#)
2626import GHC.Weak (Weak(Weak))
2727
@@ -98,4 +98,4 @@ isEmptyTQueue (TQueue read write) = do
9898
9999mkWeakTQueue :: TQueue a -> IO () -> IO (Weak (TQueue a))
100100mkWeakTQueue q@(TQueue _read (TVar write#)) f = IO $ \s ->
101− case mkWeak# write# q f s of (# s', w #) -> (# s', Weak w #)
101+ case mkWeak# write# q f s of (# s', w #) -> (# s', Weak w #)
distributed-process/src/Control/Distributed/Process/Node.hs+122−122
@@ -2,7 +2,7 @@
22--
33-- TODO: Calls to 'sendBinary' and co by the node controller may stall the
44-- node controller.
5−module Control.Distributed.Process.Node
5+module Control.Distributed.Process.Node
66 ( LocalNode
77 , newLocalNode
88 , closeLocalNode
@@ -21,7 +21,7 @@ import System.Mem.Weak (Weak, deRefWeak)
2121import qualified Data.ByteString.Lazy as BSL (fromChunks)
2222import Data.Binary (decode)
2323import Data.Map (Map)
24−import qualified Data.Map as Map
24+import qualified Data.Map as Map
2525 ( empty
2626 , toList
2727 , fromList
@@ -46,7 +46,7 @@ import Control.Exception (throwIO, SomeException, Exception, throwTo)
4646import qualified Control.Exception as Exception (catch)
4747import Control.Concurrent (forkIO)
4848import Control.Distributed.Process.Internal.StrictMVar
49− ( newMVar
49+ ( newMVar
5050 , withMVar
5151 , modifyMVar
5252 , modifyMVar_
@@ -56,13 +56,13 @@ import Control.Distributed.Process.Internal.StrictMVar
5656 )
5757import Control.Concurrent.Chan (newChan, writeChan, readChan)
5858import Control.Concurrent.STM (atomically)
59−import Control.Distributed.Process.Internal.CQueue
59+import Control.Distributed.Process.Internal.CQueue
6060 ( CQueue
6161 , enqueue
6262 , newCQueue
6363 , mkWeakCQueue
6464 )
65−import qualified Network.Transport as NT
65+import qualified Network.Transport as NT
6666 ( Transport
6767 , EndPoint
6868 , newEndPoint
@@ -81,11 +81,11 @@ import qualified Network.Transport as NT
8181import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))
8282import System.Random (randomIO)
8383import Control.Distributed.Static (RemoteTable, Closure)
84−import qualified Control.Distributed.Static as Static
84+import qualified Control.Distributed.Static as Static
8585 ( unclosure
8686 , initRemoteTable
8787 )
88−import Control.Distributed.Process.Internal.Types
88+import Control.Distributed.Process.Internal.Types
8989 ( NodeId(..)
9090 , LocalProcessId(..)
9191 , ProcessId(..)
@@ -134,7 +134,7 @@ import Control.Distributed.Process.Internal.Messaging
134134 ( sendBinary
135135 , sendMessage
136136 , sendPayload
137− , closeImplicitReconnections
137+ , closeImplicitReconnections
138138 , impliesDeathOf
139139 )
140140import Control.Distributed.Process.Internal.Primitives
@@ -153,27 +153,27 @@ import qualified Control.Distributed.Process.Internal.StrictContainerAccessors a
153153--------------------------------------------------------------------------------
154154
155155initRemoteTable :: RemoteTable
156−initRemoteTable = BuiltIn.remoteTable Static.initRemoteTable
156+initRemoteTable = BuiltIn.remoteTable Static.initRemoteTable
157157
158−-- | Initialize a new local node.
158+-- | Initialize a new local node.
159159newLocalNode :: NT.Transport -> RemoteTable -> IO LocalNode
160160newLocalNode transport rtable = do
161161 mEndPoint <- NT.newEndPoint transport
162162 case mEndPoint of
163163 Left ex -> throwIO ex
164164 Right endPoint -> do
165− localNode <- createBareLocalNode endPoint rtable
165+ localNode <- createBareLocalNode endPoint rtable
166166 startServiceProcesses localNode
167167 return localNode
168−
168+
169169-- | Create a new local node (without any service processes running)
170170createBareLocalNode :: NT.EndPoint -> RemoteTable -> IO LocalNode
171171createBareLocalNode endPoint rtable = do
172172 unq <- randomIO
173− state <- newMVar LocalNodeState
173+ state <- newMVar LocalNodeState
174174 { _localProcesses = Map.empty
175− , _localPidCounter = firstNonReservedProcessId
176− , _localPidUnique = unq
175+ , _localPidCounter = firstNonReservedProcessId
176+ , _localPidUnique = unq
177177 , _localConnections = Map.empty
178178 }
179179 ctrlChan <- newChan
@@ -183,7 +183,7 @@ createBareLocalNode endPoint rtable = do
183183 , localCtrlChan = ctrlChan
184184 , remoteTable = rtable
185185 }
186− void . forkIO $ runNodeController node
186+ void . forkIO $ runNodeController node
187187 void . forkIO $ handleIncomingMessages node
188188 return node
189189
@@ -192,7 +192,7 @@ createBareLocalNode endPoint rtable = do
192192forever' :: Monad m => m a -> m b
193193forever' a = let a' = a >> a' in a'
194194
195−-- | Start and register the service processes on a node
195+-- | Start and register the service processes on a node
196196-- (for now, this is only the logger)
197197startServiceProcesses :: LocalNode -> IO ()
198198startServiceProcesses node = do
@@ -231,7 +231,7 @@ forkProcess node proc = modifyMVar (localState node) startProcess
231231 let lpid = LocalProcessId { lpidCounter = st ^. localPidCounter
232232 , lpidUnique = st ^. localPidUnique
233233 }
234− let pid = ProcessId { processNodeId = localNodeId node
234+ let pid = ProcessId { processNodeId = localNodeId node
235235 , processLocalId = lpid
236236 }
237237 pst <- newMVar LocalProcessState { _monitorCounter = 0
@@ -245,19 +245,19 @@ forkProcess node proc = modifyMVar (localState node) startProcess
245245 let lproc = LocalProcess { processQueue = queue
246246 , processWeakQ = weakQueue
247247 , processId = pid
248− , processState = pst
248+ , processState = pst
249249 , processThread = tid
250250 , processNode = node
251251 }
252252 tid' <- forkIO $ do
253− reason <- Exception.catch
253+ reason <- Exception.catch
254254 (runLocalProcess lproc proc >> return DiedNormal)
255255 (return . DiedException . (show :: SomeException -> String))
256256 -- [Unified: Table 4, rules termination and exiting]
257257 modifyMVar_ (localState node) (cleanupProcess pid)
258− writeChan (localCtrlChan node) NCMsg
259− { ctrlMsgSender = ProcessIdentifier pid
260− , ctrlMsgSignal = Died (ProcessIdentifier pid) reason
258+ writeChan (localCtrlChan node) NCMsg
259+ { ctrlMsgSender = ProcessIdentifier pid
260+ , ctrlMsgSignal = Died (ProcessIdentifier pid) reason
261261 }
262262 return (tid', lproc)
263263
@@ -274,12 +274,12 @@ forkProcess node proc = modifyMVar (localState node) startProcess
274274 return ( (localProcessWithId lpid ^= Just lproc)
275275 . (localPidCounter ^: (+ 1))
276276 $ st
277− , pid
277+ , pid
278278 )
279279
280280 cleanupProcess :: ProcessId -> LocalNodeState -> IO LocalNodeState
281281 cleanupProcess pid st = do
282− let pid' = ProcessIdentifier pid
282+ let pid' = ProcessIdentifier pid
283283 let (affected, unaffected) = Map.partitionWithKey (\(fr, _to) !_v -> impliesDeathOf pid' fr) (st ^. localConnections)
284284 mapM_ (NT.close . fst) (Map.elems affected)
285285 return $ (localProcessWithId (processLocalId pid) ^= Nothing)
@@ -292,7 +292,7 @@ forkProcess node proc = modifyMVar (localState node) startProcess
292292
293293type IncomingConnection = (NT.EndPointAddress, IncomingTarget)
294294
295−data IncomingTarget =
295+data IncomingTarget =
296296 Uninit
297297 | ToProc (Weak (CQueue Message))
298298 | ToChan TypedChannel
@@ -315,20 +315,20 @@ incoming = accessor _incoming (\conns st -> st { _incoming = conns })
315315incomingAt :: NT.ConnectionId -> Accessor ConnectionState (Maybe IncomingConnection)
316316incomingAt cid = incoming >>> DAC.mapMaybe cid
317317
318−incomingFrom :: NT.EndPointAddress -> Accessor ConnectionState (Set NT.ConnectionId)
318+incomingFrom :: NT.EndPointAddress -> Accessor ConnectionState (Set NT.ConnectionId)
319319incomingFrom addr = aux >>> DAC.mapDefault Set.empty addr
320320 where
321321 aux = accessor _incomingFrom (\fr st -> st { _incomingFrom = fr })
322322
323323handleIncomingMessages :: LocalNode -> IO ()
324−handleIncomingMessages node = go initConnectionState
324+handleIncomingMessages node = go initConnectionState
325325 where
326− go :: ConnectionState -> IO ()
326+ go :: ConnectionState -> IO ()
327327 go !st = do
328328 event <- NT.receive endpoint
329329 case event of
330330 NT.ConnectionOpened cid rel theirAddr ->
331− if rel == NT.ReliableOrdered
331+ if rel == NT.ReliableOrdered
332332 then go ( (incomingAt cid ^= Just (theirAddr, Uninit))
333333 . (incomingFrom theirAddr ^: Set.insert cid)
334334 $ st
@@ -338,33 +338,33 @@ handleIncomingMessages node = go initConnectionState
338338 case st ^. incomingAt cid of
339339 Just (_, ToProc weakQueue) -> do
340340 mQueue <- deRefWeak weakQueue
341− forM_ mQueue $ \queue -> do
341+ forM_ mQueue $ \queue -> do
342342 -- TODO: if we find that the queue is Nothing, should we remove
343343 -- it from the NC state? (and same for channels, below)
344344 let msg = payloadToMessage payload
345345 enqueue queue msg -- 'enqueue' is strict
346− go st
346+ go st
347347 Just (_, ToChan (TypedChannel chan')) -> do
348348 mChan <- deRefWeak chan'
349349 -- If mChan is Nothing, the process has given up the read end of
350350 -- the channel and we simply ignore the incoming message
351− forM_ mChan $ \chan -> atomically $
351+ forM_ mChan $ \chan -> atomically $
352352 -- We make sure the message is fully decoded when it is enqueued
353353 writeTQueue chan $! decode (BSL.fromChunks payload)
354− go st
354+ go st
355355 Just (_, ToNode) -> do
356356 let ctrlMsg = decode . BSL.fromChunks $ payload
357357 writeChan ctrlChan $! ctrlMsg
358− go st
359− Just (src, Uninit) ->
358+ go st
359+ Just (src, Uninit) ->
360360 case decode (BSL.fromChunks payload) of
361361 ProcessIdentifier pid -> do
362362 let lpid = processLocalId pid
363− mProc <- withMVar state $ return . (^. localProcessWithId lpid)
363+ mProc <- withMVar state $ return . (^. localProcessWithId lpid)
364364 case mProc of
365− Just proc ->
366− go (incomingAt cid ^= Just (src, ToProc (processWeakQ proc)) $ st)
367− Nothing ->
365+ Just proc ->
366+ go (incomingAt cid ^= Just (src, ToProc (processWeakQ proc)) $ st)
367+ Nothing ->
368368 invalidRequest cid st
369369 SendPortIdentifier chId -> do
370370 let lcid = sendPortLocalId chId
@@ -374,7 +374,7 @@ handleIncomingMessages node = go initConnectionState
374374 Just proc -> do
375375 mChannel <- withMVar (processState proc) $ return . (^. typedChannelWithId lcid)
376376 case mChannel of
377− Just channel ->
377+ Just channel ->
378378 go (incomingAt cid ^= Just (src, ToChan channel) $ st)
379379 Nothing ->
380380 invalidRequest cid st
@@ -383,35 +383,35 @@ handleIncomingMessages node = go initConnectionState
383383 NodeIdentifier nid ->
384384 if nid == localNodeId node
385385 then go (incomingAt cid ^= Just (src, ToNode) $ st)
386− else invalidRequest cid st
386+ else invalidRequest cid st
387387 Nothing ->
388388 invalidRequest cid st
389− NT.ConnectionClosed cid ->
389+ NT.ConnectionClosed cid ->
390390 case st ^. incomingAt cid of
391− Nothing ->
391+ Nothing ->
392392 invalidRequest cid st
393− Just (src, _) ->
393+ Just (src, _) ->
394394 go ( (incomingAt cid ^= Nothing)
395395 . (incomingFrom src ^: Set.delete cid)
396396 $ st
397397 )
398− NT.ErrorEvent (NT.TransportError (NT.EventConnectionLost theirAddr) _) -> do
398+ NT.ErrorEvent (NT.TransportError (NT.EventConnectionLost theirAddr) _) -> do
399399 -- [Unified table 9, rule node_disconnect]
400400 let nid = NodeIdentifier $ NodeId theirAddr
401− writeChan ctrlChan NCMsg
401+ writeChan ctrlChan NCMsg
402402 { ctrlMsgSender = nid
403403 , ctrlMsgSignal = Died nid DiedDisconnect
404404 }
405405 let notLost k = not (k `Set.member` (st ^. incomingFrom theirAddr))
406− closeImplicitReconnections node nid
406+ closeImplicitReconnections node nid
407407 go ( (incomingFrom theirAddr ^= Set.empty)
408408 . (incoming ^: Map.filterWithKey (const . notLost))
409− $ st
409+ $ st
410410 )
411411 NT.ErrorEvent (NT.TransportError NT.EventEndPointFailed str) ->
412− fail $ "Cloud Haskell fatal error: end point failed: " ++ str
412+ fail $ "Cloud Haskell fatal error: end point failed: " ++ str
413413 NT.ErrorEvent (NT.TransportError NT.EventTransportFailed str) ->
414− fail $ "Cloud Haskell fatal error: transport failed: " ++ str
414+ fail $ "Cloud Haskell fatal error: transport failed: " ++ str
415415 NT.EndPointClosed ->
416416 return ()
417417 NT.ReceivedMulticast _ _ ->
@@ -420,13 +420,13 @@ handleIncomingMessages node = go initConnectionState
420420 fail "Cloud Haskell fatal error: received unexpected multicast"
421421
422422 invalidRequest :: NT.ConnectionId -> ConnectionState -> IO ()
423− invalidRequest cid st =
423+ invalidRequest cid st =
424424 -- TODO: We should treat this as a fatal error on the part of the remote
425425 -- node. That is, we should report the remote node as having died, and we
426426 -- should close incoming connections (this requires a Transport layer
427427 -- extension).
428428 go ( incomingAt cid ^= Nothing
429− $ st
429+ $ st
430430 )
431431
432432 state = localState node
@@ -445,8 +445,8 @@ runNodeController =
445445-- Internal data types --
446446--------------------------------------------------------------------------------
447447
448−data NCState = NCState
449− { -- Mapping from remote processes to linked local processes
448+data NCState = NCState
449+ { -- Mapping from remote processes to linked local processes
450450 _links :: !(Map Identifier (Set ProcessId))
451451 -- Mapping from remote processes to monitoring local processes
452452 , _monitors :: !(Map Identifier (Set (ProcessId, MonitorRef)))
@@ -472,19 +472,19 @@ initNCState = NCState { _links = Map.empty
472472-- [Unified: Table 7]
473473nodeController :: NC ()
474474nodeController = do
475− node <- ask
475+ node <- ask
476476 forever' $ do
477477 msg <- liftIO $ readChan (localCtrlChan node)
478478
479− -- [Unified: Table 7, rule nc_forward]
479+ -- [Unified: Table 7, rule nc_forward]
480480 case destNid (ctrlMsgSignal msg) of
481− Just nid' | nid' /= localNodeId node ->
481+ Just nid' | nid' /= localNodeId node ->
482482 liftIO $ sendBinary node
483483 (ctrlMsgSender msg)
484− (NodeIdentifier nid')
484+ (NodeIdentifier nid')
485485 WithImplicitReconnect
486486 msg
487− _ ->
487+ _ ->
488488 return ()
489489
490490 case msg of
@@ -493,7 +493,7 @@ nodeController = do
493493 NCMsg (ProcessIdentifier from) (Monitor ref) ->
494494 ncEffectMonitor from (monitorRefIdent ref) (Just ref)
495495 NCMsg (ProcessIdentifier from) (Unlink them) ->
496− ncEffectUnlink from them
496+ ncEffectUnlink from them
497497 NCMsg (ProcessIdentifier from) (Unmonitor ref) ->
498498 ncEffectUnmonitor from ref
499499 NCMsg _from (Died ident reason) ->
@@ -510,23 +510,23 @@ nodeController = do
510510 error $ "nodeController: unexpected message " ++ show unexpected
511511
512512-- [Unified: Table 10]
513−ncEffectMonitor :: ProcessId -- ^ Who's watching?
513+ncEffectMonitor :: ProcessId -- ^ Who's watching?
514514 -> Identifier -- ^ Who's being watched?
515515 -> Maybe MonitorRef -- ^ 'Nothing' to link
516516 -> NC ()
517517ncEffectMonitor from them mRef = do
518− node <- ask
519− shouldLink <-
520− if not (isLocal node them)
518+ node <- ask
519+ shouldLink <-
520+ if not (isLocal node them)
521521 then return True
522522 else isValidLocalIdentifier them
523523 case (shouldLink, isLocal node (ProcessIdentifier from)) of
524524 (True, _) -> -- [Unified: first rule]
525525 case mRef of
526526 Just ref -> modify' $ monitorsFor them ^: Set.insert (from, ref)
527− Nothing -> modify' $ linksFor them ^: Set.insert from
527+ Nothing -> modify' $ linksFor them ^: Set.insert from
528528 (False, True) -> -- [Unified: second rule]
529− notifyDied from them DiedUnknownId mRef
529+ notifyDied from them DiedUnknownId mRef
530530 (False, False) -> -- [Unified: third rule]
531531 -- TODO: this is the right sender according to the Unified semantics,
532532 -- but perhaps having 'them' as the sender would make more sense
@@ -535,7 +535,7 @@ ncEffectMonitor from them mRef = do
535535 (NodeIdentifier $ localNodeId node)
536536 (NodeIdentifier $ processNodeId from)
537537 WithImplicitReconnect
538− NCMsg
538+ NCMsg
539539 { ctrlMsgSender = NodeIdentifier (localNodeId node)
540540 , ctrlMsgSignal = Died them DiedUnknownId
541541 }
@@ -543,22 +543,22 @@ ncEffectMonitor from them mRef = do
543543-- [Unified: Table 11]
544544ncEffectUnlink :: ProcessId -> Identifier -> NC ()
545545ncEffectUnlink from them = do
546− node <- ask
547− when (isLocal node (ProcessIdentifier from)) $
546+ node <- ask
547+ when (isLocal node (ProcessIdentifier from)) $
548548 case them of
549− ProcessIdentifier pid ->
550− postAsMessage from $ DidUnlinkProcess pid
551− NodeIdentifier nid ->
549+ ProcessIdentifier pid ->
550+ postAsMessage from $ DidUnlinkProcess pid
551+ NodeIdentifier nid ->
552552 postAsMessage from $ DidUnlinkNode nid
553− SendPortIdentifier cid ->
554− postAsMessage from $ DidUnlinkPort cid
553+ SendPortIdentifier cid ->
554+ postAsMessage from $ DidUnlinkPort cid
555555 modify' $ linksFor them ^: Set.delete from
556556
557557-- [Unified: Table 11]
558558ncEffectUnmonitor :: ProcessId -> MonitorRef -> NC ()
559559ncEffectUnmonitor from ref = do
560− node <- ask
561− when (isLocal node (ProcessIdentifier from)) $
560+ node <- ask
561+ when (isLocal node (ProcessIdentifier from)) $
562562 postAsMessage from $ DidUnmonitor ref
563563 modify' $ monitorsFor (monitorRefIdent ref) ^: Set.delete (from, ref)
564564
@@ -573,40 +573,40 @@ ncEffectDied ident reason = do
573573
574574 let localOnly = case ident of NodeIdentifier _ -> True ; _ -> False
575575
576− forM_ (Map.toList affectedLinks) $ \(them, uss) ->
576+ forM_ (Map.toList affectedLinks) $ \(them, uss) ->
577577 forM_ uss $ \us ->
578− when (localOnly <= isLocal node (ProcessIdentifier us)) $
578+ when (localOnly <= isLocal node (ProcessIdentifier us)) $
579579 notifyDied us them reason Nothing
580580
581581 forM_ (Map.toList affectedMons) $ \(them, refs) ->
582582 forM_ refs $ \(us, ref) ->
583583 when (localOnly <= isLocal node (ProcessIdentifier us)) $
584− notifyDied us them reason (Just ref)
584+ notifyDied us them reason (Just ref)
585585
586586 modify' $ (links ^= unaffectedLinks) . (monitors ^= unaffectedMons)
587587
588588 modify' $ registeredHere ^: Map.filter (\pid -> not $ ident `impliesDeathOf` ProcessIdentifier pid)
589589
590590 remaining <- fmap Map.toList (gets (^. registeredOnNodes)) >>=
591− mapM (\(pid,nidlist) ->
591+ mapM (\(pid,nidlist) ->
592592 case ident `impliesDeathOf` ProcessIdentifier pid of
593− True ->
593+ True ->
594594 do forM_ nidlist $ \(nid,_) ->
595− when (not $ isLocal node (NodeIdentifier nid))
595+ when (not $ isLocal node (NodeIdentifier nid))
596596 (forwardNameDeath node nid)
597597 return Nothing
598598 False -> return $ Just (pid,nidlist) )
599599 modify' $ registeredOnNodes ^= (Map.fromList (catMaybes remaining))
600− where
600+ where
601601 forwardNameDeath node nid =
602602 liftIO $ sendBinary node
603603 (NodeIdentifier $ localNodeId node)
604604 (NodeIdentifier $ nid)
605605 WithImplicitReconnect
606606 NCMsg
607− { ctrlMsgSender = NodeIdentifier (localNodeId node)
607+ { ctrlMsgSender = NodeIdentifier (localNodeId node)
608608 , ctrlMsgSignal = Died ident reason
609− }
609+ }
610610
611611
612612-- [Unified: Table 13]
@@ -622,9 +622,9 @@ ncEffectSpawn pid cProc ref = do
622622 pid' <- liftIO $ forkProcess node proc
623623 liftIO $ sendMessage node
624624 (NodeIdentifier (localNodeId node))
625− (ProcessIdentifier pid)
625+ (ProcessIdentifier pid)
626626 WithImplicitReconnect
627− (DidSpawn ref pid')
627+ (DidSpawn ref pid')
628628
629629-- Unified semantics does not explicitly describe how to implement 'register',
630630-- but mentions it's "very similar to nsend" (Table 14)
@@ -639,7 +639,7 @@ ncEffectRegister from label atnode mPid reregistration = do
639639 return $ isJust currentVal
640640 Just thepid -> -- register request
641641 do isvalidlocal <- isValidLocalIdentifier (ProcessIdentifier thepid)
642− return $ (isNothing currentVal /= reregistration) &&
642+ return $ (isNothing currentVal /= reregistration) &&
643643 (not (isLocal node (ProcessIdentifier thepid) ) || isvalidlocal )
644644 if isLocal node (NodeIdentifier atnode)
645645 then do when (isOk) $
@@ -647,10 +647,10 @@ ncEffectRegister from label atnode mPid reregistration = do
647647 updateRemote node currentVal mPid
648648 liftIO $ sendMessage node
649649 (NodeIdentifier (localNodeId node))
650− (ProcessIdentifier from)
650+ (ProcessIdentifier from)
651651 WithImplicitReconnect
652652 (RegisterReply label isOk)
653− else let operation =
653+ else let operation =
654654 case reregistration of
655655 True -> flip decList
656656 False -> flip incList
@@ -676,7 +676,7 @@ ncEffectRegister from label atnode mPid reregistration = do
676676 decList ((atag,1):xs) tag | atag == tag = xs
677677 decList ((atag,n):xs) tag | atag == tag = (atag,n-1):xs
678678 decList (x:xs) tag = x:decList xs tag
679− forward node to reg =
679+ forward node to reg =
680680 when (not $ isLocal node (NodeIdentifier to)) $
681681 liftIO $ sendBinary node
682682 (ProcessIdentifier from)
@@ -695,22 +695,22 @@ ncEffectWhereIs from label = do
695695 mPid <- gets (^. registeredHereFor label)
696696 liftIO $ sendMessage node
697697 (NodeIdentifier (localNodeId node))
698− (ProcessIdentifier from)
698+ (ProcessIdentifier from)
699699 WithImplicitReconnect
700700 (WhereIsReply label mPid)
701701
702702-- [Unified: Table 14]
703703ncEffectNamedSend :: Identifier -> String -> Message -> NC ()
704704ncEffectNamedSend from label msg = do
705− node <- ask
705+ node <- ask
706706 mPid <- gets (^. registeredHereFor label)
707707 -- If mPid is Nothing, we just ignore the named send (as per Table 14)
708− forM_ mPid $ \pid ->
708+ forM_ mPid $ \pid ->
709709 liftIO $ sendPayload node
710710 from
711− (ProcessIdentifier pid)
711+ (ProcessIdentifier pid)
712712 NoImplicitReconnect
713− (messageToPayload msg)
713+ (messageToPayload msg)
714714
715715--------------------------------------------------------------------------------
716716-- Auxiliary --
@@ -722,20 +722,20 @@ notifyDied :: ProcessId -- ^ Who to notify?
722722 -> Maybe MonitorRef -- ^ 'Nothing' for linking
723723 -> NC ()
724724notifyDied dest src reason mRef = do
725− node <- ask
725+ node <- ask
726726 case (isLocal node (ProcessIdentifier dest), mRef, src) of
727727 (True, Just ref, ProcessIdentifier pid) ->
728− postAsMessage dest $ ProcessMonitorNotification ref pid reason
728+ postAsMessage dest $ ProcessMonitorNotification ref pid reason
729729 (True, Just ref, NodeIdentifier nid) ->
730730 postAsMessage dest $ NodeMonitorNotification ref nid reason
731731 (True, Just ref, SendPortIdentifier cid) ->
732732 postAsMessage dest $ PortMonitorNotification ref cid reason
733733 (True, Nothing, ProcessIdentifier pid) ->
734− throwException dest $ ProcessLinkException pid reason
734+ throwException dest $ ProcessLinkException pid reason
735735 (True, Nothing, NodeIdentifier pid) ->
736− throwException dest $ NodeLinkException pid reason
736+ throwException dest $ NodeLinkException pid reason
737737 (True, Nothing, SendPortIdentifier pid) ->
738− throwException dest $ PortLinkException pid reason
738+ throwException dest $ PortLinkException pid reason
739739 (False, _, _) ->
740740 -- The change in sender comes from [Unified: Table 10]
741741 liftIO $ sendBinary node
@@ -743,30 +743,30 @@ notifyDied dest src reason mRef = do
743743 (NodeIdentifier $ processNodeId dest)
744744 WithImplicitReconnect
745745 NCMsg
746− { ctrlMsgSender = NodeIdentifier (localNodeId node)
746+ { ctrlMsgSender = NodeIdentifier (localNodeId node)
747747 , ctrlMsgSignal = Died src reason
748748 }
749−
749+
750750-- | [Unified: Table 8]
751751destNid :: ProcessSignal -> Maybe NodeId
752752destNid (Link ident) = Just $ nodeOf ident
753753destNid (Unlink ident) = Just $ nodeOf ident
754754destNid (Monitor ref) = Just $ nodeOf (monitorRefIdent ref)
755755destNid (Unmonitor ref) = Just $ nodeOf (monitorRefIdent ref)
756−destNid (Spawn _ _) = Nothing
756+destNid (Spawn _ _) = Nothing
757757destNid (Register _ _ _ _) = Nothing
758758destNid (WhereIs _) = Nothing
759759destNid (NamedSend _ _) = Nothing
760760-- We don't need to forward 'Died' signals; if monitoring/linking is setup,
761761-- then when a local process dies the monitoring/linking machinery will take
762762-- care of notifying remote nodes
763−destNid (Died _ _) = Nothing
763+destNid (Died _ _) = Nothing
764764
765765-- | Check if a process is local to our own node
766−isLocal :: LocalNode -> Identifier -> Bool
766+isLocal :: LocalNode -> Identifier -> Bool
767767isLocal nid ident = nodeOf ident == localNodeId nid
768768
769−-- | Lookup a local closure
769+-- | Lookup a local closure
770770unClosure :: Typeable a => Closure a -> NC (Either String a)
771771unClosure closure = do
772772 rtable <- remoteTable <$> ask
@@ -776,13 +776,13 @@ unClosure closure = do
776776isValidLocalIdentifier :: Identifier -> NC Bool
777777isValidLocalIdentifier ident = do
778778 node <- ask
779− liftIO . withMVar (localState node) $ \nSt ->
779+ liftIO . withMVar (localState node) $ \nSt ->
780780 case ident of
781781 NodeIdentifier nid ->
782782 return $ nid == localNodeId node
783783 ProcessIdentifier pid -> do
784784 let mProc = nSt ^. localProcessWithId (processLocalId pid)
785− return $ isJust mProc
785+ return $ isJust mProc
786786 SendPortIdentifier cid -> do
787787 let pid = sendPortProcessId cid
788788 mProc = nSt ^. localProcessWithId (processLocalId pid)
@@ -797,24 +797,24 @@ isValidLocalIdentifier ident = do
797797--------------------------------------------------------------------------------
798798
799799postAsMessage :: Serializable a => ProcessId -> a -> NC ()
800−postAsMessage pid = postMessage pid . createMessage
800+postAsMessage pid = postMessage pid . createMessage
801801
802802postMessage :: ProcessId -> Message -> NC ()
803803postMessage pid msg = withLocalProc pid $ \p -> enqueue (processQueue p) msg
804804
805805throwException :: Exception e => ProcessId -> e -> NC ()
806−throwException pid e = withLocalProc pid $ \p ->
806+throwException pid e = withLocalProc pid $ \p ->
807807 throwTo (processThread p) e
808808
809−withLocalProc :: ProcessId -> (LocalProcess -> IO ()) -> NC ()
809+withLocalProc :: ProcessId -> (LocalProcess -> IO ()) -> NC ()
810810withLocalProc pid p = do
811− node <- ask
812− liftIO $ do
811+ node <- ask
812+ liftIO $ do
813813 -- By [Unified: table 6, rule missing_process] messages to dead processes
814814 -- can silently be dropped
815815 let lpid = processLocalId pid
816816 mProc <- withMVar (localState node) $ return . (^. localProcessWithId lpid)
817− forM_ mProc p
817+ forM_ mProc p
818818
819819--------------------------------------------------------------------------------
820820-- Accessors --
@@ -851,23 +851,23 @@ registeredOnNodesFor ident = registeredOnNodes >>> DAC.mapMaybe ident
851851-- There is a hierarchy between identifiers: failure of a node implies failure
852852-- of all processes on that node, and failure of a process implies failure of
853853-- all typed channels to that process. In other words, if 'ident' refers to a
854−-- node, then the /should trigger/ set will include
854+-- node, then the /should trigger/ set will include
855855--
856856-- * the notifications for the node specifically
857−-- * the notifications for processes on that node, and
858−-- * the notifications for typed channels to processes on that node.
857+-- * the notifications for processes on that node, and
858+-- * the notifications for typed channels to processes on that node.
859859--
860860-- Similarly, if 'ident' refers to a process, the /should trigger/ set will
861−-- include
861+-- include
862862--
863−-- * the notifications for that process specifically and
863+-- * the notifications for that process specifically and
864864-- * the notifications for typed channels to that process.
865865--
866866-- See https://github.com/haskell/containers/issues/14 for the bang on _v.
867867splitNotif :: Identifier
868868 -> Map Identifier a
869869 -> (Map Identifier a, Map Identifier a)
870−splitNotif ident = Map.partitionWithKey (\k !_v -> ident `impliesDeathOf` k)
870+splitNotif ident = Map.partitionWithKey (\k !_v -> ident `impliesDeathOf` k)
871871
872872--------------------------------------------------------------------------------
873873-- Auxiliary --
distributed-process/src/Control/Distributed/Process/Serializable.hs+8−8
@@ -1,4 +1,4 @@
1−module Control.Distributed.Process.Serializable
1+module Control.Distributed.Process.Serializable
22 ( Serializable
33 , encodeFingerprint
44 , decodeFingerprint
@@ -35,29 +35,29 @@ instance (Binary a, Typeable a) => Serializable a
3535
3636-- | Encode type representation as a bytestring
3737encodeFingerprint :: Fingerprint -> ByteString
38−encodeFingerprint fp =
38+encodeFingerprint fp =
3939 -- Since all CH nodes will run precisely the same binary, we don't have to
4040 -- worry about cross-arch issues here (like endianness)
41− BSI.unsafeCreate sizeOfFingerprint $ \p -> pokeByteOff p 0 fp
41+ BSI.unsafeCreate sizeOfFingerprint $ \p -> pokeByteOff p 0 fp
4242
43−-- | Decode a bytestring into a fingerprint. Throws an IO exception on failure
43+-- | Decode a bytestring into a fingerprint. Throws an IO exception on failure
4444decodeFingerprint :: ByteString -> Fingerprint
4545decodeFingerprint bs
46− | BS.length bs /= sizeOfFingerprint =
46+ | BS.length bs /= sizeOfFingerprint =
4747 throw $ userError "decodeFingerprint: Invalid length"
4848 | otherwise = BSI.inlinePerformIO $ do
4949 let (fp, offset, _) = BSI.toForeignPtr bs
50− withForeignPtr fp $ \p -> peekByteOff p offset
50+ withForeignPtr fp $ \p -> peekByteOff p offset
5151
5252-- | Size of a fingerprint
5353sizeOfFingerprint :: Int
5454sizeOfFingerprint = sizeOf (undefined :: Fingerprint)
5555
56−-- | The fingerprint of the typeRep of the argument
56+-- | The fingerprint of the typeRep of the argument
5757fingerprint :: Typeable a => a -> Fingerprint
5858fingerprint a = let TypeRep fp _ _ = typeOf a in fp
5959
6060-- | Show fingerprint (for debugging purposes)
6161showFingerprint :: Fingerprint -> ShowS
62−showFingerprint (Fingerprint hi lo) =
62+showFingerprint (Fingerprint hi lo) =
6363 showString "(" . showHex hi . showString "," . showHex lo . showString ")"
distributed-process/tests/TestCH.hs+104−104
@@ -1,4 +1,4 @@
1−module Main where
1+module Main where
22
33#if ! MIN_VERSION_base(4,6,0)
44import Prelude hiding (catch)
@@ -9,7 +9,7 @@ import Data.Binary (Binary(..))
99import Data.Typeable (Typeable)
1010import Data.Foldable (forM_)
1111import Control.Concurrent (forkIO, threadDelay, myThreadId, throwTo, ThreadId)
12−import Control.Concurrent.MVar
12+import Control.Concurrent.MVar
1313 ( MVar
1414 , newEmptyMVar
1515 , putMVar
@@ -22,14 +22,14 @@ import qualified Control.Exception as Ex (catch)
2222import Control.Applicative ((<$>), (<*>), pure, (<|>))
2323import qualified Network.Transport as NT (Transport, closeEndPoint)
2424import Network.Socket (sClose)
25−import Network.Transport.TCP
25+import Network.Transport.TCP
2626 ( createTransportExposeInternals
2727 , TransportInternals(socketBetween)
2828 , defaultTCPParameters
2929 )
3030import Control.Distributed.Process
31−import Control.Distributed.Process.Internal.Types
32− ( NodeId(nodeAddress)
31+import Control.Distributed.Process.Internal.Types
32+ ( NodeId(nodeAddress)
3333 , LocalNode(localEndPoint)
3434 , RegisterReply(..)
3535 )
@@ -51,7 +51,7 @@ newtype Pong = Pong ProcessId
5151--------------------------------------------------------------------------------
5252
5353-- | Like fork, but throw exceptions in the child thread to the parent
54−forkTry :: IO () -> IO ThreadId
54+forkTry :: IO () -> IO ThreadId
5555forkTry p = do
5656 tid <- myThreadId
5757 forkIO $ Ex.catch p (\e -> throwTo tid (e :: SomeException))
@@ -71,7 +71,7 @@ whereisRemote nid string = do
7171 WhereIsReply _ mPid <- expect
7272 return mPid
7373
74−data Add = Add ProcessId Double Double deriving (Typeable)
74+data Add = Add ProcessId Double Double deriving (Typeable)
7575data Divide = Divide ProcessId Double Double deriving (Typeable)
7676data DivByZero = DivByZero deriving (Typeable)
7777
@@ -102,7 +102,7 @@ math = do
102102monitorOrLink :: Bool -- ^ 'True' for monitor, 'False' for link
103103 -> ProcessId -- Process to monitor/link to
104104 -> Maybe (MVar ()) -- MVar to signal on once the monitor has been set up
105− -> Process (Maybe MonitorRef)
105+ -> Process (Maybe MonitorRef)
106106monitorOrLink mOrL pid mSignal = do
107107 result <- if mOrL then Just <$> monitor pid
108108 else link pid >> return Nothing
@@ -116,11 +116,11 @@ monitorTestProcess :: ProcessId -- Process to monitor/link to
116116 -> Bool -- 'True' for monitor, 'False' for link
117117 -> Bool -- Should we unmonitor?
118118 -> DiedReason -- Expected cause of death
119− -> Maybe (MVar ()) -- Signal for 'monitor set up'
119+ -> Maybe (MVar ()) -- Signal for 'monitor set up'
120120 -> MVar () -- Signal for successful termination
121121 -> Process ()
122−monitorTestProcess theirAddr mOrL un reason monitorSetup done =
123− catch (do mRef <- monitorOrLink mOrL theirAddr monitorSetup
122+monitorTestProcess theirAddr mOrL un reason monitorSetup done =
123+ catch (do mRef <- monitorOrLink mOrL theirAddr monitorSetup
124124 case (un, mRef) of
125125 (True, Nothing) -> do
126126 unlink theirAddr
@@ -137,13 +137,13 @@ monitorTestProcess theirAddr mOrL un reason monitorSetup done =
137137 True <- return $ pid == theirAddr && not mOrL && not un && reason == reason'
138138 liftIO $ putMVar done ()
139139 )
140−
140+
141141--------------------------------------------------------------------------------
142142-- The tests proper --
143143--------------------------------------------------------------------------------
144144
145145-- | Basic ping test
146−testPing :: NT.Transport -> Assertion
146+testPing :: NT.Transport -> Assertion
147147testPing transport = do
148148 serverAddr <- newEmptyMVar
149149 clientDone <- newEmptyMVar
@@ -172,15 +172,15 @@ testPing transport = do
172172
173173 takeMVar clientDone
174174
175−-- | Monitor a process on an unreachable node
176−testMonitorUnreachable :: NT.Transport -> Bool -> Bool -> Assertion
175+-- | Monitor a process on an unreachable node
176+testMonitorUnreachable :: NT.Transport -> Bool -> Bool -> Assertion
177177testMonitorUnreachable transport mOrL un = do
178178 deadProcess <- newEmptyMVar
179179 done <- newEmptyMVar
180180
181181 forkIO $ do
182182 localNode <- newLocalNode transport initRemoteTable
183− addr <- forkProcess localNode . liftIO $ threadDelay 1000000
183+ addr <- forkProcess localNode . liftIO $ threadDelay 1000000
184184 closeLocalNode localNode
185185 putMVar deadProcess addr
186186
@@ -188,12 +188,12 @@ testMonitorUnreachable transport mOrL un = do
188188 localNode <- newLocalNode transport initRemoteTable
189189 theirAddr <- readMVar deadProcess
190190 runProcess localNode $
191− monitorTestProcess theirAddr mOrL un DiedDisconnect Nothing done
191+ monitorTestProcess theirAddr mOrL un DiedDisconnect Nothing done
192192
193193 takeMVar done
194194
195195-- | Monitor a process which terminates normally
196−testMonitorNormalTermination :: NT.Transport -> Bool -> Bool -> Assertion
196+testMonitorNormalTermination :: NT.Transport -> Bool -> Bool -> Assertion
197197testMonitorNormalTermination transport mOrL un = do
198198 monitorSetup <- newEmptyMVar
199199 monitoredProcess <- newEmptyMVar
@@ -201,20 +201,20 @@ testMonitorNormalTermination transport mOrL un = do
201201
202202 forkIO $ do
203203 localNode <- newLocalNode transport initRemoteTable
204− addr <- forkProcess localNode $
204+ addr <- forkProcess localNode $
205205 liftIO $ readMVar monitorSetup
206206 putMVar monitoredProcess addr
207207
208208 forkIO $ do
209209 localNode <- newLocalNode transport initRemoteTable
210210 theirAddr <- readMVar monitoredProcess
211− runProcess localNode $
211+ runProcess localNode $
212212 monitorTestProcess theirAddr mOrL un DiedNormal (Just monitorSetup) done
213213
214214 takeMVar done
215215
216216-- | Monitor a process which terminates abnormally
217−testMonitorAbnormalTermination :: NT.Transport -> Bool -> Bool -> Assertion
217+testMonitorAbnormalTermination :: NT.Transport -> Bool -> Bool -> Assertion
218218testMonitorAbnormalTermination transport mOrL un = do
219219 monitorSetup <- newEmptyMVar
220220 monitoredProcess <- newEmptyMVar
@@ -226,19 +226,19 @@ testMonitorAbnormalTermination transport mOrL un = do
226226 localNode <- newLocalNode transport initRemoteTable
227227 addr <- forkProcess localNode . liftIO $ do
228228 readMVar monitorSetup
229− throwIO err
229+ throwIO err
230230 putMVar monitoredProcess addr
231231
232232 forkIO $ do
233233 localNode <- newLocalNode transport initRemoteTable
234234 theirAddr <- readMVar monitoredProcess
235− runProcess localNode $
235+ runProcess localNode $
236236 monitorTestProcess theirAddr mOrL un (DiedException (show err)) (Just monitorSetup) done
237237
238238 takeMVar done
239−
239+
240240-- | Monitor a local process that is already dead
241−testMonitorLocalDeadProcess :: NT.Transport -> Bool -> Bool -> Assertion
241+testMonitorLocalDeadProcess :: NT.Transport -> Bool -> Bool -> Assertion
242242testMonitorLocalDeadProcess transport mOrL un = do
243243 processDead <- newEmptyMVar
244244 processAddr <- newEmptyMVar
@@ -258,7 +258,7 @@ testMonitorLocalDeadProcess transport mOrL un = do
258258 takeMVar done
259259
260260-- | Monitor a remote process that is already dead
261−testMonitorRemoteDeadProcess :: NT.Transport -> Bool -> Bool -> Assertion
261+testMonitorRemoteDeadProcess :: NT.Transport -> Bool -> Bool -> Assertion
262262testMonitorRemoteDeadProcess transport mOrL un = do
263263 processDead <- newEmptyMVar
264264 processAddr <- newEmptyMVar
@@ -279,7 +279,7 @@ testMonitorRemoteDeadProcess transport mOrL un = do
279279 takeMVar done
280280
281281-- | Monitor a process that becomes disconnected
282−testMonitorDisconnect :: NT.Transport -> Bool -> Bool -> Assertion
282+testMonitorDisconnect :: NT.Transport -> Bool -> Bool -> Assertion
283283testMonitorDisconnect transport mOrL un = do
284284 processAddr <- newEmptyMVar
285285 monitorSetup <- newEmptyMVar
@@ -287,7 +287,7 @@ testMonitorDisconnect transport mOrL un = do
287287
288288 forkIO $ do
289289 localNode <- newLocalNode transport initRemoteTable
290− addr <- forkProcess localNode . liftIO $ threadDelay 1000000
290+ addr <- forkProcess localNode . liftIO $ threadDelay 1000000
291291 putMVar processAddr addr
292292 readMVar monitorSetup
293293 NT.closeEndPoint (localEndPoint localNode)
@@ -297,18 +297,18 @@ testMonitorDisconnect transport mOrL un = do
297297 theirAddr <- readMVar processAddr
298298 runProcess localNode $ do
299299 monitorTestProcess theirAddr mOrL un DiedDisconnect (Just monitorSetup) done
300−
300+
301301 takeMVar done
302302
303303-- | Test the math server (i.e., receiveWait)
304−testMath :: NT.Transport -> Assertion
304+testMath :: NT.Transport -> Assertion
305305testMath transport = do
306− serverAddr <- newEmptyMVar
306+ serverAddr <- newEmptyMVar
307307 clientDone <- newEmptyMVar
308308
309309 -- Server
310310 forkIO $ do
311− localNode <- newLocalNode transport initRemoteTable
311+ localNode <- newLocalNode transport initRemoteTable
312312 addr <- forkProcess localNode math
313313 putMVar serverAddr addr
314314
@@ -320,7 +320,7 @@ testMath transport = do
320320 runProcess localNode $ do
321321 pid <- getSelfPid
322322 send mathServer (Add pid 1 2)
323− 3 <- expect :: Process Double
323+ 3 <- expect :: Process Double
324324 send mathServer (Divide pid 8 2)
325325 4 <- expect :: Process Double
326326 send mathServer (Divide pid 8 0)
@@ -330,15 +330,15 @@ testMath transport = do
330330 takeMVar clientDone
331331
332332-- | Send first message (i.e. connect) to an already terminated process
333−-- (without monitoring); then send another message to a second process on
333+-- (without monitoring); then send another message to a second process on
334334-- the same remote node (we're checking that the remote node did not die)
335−testSendToTerminated :: NT.Transport -> Assertion
335+testSendToTerminated :: NT.Transport -> Assertion
336336testSendToTerminated transport = do
337337 serverAddr1 <- newEmptyMVar
338338 serverAddr2 <- newEmptyMVar
339339 clientDone <- newEmptyMVar
340340
341− forkIO $ do
341+ forkIO $ do
342342 terminated <- newEmptyMVar
343343 localNode <- newLocalNode transport initRemoteTable
344344 addr1 <- forkProcess localNode $ liftIO $ putMVar terminated ()
@@ -356,13 +356,13 @@ testSendToTerminated transport = do
356356 send server1 "Hi"
357357 send server2 (Pong pid)
358358 Ping pid' <- expect
359− True <- return $ pid' == server2
359+ True <- return $ pid' == server2
360360 liftIO $ putMVar clientDone ()
361361
362362 takeMVar clientDone
363363
364364-- | Test (non-zero) timeout
365−testTimeout :: NT.Transport -> Assertion
365+testTimeout :: NT.Transport -> Assertion
366366testTimeout transport = do
367367 localNode <- newLocalNode transport initRemoteTable
368368 runProcess localNode $ do
@@ -370,20 +370,20 @@ testTimeout transport = do
370370 return ()
371371
372372-- | Test zero timeout
373−testTimeout0 :: NT.Transport -> Assertion
373+testTimeout0 :: NT.Transport -> Assertion
374374testTimeout0 transport = do
375375 serverAddr <- newEmptyMVar
376376 clientDone <- newEmptyMVar
377377 messagesSent <- newEmptyMVar
378378
379− forkIO $ do
379+ forkIO $ do
380380 localNode <- newLocalNode transport initRemoteTable
381381 addr <- forkProcess localNode $ do
382382 liftIO $ readMVar messagesSent >> threadDelay 1000000
383383 -- Variation on the venerable ping server which uses a zero timeout
384384 -- Since we wait for all messages to be sent before doing this receive,
385385 -- we should nevertheless find the right message immediately
386− Just partner <- receiveTimeout 0 [match (\(Pong partner) -> return partner)]
386+ Just partner <- receiveTimeout 0 [match (\(Pong partner) -> return partner)]
387387 self <- getSelfPid
388388 send partner (Ping self)
389389 putMVar serverAddr addr
@@ -398,13 +398,13 @@ testTimeout0 transport = do
398398 replicateM_ 10000 $ send server "Irrelevant message"
399399 send server (Pong pid)
400400 liftIO $ putMVar messagesSent ()
401− Ping _ <- expect
401+ Ping _ <- expect
402402 liftIO $ putMVar clientDone ()
403403
404404 takeMVar clientDone
405405
406406-- | Test typed channels
407−testTypedChannels :: NT.Transport -> Assertion
407+testTypedChannels :: NT.Transport -> Assertion
408408testTypedChannels transport = do
409409 serverChannel <- newEmptyMVar :: IO (MVar (SendPort (SendPort Bool, Int)))
410410 clientDone <- newEmptyMVar
@@ -413,7 +413,7 @@ testTypedChannels transport = do
413413 localNode <- newLocalNode transport initRemoteTable
414414 forkProcess localNode $ do
415415 (serverSendPort, rport) <- newChan
416− liftIO $ putMVar serverChannel serverSendPort
416+ liftIO $ putMVar serverChannel serverSendPort
417417 (clientSendPort, i) <- receiveChan rport
418418 sendChan clientSendPort (even i)
419419 return ()
@@ -423,14 +423,14 @@ testTypedChannels transport = do
423423 serverSendPort <- readMVar serverChannel
424424 runProcess localNode $ do
425425 (clientSendPort, rport) <- newChan
426− sendChan serverSendPort (clientSendPort, 5)
426+ sendChan serverSendPort (clientSendPort, 5)
427427 False <- receiveChan rport
428428 liftIO $ putMVar clientDone ()
429−
430− takeMVar clientDone
429+
430+ takeMVar clientDone
431431
432432-- | Test merging receive ports
433−testMergeChannels :: NT.Transport -> Assertion
433+testMergeChannels :: NT.Transport -> Assertion
434434testMergeChannels transport = do
435435 localNode <- newLocalNode transport initRemoteTable
436436 testFlat localNode True "aaabbbccc"
@@ -443,13 +443,13 @@ testMergeChannels transport = do
443443 testBlocked localNode False
444444 where
445445 -- Single layer of merging
446− testFlat :: LocalNode -> Bool -> String -> IO ()
446+ testFlat :: LocalNode -> Bool -> String -> IO ()
447447 testFlat localNode biased expected = do
448448 done <- newEmptyMVar
449449 forkProcess localNode $ do
450− rs <- mapM charChannel "abc"
451− m <- mergePorts biased rs
452− xs <- replicateM 9 $ receiveChan m
450+ rs <- mapM charChannel "abc"
451+ m <- mergePorts biased rs
452+ xs <- replicateM 9 $ receiveChan m
453453 True <- return $ xs == expected
454454 liftIO $ putMVar done ()
455455 takeMVar done
@@ -462,7 +462,7 @@ testMergeChannels transport = do
462462 rss <- mapM (mapM charChannel) ["abc", "def", "ghi"]
463463 ms <- mapM (mergePorts biasedInner) rss
464464 m <- mergePorts biasedOuter ms
465− xs <- replicateM (9 * 3) $ receiveChan m
465+ xs <- replicateM (9 * 3) $ receiveChan m
466466 True <- return $ xs == expected
467467 liftIO $ putMVar done ()
468468 takeMVar done
@@ -470,12 +470,12 @@ testMergeChannels transport = do
470470 -- Test that if no messages are (immediately) available, the scheduler makes no difference
471471 testBlocked :: LocalNode -> Bool -> IO ()
472472 testBlocked localNode biased = do
473− vs <- replicateM 3 newEmptyMVar
473+ vs <- replicateM 3 newEmptyMVar
474474 done <- newEmptyMVar
475475
476476 forkProcess localNode $ do
477− [sa, sb, sc] <- liftIO $ mapM readMVar vs
478− mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)
477+ [sa, sb, sc] <- liftIO $ mapM readMVar vs
478+ mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)
479479 [ -- a, b, c
480480 (sa, 'a')
481481 , (sb, 'b')
@@ -504,8 +504,8 @@ testMergeChannels transport = do
504504
505505 forkProcess localNode $ do
506506 (ss, rs) <- unzip <$> replicateM 3 newChan
507− liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
508− m <- mergePorts biased rs
507+ liftIO $ mapM_ (uncurry putMVar) $ zip vs ss
508+ m <- mergePorts biased rs
509509 xs <- replicateM (6 * 3) $ receiveChan m
510510 True <- return $ xs == "abcacbbacbcacabcba"
511511 liftIO $ putMVar done ()
@@ -514,16 +514,16 @@ testMergeChannels transport = do
514514
515515 mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
516516 mergePorts True = mergePortsBiased
517− mergePorts False = mergePortsRR
517+ mergePorts False = mergePortsRR
518518
519519 charChannel :: Char -> Process (ReceivePort Char)
520520 charChannel c = do
521521 (sport, rport) <- newChan
522− replicateM_ 3 $ sendChan sport c
522+ replicateM_ 3 $ sendChan sport c
523523 liftIO $ threadDelay 10000 -- Make sure messages have been sent
524524 return rport
525525
526−testTerminate :: NT.Transport -> Assertion
526+testTerminate :: NT.Transport -> Assertion
527527testTerminate transport = do
528528 localNode <- newLocalNode transport initRemoteTable
529529
@@ -534,10 +534,10 @@ testTerminate transport = do
534534 runProcess localNode $ do
535535 ref <- monitor pid
536536 ProcessMonitorNotification ref' pid' (DiedException ex) <- expect
537− True <- return $ ref == ref' && pid == pid' && ex == show ProcessTerminationException
537+ True <- return $ ref == ref' && pid == pid' && ex == show ProcessTerminationException
538538 return ()
539539
540−testMonitorNode :: NT.Transport -> Assertion
540+testMonitorNode :: NT.Transport -> Assertion
541541testMonitorNode transport = do
542542 [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
543543
@@ -549,7 +549,7 @@ testMonitorNode transport = do
549549 True <- return $ ref == ref' && nid == localNodeId node1
550550 return ()
551551
552−testMonitorChannel :: NT.Transport -> Assertion
552+testMonitorChannel :: NT.Transport -> Assertion
553553testMonitorChannel transport = do
554554 [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
555555 gotNotification <- newEmptyMVar
@@ -558,7 +558,7 @@ testMonitorChannel transport = do
558558 sport <- expect :: Process (SendPort ())
559559 ref <- monitorPort sport
560560 PortMonitorNotification ref' port' reason <- expect
561− -- reason might be DiedUnknownId if the receive port is GCed before the
561+ -- reason might be DiedUnknownId if the receive port is GCed before the
562562 -- monitor is established (TODO: not sure that this is reasonable)
563563 return $ ref' == ref && port' == sendPortId sport && (reason == DiedNormal || reason == DiedUnknownId)
564564 liftIO $ putMVar gotNotification ()
@@ -570,45 +570,45 @@ testMonitorChannel transport = do
570570
571571 takeMVar gotNotification
572572
573−testRegistry :: NT.Transport -> Assertion
573+testRegistry :: NT.Transport -> Assertion
574574testRegistry transport = do
575575 node <- newLocalNode transport initRemoteTable
576576
577− pingServer <- forkProcess node ping
577+ pingServer <- forkProcess node ping
578578
579579 runProcess node $ do
580580 register "ping" pingServer
581581 Just pid <- whereis "ping"
582− True <- return $ pingServer == pid
582+ True <- return $ pingServer == pid
583583 us <- getSelfPid
584584 nsend "ping" (Pong us)
585− Ping pid' <- expect
585+ Ping pid' <- expect
586586 True <- return $ pingServer == pid'
587587 return ()
588588
589−testRemoteRegistry :: NT.Transport -> Assertion
589+testRemoteRegistry :: NT.Transport -> Assertion
590590testRemoteRegistry transport = do
591591 node1 <- newLocalNode transport initRemoteTable
592592 node2 <- newLocalNode transport initRemoteTable
593593
594− pingServer <- forkProcess node1 ping
594+ pingServer <- forkProcess node1 ping
595595
596596 runProcess node2 $ do
597597 let nid1 = localNodeId node1
598598 registerRemoteAsync nid1 "ping" pingServer
599− receiveWait [
599+ receiveWait [
600600 matchIf (\(RegisterReply label' _) -> "ping" == label')
601601 (\(RegisterReply _ _) -> return ()) ]
602602
603603 Just pid <- whereisRemote nid1 "ping"
604− True <- return $ pingServer == pid
604+ True <- return $ pingServer == pid
605605 us <- getSelfPid
606606 nsendRemote nid1 "ping" (Pong us)
607− Ping pid' <- expect
607+ Ping pid' <- expect
608608 True <- return $ pingServer == pid'
609609 return ()
610610
611−testSpawnLocal :: NT.Transport -> Assertion
611+testSpawnLocal :: NT.Transport -> Assertion
612612testSpawnLocal transport = do
613613 node <- newLocalNode transport initRemoteTable
614614
@@ -626,7 +626,7 @@ testSpawnLocal transport = do
626626 send pid sport
627627 expect
628628
629−testReconnect :: NT.Transport -> TransportInternals -> Assertion
629+testReconnect :: NT.Transport -> TransportInternals -> Assertion
630630testReconnect transport transportInternals = do
631631 [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
632632 let nid1 = localNodeId node1
@@ -651,40 +651,40 @@ testReconnect transport transportInternals = do
651651 send them "message 1" >> liftIO (threadDelay 100000)
652652
653653 -- Simulate network failure
654− liftIO $ do
654+ liftIO $ do
655655 sock <- socketBetween transportInternals (nodeAddress nid1) (nodeAddress nid2)
656656 sClose sock
657657 threadDelay 10000
658658
659659 -- Should not arrive
660− send them "message 2"
660+ send them "message 2"
661661
662662 -- Should arrive
663663 reconnect them
664− send them "message 3"
664+ send them "message 3"
665665
666666 liftIO $ takeMVar sendTestOk
667667
668668 {-
669669 - Test that there *is* implicit reconnect on node controller messages
670670 -}
671−
671+
672672 us <- getSelfPid
673673 registerRemoteAsync nid1 "a" us -- registerRemote is asynchronous
674674 receiveWait [
675675 matchIf (\(RegisterReply label' _) -> "a" == label')
676676 (\(RegisterReply _ _) -> return ()) ]
677677
678− Just _ <- whereisRemote nid1 "a"
679−
678+ Just _ <- whereisRemote nid1 "a"
679+
680680
681681 -- Simulate network failure
682− liftIO $ do
682+ liftIO $ do
683683 sock <- socketBetween transportInternals (nodeAddress nid1) (nodeAddress nid2)
684684 sClose sock
685685 threadDelay 10000
686686
687− -- This will happen due to implicit reconnect
687+ -- This will happen due to implicit reconnect
688688 registerRemoteAsync nid1 "b" us
689689 receiveWait [
690690 matchIf (\(RegisterReply label' _) -> "b" == label')
@@ -699,27 +699,27 @@ testReconnect transport transportInternals = do
699699 -- Check
700700 Nothing <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected
701701 Just _ <- whereisRemote nid1 "b" -- this will suceed because the value is set after thereconnect
702− Just _ <- whereisRemote nid1 "c"
702+ Just _ <- whereisRemote nid1 "c"
703703
704704 liftIO $ putMVar registerTestOk ()
705705
706706 takeMVar registerTestOk
707707
708−-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
708+-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
709709-- in between
710−testMatchAny :: NT.Transport -> Assertion
710+testMatchAny :: NT.Transport -> Assertion
711711testMatchAny transport = do
712− proxyAddr <- newEmptyMVar
712+ proxyAddr <- newEmptyMVar
713713 clientDone <- newEmptyMVar
714714
715715 -- Math server
716716 forkIO $ do
717− localNode <- newLocalNode transport initRemoteTable
717+ localNode <- newLocalNode transport initRemoteTable
718718 mathServer <- forkProcess localNode math
719− proxyServer <- forkProcess localNode $ forever $ do
719+ proxyServer <- forkProcess localNode $ forever $ do
720720 msg <- receiveWait [ matchAny return ]
721721 forward msg mathServer
722− putMVar proxyAddr proxyServer
722+ putMVar proxyAddr proxyServer
723723
724724 -- Client
725725 forkIO $ do
@@ -729,7 +729,7 @@ testMatchAny transport = do
729729 runProcess localNode $ do
730730 pid <- getSelfPid
731731 send mathServer (Add pid 1 2)
732− 3 <- expect :: Process Double
732+ 3 <- expect :: Process Double
733733 send mathServer (Divide pid 8 2)
734734 4 <- expect :: Process Double
735735 send mathServer (Divide pid 8 0)
@@ -739,11 +739,11 @@ testMatchAny transport = do
739739 takeMVar clientDone
740740
741741-- Test 'receiveChanTimeout'
742−testReceiveChanTimeout :: NT.Transport -> Assertion
742+testReceiveChanTimeout :: NT.Transport -> Assertion
743743testReceiveChanTimeout transport = do
744744 done <- newEmptyMVar
745745 sendPort <- newEmptyMVar
746−
746+
747747 forkTry $ do
748748 localNode <- newLocalNode transport initRemoteTable
749749 runProcess localNode $ do
@@ -751,7 +751,7 @@ testReceiveChanTimeout transport = do
751751 (sp, rp) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
752752 liftIO $ putMVar sendPort sp
753753
754− -- Wait for a message with a delay. No message arrives, we should get Nothing after 1 second
754+ -- Wait for a message with a delay. No message arrives, we should get Nothing after 1 second
755755 Nothing <- receiveChanTimeout 1000000 rp
756756
757757 -- Wait for a message with a delay again. Now a message arrives after 0.5 seconds
@@ -762,7 +762,7 @@ testReceiveChanTimeout transport = do
762762
763763 -- Again, but now there is a message available
764764 liftIO $ threadDelay 1000000
765− Just False <- receiveChanTimeout 0 rp
765+ Just False <- receiveChanTimeout 0 rp
766766
767767 liftIO $ putMVar done ()
768768
@@ -810,9 +810,9 @@ testReceiveChanFeatures transport = do
810810 7 <- receiveChan rp2
811811
812812 -- Test Alternative instance
813−
813+
814814 sendChan spInt 3
815− sendChan spBool True
815+ sendChan spBool True
816816
817817 let rp3 = (even <$> rpInt) <|> rpBool
818818
@@ -820,14 +820,14 @@ testReceiveChanFeatures transport = do
820820 True <- receiveChan rp3
821821
822822 -- Test Monad instance
823−
823+
824824 sendChan spBool True
825825 sendChan spBool False
826826 sendChan spInt 5
827827
828828 let rp4 :: ReceivePort Int
829829 rp4 = do b <- rpBool
830− if b
830+ if b
831831 then rpInt
832832 else return 7
833833
@@ -839,13 +839,13 @@ testReceiveChanFeatures transport = do
839839 takeMVar done
840840
841841tests :: (NT.Transport, TransportInternals) -> [Test]
842−tests (transport, transportInternals) = [
842+tests (transport, transportInternals) = [
843843 testGroup "Basic features" [
844844 testCase "Ping" (testPing transport)
845− , testCase "Math" (testMath transport)
845+ , testCase "Math" (testMath transport)
846846 , testCase "Timeout" (testTimeout transport)
847847 , testCase "Timeout0" (testTimeout0 transport)
848− , testCase "SendToTerminated" (testSendToTerminated transport)
848+ , testCase "SendToTerminated" (testSendToTerminated transport)
849849 , testCase "TypedChannnels" (testTypedChannels transport)
850850 , testCase "MergeChannels" (testMergeChannels transport)
851851 , testCase "Terminate" (testTerminate transport)
@@ -860,7 +860,7 @@ tests (transport, transportInternals) = [
860860 -- Monitoring processes
861861 --
862862 -- The "missing" combinations in the list below don't make much sense, as
863− -- we cannot guarantee that the monitor reply or link exception will not
863+ -- we cannot guarantee that the monitor reply or link exception will not
864864 -- happen before the unmonitor or unlink
865865 testCase "MonitorUnreachable" (testMonitorUnreachable transport True False)
866866 , testCase "MonitorNormalTermination" (testMonitorNormalTermination transport True False)
distributed-process/tests/TestClosure.hs+66−66
@@ -6,7 +6,7 @@ import Data.Typeable (Typeable)
66import Control.Monad (join, replicateM, forever, replicateM_, void)
77import Control.Exception (IOException, throw)
88import Control.Concurrent (forkIO, threadDelay)
9−import Control.Concurrent.MVar
9+import Control.Concurrent.MVar
1010 ( MVar
1111 , newEmptyMVar
1212 , readMVar
@@ -18,12 +18,12 @@ import Control.Concurrent.MVar
1818import Control.Applicative ((<$>))
1919import System.Random (randomIO)
2020import Network.Transport (Transport)
21−import Network.Transport.TCP
21+import Network.Transport.TCP
2222 ( createTransportExposeInternals
2323 , defaultTCPParameters
2424 , TransportInternals(socketBetween)
2525 )
26−import Network.Socket (sClose)
26+import Network.Socket (sClose)
2727import Control.Distributed.Process
2828import Control.Distributed.Process.Closure
2929import Control.Distributed.Process.Node
@@ -46,7 +46,7 @@ sdictInt = SerializableDict
4646
4747factorial :: Int -> Process Int
4848factorial 0 = return 1
49−factorial n = (n *) <$> factorial (n - 1)
49+factorial n = (n *) <$> factorial (n - 1)
5050
5151addInt :: Int -> Int -> Int
5252addInt x y = x + y
@@ -95,7 +95,7 @@ randomElement xs = do
9595 ix <- randomIO
9696 return (xs !! (ix `mod` length xs))
9797
98−remotableDecl [
98+remotableDecl [
9999 [d| dfib :: ([NodeId], SendPort Integer, Integer) -> Process () ;
100100 dfib (_, reply, 0) = sendChan reply 0
101101 dfib (_, reply, 1) = sendChan reply 1
@@ -117,33 +117,33 @@ staticQuintuple :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e)
117117staticQuintuple = $(mkStatic 'quintuple)
118118
119119factorialClosure :: Int -> Closure (Process Int)
120−factorialClosure = $(mkClosure 'factorial)
120+factorialClosure = $(mkClosure 'factorial)
121121
122122addIntClosure :: Int -> Closure (Int -> Int)
123−addIntClosure = $(mkClosure 'addInt)
123+addIntClosure = $(mkClosure 'addInt)
124124
125125putIntClosure :: Int -> Closure (MVar Int -> IO ())
126−putIntClosure = $(mkClosure 'putInt)
126+putIntClosure = $(mkClosure 'putInt)
127127
128128sendPidClosure :: ProcessId -> Closure (Process ())
129−sendPidClosure = $(mkClosure 'sendPid)
129+sendPidClosure = $(mkClosure 'sendPid)
130130
131131sendFac :: Int -> ProcessId -> Closure (Process ())
132−sendFac n pid = factorialClosure n `bindCP` cpSend $(mkStatic 'sdictInt) pid
132+sendFac n pid = factorialClosure n `bindCP` cpSend $(mkStatic 'sdictInt) pid
133133
134134factorialOf :: Closure (Int -> Process Int)
135135factorialOf = staticClosure $(mkStatic 'factorial)
136136
137137factorial' :: Int -> Closure (Process Int)
138−factorial' n = returnCP $(mkStatic 'sdictInt) n `bindCP` factorialOf
138+factorial' n = returnCP $(mkStatic 'sdictInt) n `bindCP` factorialOf
139139
140140waitClosure :: Int -> Closure (Process ())
141−waitClosure = $(mkClosure 'wait)
141+waitClosure = $(mkClosure 'wait)
142142
143143simulateNetworkFailure :: TransportInternals -> NodeId -> NodeId -> Process ()
144144simulateNetworkFailure transportInternals fr to = liftIO $ do
145145 threadDelay 10000
146− sock <- socketBetween transportInternals (nodeAddress fr) (nodeAddress to)
146+ sock <- socketBetween transportInternals (nodeAddress fr) (nodeAddress to)
147147 sClose sock
148148 threadDelay 10000
149149
@@ -160,87 +160,87 @@ testUnclosure transport rtable = do
160160 liftIO $ putMVar done ()
161161 takeMVar done
162162
163−testBind :: Transport -> RemoteTable -> Assertion
163+testBind :: Transport -> RemoteTable -> Assertion
164164testBind transport rtable = do
165165 node <- newLocalNode transport rtable
166166 done <- newEmptyMVar
167167 runProcess node $ do
168168 us <- getSelfPid
169− join . unClosure $ sendFac 6 us
170− (720 :: Int) <- expect
169+ join . unClosure $ sendFac 6 us
170+ (720 :: Int) <- expect
171171 liftIO $ putMVar done ()
172172 takeMVar done
173173
174−testSendPureClosure :: Transport -> RemoteTable -> Assertion
174+testSendPureClosure :: Transport -> RemoteTable -> Assertion
175175testSendPureClosure transport rtable = do
176176 serverAddr <- newEmptyMVar
177177 serverDone <- newEmptyMVar
178178
179− forkIO $ do
180− node <- newLocalNode transport rtable
179+ forkIO $ do
180+ node <- newLocalNode transport rtable
181181 addr <- forkProcess node $ do
182182 cl <- expect
183183 fn <- unClosure cl :: Process (Int -> Int)
184184 13 <- return $ fn 6
185− liftIO $ putMVar serverDone ()
186− putMVar serverAddr addr
185+ liftIO $ putMVar serverDone ()
186+ putMVar serverAddr addr
187187
188188 forkIO $ do
189− node <- newLocalNode transport rtable
189+ node <- newLocalNode transport rtable
190190 theirAddr <- readMVar serverAddr
191191 runProcess node $ send theirAddr (addIntClosure 7)
192192
193193 takeMVar serverDone
194194
195−testSendIOClosure :: Transport -> RemoteTable -> Assertion
195+testSendIOClosure :: Transport -> RemoteTable -> Assertion
196196testSendIOClosure transport rtable = do
197197 serverAddr <- newEmptyMVar
198198 serverDone <- newEmptyMVar
199199
200− forkIO $ do
201− node <- newLocalNode transport rtable
200+ forkIO $ do
201+ node <- newLocalNode transport rtable
202202 addr <- forkProcess node $ do
203203 cl <- expect
204204 io <- unClosure cl :: Process (MVar Int -> IO ())
205− liftIO $ do
205+ liftIO $ do
206206 someMVar <- newEmptyMVar
207− io someMVar
207+ io someMVar
208208 5 <- readMVar someMVar
209− putMVar serverDone ()
210− putMVar serverAddr addr
209+ putMVar serverDone ()
210+ putMVar serverAddr addr
211211
212212 forkIO $ do
213− node <- newLocalNode transport rtable
213+ node <- newLocalNode transport rtable
214214 theirAddr <- readMVar serverAddr
215− runProcess node $ send theirAddr (putIntClosure 5)
215+ runProcess node $ send theirAddr (putIntClosure 5)
216216
217217 takeMVar serverDone
218218
219−testSendProcClosure :: Transport -> RemoteTable -> Assertion
219+testSendProcClosure :: Transport -> RemoteTable -> Assertion
220220testSendProcClosure transport rtable = do
221221 serverAddr <- newEmptyMVar
222222 clientDone <- newEmptyMVar
223223
224− forkIO $ do
225− node <- newLocalNode transport rtable
224+ forkIO $ do
225+ node <- newLocalNode transport rtable
226226 addr <- forkProcess node $ do
227227 cl <- expect
228228 pr <- unClosure cl :: Process (Int -> Process ())
229229 pr 5
230− putMVar serverAddr addr
230+ putMVar serverAddr addr
231231
232232 forkIO $ do
233− node <- newLocalNode transport rtable
233+ node <- newLocalNode transport rtable
234234 theirAddr <- readMVar serverAddr
235235 runProcess node $ do
236236 pid <- getSelfPid
237− send theirAddr (cpSend $(mkStatic 'sdictInt) pid)
237+ send theirAddr (cpSend $(mkStatic 'sdictInt) pid)
238238 5 <- expect :: Process Int
239239 liftIO $ putMVar clientDone ()
240240
241241 takeMVar clientDone
242242
243−testSpawn :: Transport -> RemoteTable -> Assertion
243+testSpawn :: Transport -> RemoteTable -> Assertion
244244testSpawn transport rtable = do
245245 serverNodeAddr <- newEmptyMVar
246246 clientDone <- newEmptyMVar
@@ -261,7 +261,7 @@ testSpawn transport rtable = do
261261
262262 takeMVar clientDone
263263
264−testCall :: Transport -> RemoteTable -> Assertion
264+testCall :: Transport -> RemoteTable -> Assertion
265265testCall transport rtable = do
266266 serverNodeAddr <- newEmptyMVar
267267 clientDone <- newEmptyMVar
@@ -279,7 +279,7 @@ testCall transport rtable = do
279279
280280 takeMVar clientDone
281281
282−testCallBind :: Transport -> RemoteTable -> Assertion
282+testCallBind :: Transport -> RemoteTable -> Assertion
283283testCallBind transport rtable = do
284284 serverNodeAddr <- newEmptyMVar
285285 clientDone <- newEmptyMVar
@@ -297,7 +297,7 @@ testCallBind transport rtable = do
297297
298298 takeMVar clientDone
299299
300−testSeq :: Transport -> RemoteTable -> Assertion
300+testSeq :: Transport -> RemoteTable -> Assertion
301301testSeq transport rtable = do
302302 node <- newLocalNode transport rtable
303303 done <- newEmptyMVar
@@ -315,7 +315,7 @@ testSeq transport rtable = do
315315-- child. The supervisor then throws an exception, the child dies because it
316316-- was linked to the supervisor, and the third process notices that the child
317317-- dies.
318−testSpawnSupervised :: Transport -> RemoteTable -> Assertion
318+testSpawnSupervised :: Transport -> RemoteTable -> Assertion
319319testSpawnSupervised transport rtable = do
320320 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
321321 [superPid, childPid] <- replicateM 2 $ newEmptyMVar
@@ -324,7 +324,7 @@ testSpawnSupervised transport rtable = do
324324 forkProcess node1 $ do
325325 us <- getSelfPid
326326 liftIO $ putMVar superPid us
327− (child, _ref) <- spawnSupervised (localNodeId node2) (waitClosure 1000000)
327+ (child, _ref) <- spawnSupervised (localNodeId node2) (waitClosure 1000000)
328328 liftIO $ do
329329 putMVar childPid child
330330 threadDelay 500000 -- Give the child a chance to link to us
@@ -334,8 +334,8 @@ testSpawnSupervised transport rtable = do
334334 [super, child] <- liftIO $ mapM readMVar [superPid, childPid]
335335 ref <- monitor child
336336 ProcessMonitorNotification ref' pid' (DiedException e) <- expect
337− True <- return $ ref' == ref
338− && pid' == child
337+ True <- return $ ref' == ref
338+ && pid' == child
339339 && e == show (ProcessLinkException super (DiedException (show supervisorDeath)))
340340 liftIO $ putMVar thirdProcessDone ()
341341
@@ -344,19 +344,19 @@ testSpawnSupervised transport rtable = do
344344 supervisorDeath :: IOException
345345 supervisorDeath = userError "Supervisor died"
346346
347−testSpawnInvalid :: Transport -> RemoteTable -> Assertion
347+testSpawnInvalid :: Transport -> RemoteTable -> Assertion
348348testSpawnInvalid transport rtable = do
349349 node <- newLocalNode transport rtable
350350 done <- newEmptyMVar
351351 forkProcess node $ do
352352 (pid, ref) <- spawnMonitor (localNodeId node) (closure (staticLabel "ThisDoesNotExist") empty)
353− ProcessMonitorNotification ref' pid' _reason <- expect
353+ ProcessMonitorNotification ref' pid' _reason <- expect
354354 -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure
355− True <- return $ ref' == ref && pid == pid'
355+ True <- return $ ref' == ref && pid == pid'
356356 liftIO $ putMVar done ()
357357 takeMVar done
358358
359−testClosureExpect :: Transport -> RemoteTable -> Assertion
359+testClosureExpect :: Transport -> RemoteTable -> Assertion
360360testClosureExpect transport rtable = do
361361 node <- newLocalNode transport rtable
362362 done <- newEmptyMVar
@@ -369,15 +369,15 @@ testClosureExpect transport rtable = do
369369 liftIO $ putMVar done ()
370370 takeMVar done
371371
372−testSpawnChannel :: Transport -> RemoteTable -> Assertion
372+testSpawnChannel :: Transport -> RemoteTable -> Assertion
373373testSpawnChannel transport rtable = do
374374 done <- newEmptyMVar
375375 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
376376
377377 forkProcess node1 $ do
378− pingServer <- spawnChannel
378+ pingServer <- spawnChannel
379379 (sdictSendPort sdictUnit)
380− (localNodeId node2)
380+ (localNodeId node2)
381381 ($(mkClosure 'typedPingServer) ())
382382 (sendReply, receiveReply) <- newChan
383383 sendChan pingServer sendReply
@@ -386,7 +386,7 @@ testSpawnChannel transport rtable = do
386386
387387 takeMVar done
388388
389−testTDict :: Transport -> RemoteTable -> Assertion
389+testTDict :: Transport -> RemoteTable -> Assertion
390390testTDict transport rtable = do
391391 done <- newEmptyMVar
392392 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
@@ -395,7 +395,7 @@ testTDict transport rtable = do
395395 liftIO $ putMVar done ()
396396 takeMVar done
397397
398−testFib :: Transport -> RemoteTable -> Assertion
398+testFib :: Transport -> RemoteTable -> Assertion
399399testFib transport rtable = do
400400 nodes <- replicateM 4 $ newLocalNode transport rtable
401401 done <- newEmptyMVar
@@ -408,28 +408,28 @@ testFib transport rtable = do
408408
409409 takeMVar done
410410
411−testSpawnReconnect :: Transport -> RemoteTable -> TransportInternals -> Assertion
411+testSpawnReconnect :: Transport -> RemoteTable -> TransportInternals -> Assertion
412412testSpawnReconnect transport rtable transportInternals = do
413− [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
413+ [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
414414 let nid1 = localNodeId node1
415415 nid2 = localNodeId node2
416− done <- newEmptyMVar
417− iv <- newMVar (0 :: Int)
416+ done <- newEmptyMVar
417+ iv <- newMVar (0 :: Int)
418418
419419 incr <- forkProcess node1 $ forever $ do
420420 () <- expect
421421 liftIO $ modifyMVar_ iv (return . (+ 1))
422422
423423 forkProcess node2 $ do
424− _pid1 <- spawn nid1 ($(mkClosure 'signal) incr)
424+ _pid1 <- spawn nid1 ($(mkClosure 'signal) incr)
425425 simulateNetworkFailure transportInternals nid2 nid1
426− _pid2 <- spawn nid1 ($(mkClosure 'signal) incr)
427− _pid3 <- spawn nid1 ($(mkClosure 'signal) incr)
426+ _pid2 <- spawn nid1 ($(mkClosure 'signal) incr)
427+ _pid3 <- spawn nid1 ($(mkClosure 'signal) incr)
428428
429429 liftIO $ threadDelay 100000
430430
431431 count <- liftIO $ takeMVar iv
432− True <- return $ count == 2 || count == 3 -- It depends on which message we get first in 'spawn'
432+ True <- return $ count == 2 || count == 3 -- It depends on which message we get first in 'spawn'
433433
434434 liftIO $ putMVar done ()
435435
@@ -437,10 +437,10 @@ testSpawnReconnect transport rtable transportInternals = do
437437
438438-- | 'spawn' used to ave a race condition which would be triggered if the
439439-- spawning process terminates immediately after spawning
440−testSpawnTerminate :: Transport -> RemoteTable -> Assertion
440+testSpawnTerminate :: Transport -> RemoteTable -> Assertion
441441testSpawnTerminate transport rtable = do
442− slave <- newLocalNode transport rtable
443− master <- newLocalNode transport rtable
442+ slave <- newLocalNode transport rtable
443+ master <- newLocalNode transport rtable
444444 masterDone <- newEmptyMVar
445445
446446 runProcess master $ do
@@ -476,5 +476,5 @@ tests (transport, transportInternals) rtable = [
476476main :: IO ()
477477main = do
478478 Right transport <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters
479− let rtable = __remoteTable . __remoteTableDecl $ initRemoteTable
479+ let rtable = __remoteTable . __remoteTableDecl $ initRemoteTable
480480 defaultMain (tests transport rtable)
distributed-static/src/Control/Distributed/Static.hs+64−64
@@ -1,9 +1,9 @@
1−-- | /Towards Haskell in the Cloud/ (Epstein et al, Haskell Symposium 2011)
1+-- | /Towards Haskell in the Cloud/ (Epstein et al, Haskell Symposium 2011)
22-- introduces the concept of /static/ values: values that are known at compile
3−-- time. In a distributed setting where all nodes are running the same
3+-- time. In a distributed setting where all nodes are running the same
44-- executable, static values can be serialized simply by transmitting a code
55-- pointer to the value. This however requires special compiler support, which
6−-- is not yet available in ghc. We can mimick the behaviour by keeping an
6+-- is not yet available in ghc. We can mimick the behaviour by keeping an
77-- explicit mapping ('RemoteTable') from labels to values (and making sure that
88-- all distributed nodes are using the same 'RemoteTable'). In this module
99-- we implement this mimickry and various extensions.
@@ -13,13 +13,13 @@
1313-- The paper stipulates that 'Static' values should have a free 'Binary'
1414-- instance:
1515--
16−-- > instance Binary (Static a)
16+-- > instance Binary (Static a)
1717--
1818-- This however is not (runtime) type safe: for instance, what would be the
1919-- behaviour of
2020--
21−-- > f :: Static Int -> Static Bool
22−-- > f = decode . encode
21+-- > f :: Static Int -> Static Bool
22+-- > f = decode . encode
2323--
2424-- For this reason we work only with 'Typeable' terms in this module, and
2525-- implement runtime checks
@@ -34,7 +34,7 @@
3434--
3535-- Since the runtime mapping ('RemoteTable') contains values of different types,
3636-- it maps labels ('String's) to 'Data.Rank1Dynamic.Dynamic' values. Again, we
37−-- use the implementation from "Data.Rank1Dynamic" so that we can store
37+-- use the implementation from "Data.Rank1Dynamic" so that we can store
3838-- polymorphic dynamic values.
3939--
4040-- [Compositionality]
@@ -43,18 +43,18 @@
4343-- way to combine two static values and get a static value out of it. This
4444-- makes sense when interpreting static strictly as /known at compile time/,
4545-- but it severely limits expressiveness. However, the main motivation for
46−-- 'static' is not that they are known at compile time but rather that
46+-- 'static' is not that they are known at compile time but rather that
4747-- /they provide a free/ 'Binary' /instance/. We therefore provide two basic
4848-- constructors for 'Static' values:
4949--
5050-- > staticLabel :: String -> Static a
5151-- > staticApply :: Static (a -> b) -> Static a -> Static b
5252--
53−-- The first constructor refers to a label in a 'RemoteTable'. The second
53+-- The first constructor refers to a label in a 'RemoteTable'. The second
5454-- allows to apply a static function to a static argument, and makes 'Static'
5555-- compositional: once we have 'staticApply' we can implement numerous derived
5656-- combinators on 'Static' values (we define a few in this module; see
57−-- 'staticCompose', 'staticSplit', and 'staticConst').
57+-- 'staticCompose', 'staticSplit', and 'staticConst').
5858--
5959-- [Closures]
6060--
@@ -67,7 +67,7 @@
6767--
6868-- See /Towards Haskell in the Cloud/ for the rationale behind representing
6969-- the function closure environment in serialized ('ByteString') form. Any
70−-- static value can trivially be turned into a 'Closure' ('staticClosure').
70+-- static value can trivially be turned into a 'Closure' ('staticClosure').
7171-- Moreover, since 'Static' is now compositional, we can also define derived
7272-- operators on 'Closure' values ('closureApplyStatic', 'closureApply',
7373-- 'closureCompose', 'closureSplit').
@@ -76,9 +76,9 @@
7676--
7777-- Suppose we are working in the context of some distributed environment, with
7878-- a monadic type 'Process' representing processes, 'NodeId' representing node
79−-- addresses and 'ProcessId' representing process addresses. Suppose further
80−-- that we have a primitive
81−--
79+-- addresses and 'ProcessId' representing process addresses. Suppose further
80+-- that we have a primitive
81+--
8282-- > sendInt :: ProcessId -> Int -> Process ()
8383--
8484-- We might want to define
@@ -106,7 +106,7 @@
106106-- > sendIntClosure :: ProcessId -> Closure (Int -> Process ())
107107-- > sendIntClosure pid = closure decoder (encode pid)
108108-- > where
109−-- > decoder :: Static (ByteString -> Int -> Process ())
109+-- > decoder :: Static (ByteString -> Int -> Process ())
110110-- > decoder = sendIntStatic `staticCompose` decodeProcessIdStatic
111111--
112112-- [Polymorphic example]
@@ -118,8 +118,8 @@
118118-- which turns a process that computes an integer into a process that computes
119119-- the integer and then sends it someplace else.
120120--
121−-- We can define
122−--
121+-- We can define
122+--
123123-- > bindStatic :: (Typeable a, Typeable b) => Static (Process a -> (a -> Process b) -> Process b)
124124-- > bindStatic = staticLabel "$bind"
125125--
@@ -132,7 +132,7 @@
132132--
133133-- (Note that we are using the special 'Data.Rank1Typeable.ANY1' and
134134-- 'Data.Rank1Typeable.ANY2' types from "Data.Rank1Typeable" to represent this
135−-- polymorphic value.) Once we have a static bind we can define
135+-- polymorphic value.) Once we have a static bind we can define
136136--
137137-- > sendIntResult :: ProcessId -> Closure (Process Int) -> Closure (Process ())
138138-- > sendIntResult pid cl = bindStatic `closureApplyStatic` cl `closureApply` sendIntClosure pid
@@ -157,7 +157,7 @@
157157-- > sendDict BinaryDict = send
158158--
159159-- Now 'sendDict' is a normal polymorphic value:
160−--
160+--
161161-- > sendDictStatic :: Static (BinaryDict a -> ProcessId -> a -> Process ())
162162-- > sendDictStatic = staticLabel "$sendDict"
163163-- >
@@ -165,20 +165,20 @@
165165-- > rtable = ...
166166-- > . registerStatic "$sendDict" (sendDict :: BinaryDict ANY -> ProcessId -> ANY -> Process ())
167167-- > $ initRemoteTable
168−--
168+--
169169-- so that we can define
170170--
171171-- > sendClosure :: Static (BinaryDict a) -> Process a -> Closure (a -> Process ())
172172-- > sendClosure dict pid = closure decoder (encode pid)
173173-- > where
174174-- > decoder :: Static (ByteString -> a -> Process ())
175−-- > decoder = (sendDictStatic `staticApply` dict) `staticCompose` decodeProcessIdStatic
175+-- > decoder = (sendDictStatic `staticApply` dict) `staticCompose` decodeProcessIdStatic
176176--
177177-- [Word of Caution]
178178--
179179-- You should not /define/ functions on 'ANY' and co. For example, the following
180180-- definition of 'rtable' is incorrect:
181−--
181+--
182182-- > rtable :: RemoteTable
183183-- > rtable = registerStatic "$sdictSendPort" sdictSendPort
184184-- > $ initRemoteTable
@@ -186,7 +186,7 @@
186186-- > sdictSendPort :: SerializableDict ANY -> SerializableDict (SendPort ANY)
187187-- > sdictSendPort SerializableDict = SerializableDict
188188--
189−-- This definition of 'sdictSendPort' ignores its argument completely, and
189+-- This definition of 'sdictSendPort' ignores its argument completely, and
190190-- constructs a 'SerializableDict' for the /monomorphic/ type @SendPort ANY@,
191191-- which isn't what you want. Instead, you should do
192192--
@@ -196,8 +196,8 @@
196196-- > where
197197-- > sdictSendPort :: forall a. SerializableDict a -> SerializableDict (SendPort a)
198198-- > sdictSendPort SerializableDict = SerializableDict
199−module Control.Distributed.Static
200− ( -- * Static values
199+module Control.Distributed.Static
200+ ( -- * Static values
201201 Static
202202 , staticLabel
203203 , staticApply
@@ -215,15 +215,15 @@ module Control.Distributed.Static
215215 , closureApply
216216 , closureCompose
217217 , closureSplit
218− -- * Resolution
218+ -- * Resolution
219219 , RemoteTable
220220 , initRemoteTable
221221 , registerStatic
222− , unstatic
223− , unclosure
222+ , unstatic
223+ , unclosure
224224 ) where
225225
226−import Data.Binary
226+import Data.Binary
227227 ( Binary(get, put)
228228 , Put
229229 , Get
@@ -238,7 +238,7 @@ import qualified Data.Map as Map (lookup, empty, insert)
238238import Control.Applicative ((<$>), (<*>))
239239import Control.Arrow as Arrow ((***), app)
240240import Data.Rank1Dynamic (Dynamic, toDynamic, fromDynamic, dynApply)
241−import Data.Rank1Typeable
241+import Data.Rank1Typeable
242242 ( Typeable
243243 , typeOf
244244 , ANY1
@@ -258,7 +258,7 @@ data StaticLabel =
258258 deriving (Typeable, Show)
259259
260260-- | A static value. Static is opaque; see 'staticLabel' and 'staticApply'.
261−newtype Static a = Static StaticLabel
261+newtype Static a = Static StaticLabel
262262 deriving (Typeable, Show)
263263
264264instance Typeable a => Binary (Static a) where
@@ -272,9 +272,9 @@ instance Typeable a => Binary (Static a) where
272272
273273-- We don't want StaticLabel to be its own Binary instance
274274putStaticLabel :: StaticLabel -> Put
275−putStaticLabel (StaticLabel string) =
276− putWord8 0 >> put string
277−putStaticLabel (StaticApply label1 label2) =
275+putStaticLabel (StaticLabel string) =
276+ putWord8 0 >> put string
277+putStaticLabel (StaticApply label1 label2) =
278278 putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2
279279
280280getStaticLabel :: Get StaticLabel
@@ -283,14 +283,14 @@ getStaticLabel = do
283283 case header of
284284 0 -> StaticLabel <$> get
285285 1 -> StaticApply <$> getStaticLabel <*> getStaticLabel
286− _ -> fail "StaticLabel.get: invalid"
287−
286+ _ -> fail "StaticLabel.get: invalid"
287+
288288-- | Create a primitive static value.
289−--
289+--
290290-- It is the responsibility of the client code to make sure the corresponding
291291-- entry in the 'RemoteTable' has the appropriate type.
292292staticLabel :: String -> Static a
293−staticLabel = Static . StaticLabel
293+staticLabel = Static . StaticLabel
294294
295295-- | Apply two static values
296296staticApply :: Static (a -> b) -> Static a -> Static b
@@ -300,12 +300,12 @@ staticApply (Static f) (Static x) = Static (StaticApply f x)
300300-- Eliminating static values --
301301--------------------------------------------------------------------------------
302302
303−-- | Runtime dictionary for 'unstatic' lookups
303+-- | Runtime dictionary for 'unstatic' lookups
304304newtype RemoteTable = RemoteTable (Map String Dynamic)
305305
306306-- | Initial remote table
307307initRemoteTable :: RemoteTable
308−initRemoteTable =
308+initRemoteTable =
309309 registerStatic "$compose" (toDynamic ((.) :: (ANY2 -> ANY3) -> (ANY1 -> ANY2) -> ANY1 -> ANY3))
310310 . registerStatic "$const" (toDynamic (const :: ANY1 -> ANY2 -> ANY1))
311311 . registerStatic "$split" (toDynamic ((***) :: (ANY1 -> ANY3) -> (ANY2 -> ANY4) -> (ANY1, ANY2) -> (ANY3, ANY4)))
@@ -321,23 +321,23 @@ registerStatic label dyn (RemoteTable rtable)
321321
322322-- Pseudo-type: RemoteTable -> Static a -> a
323323resolveStaticLabel :: RemoteTable -> StaticLabel -> Either String Dynamic
324−resolveStaticLabel (RemoteTable rtable) (StaticLabel label) =
324+resolveStaticLabel (RemoteTable rtable) (StaticLabel label) =
325325 case Map.lookup label rtable of
326326 Nothing -> Left $ "Invalid static label '" ++ label ++ "'"
327327 Just d -> Right d
328328resolveStaticLabel rtable (StaticApply label1 label2) = do
329− f <- resolveStaticLabel rtable label1
329+ f <- resolveStaticLabel rtable label1
330330 x <- resolveStaticLabel rtable label2
331331 f `dynApply` x
332332
333333-- | Resolve a static value
334334unstatic :: Typeable a => RemoteTable -> Static a -> Either String a
335−unstatic rtable (Static static) = do
336− dyn <- resolveStaticLabel rtable static
335+unstatic rtable (Static static) = do
336+ dyn <- resolveStaticLabel rtable static
337337 fromDynamic dyn
338338
339339--------------------------------------------------------------------------------
340−-- Closures --
340+-- Closures --
341341--------------------------------------------------------------------------------
342342
343343-- | A closure is a static value and an encoded environment
@@ -346,16 +346,16 @@ data Closure a = Closure (Static (ByteString -> a)) ByteString
346346
347347instance Typeable a => Binary (Closure a) where
348348 put (Closure static env) = put static >> put env
349− get = Closure <$> get <*> get
349+ get = Closure <$> get <*> get
350350
351351closure :: Static (ByteString -> a) -- ^ Decoder
352352 -> ByteString -- ^ Encoded closure environment
353353 -> Closure a
354−closure = Closure
354+closure = Closure
355355
356356-- | Resolve a closure
357357unclosure :: Typeable a => RemoteTable -> Closure a -> Either String a
358−unclosure rtable (Closure static env) = do
358+unclosure rtable (Closure static env) = do
359359 f <- unstatic rtable static
360360 return (f env)
361361
@@ -368,18 +368,18 @@ staticClosure static = closure (staticConst static) empty
368368--------------------------------------------------------------------------------
369369
370370-- | Static version of ('Prelude..')
371−composeStatic :: (Typeable a, Typeable b, Typeable c)
371+composeStatic :: (Typeable a, Typeable b, Typeable c)
372372 => Static ((b -> c) -> (a -> b) -> a -> c)
373−composeStatic = staticLabel "$compose"
373+composeStatic = staticLabel "$compose"
374374
375375-- | Static version of 'const'
376376constStatic :: (Typeable a, Typeable b)
377377 => Static (a -> b -> a)
378−constStatic = staticLabel "$const"
378+constStatic = staticLabel "$const"
379379
380380-- | Static version of ('Arrow.***')
381−splitStatic :: (Typeable a, Typeable a', Typeable b, Typeable b')
382− => Static ((a -> b) -> (a' -> b') -> (a, a') -> (b, b'))
381+splitStatic :: (Typeable a, Typeable a', Typeable b, Typeable b')
382+ => Static ((a -> b) -> (a' -> b') -> (a, a') -> (b, b'))
383383splitStatic = staticLabel "$split"
384384
385385-- | Static version of 'Arrow.app'
@@ -390,31 +390,31 @@ appStatic = staticLabel "$app"
390390-- | Static version of 'flip'
391391flipStatic :: (Typeable a, Typeable b, Typeable c)
392392 => Static ((a -> b -> c) -> b -> a -> c)
393−flipStatic = staticLabel "$flip"
393+flipStatic = staticLabel "$flip"
394394
395395--------------------------------------------------------------------------------
396396-- Combinators on static values --
397397--------------------------------------------------------------------------------
398398
399−-- | Static version of ('Prelude..')
399+-- | Static version of ('Prelude..')
400400staticCompose :: (Typeable a, Typeable b, Typeable c)
401401 => Static (b -> c) -> Static (a -> b) -> Static (a -> c)
402402staticCompose g f = composeStatic `staticApply` g `staticApply` f
403403
404404-- | Static version of ('Control.Arrow.***')
405−staticSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
405+staticSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
406406 => Static (a -> b) -> Static (a' -> b') -> Static ((a, a') -> (b, b'))
407407staticSplit f g = splitStatic `staticApply` f `staticApply` g
408408
409409-- | Static version of 'Prelude.const'
410410staticConst :: (Typeable a, Typeable b)
411411 => Static a -> Static (b -> a)
412−staticConst x = constStatic `staticApply` x
412+staticConst x = constStatic `staticApply` x
413413
414414-- | Static version of 'Prelude.flip'
415415staticFlip :: (Typeable a, Typeable b, Typeable c)
416416 => Static (a -> b -> c) -> Static (b -> a -> c)
417−staticFlip f = flipStatic `staticApply` f
417+staticFlip f = flipStatic `staticApply` f
418418
419419--------------------------------------------------------------------------------
420420-- Combinators on Closures --
@@ -423,7 +423,7 @@ staticFlip f = flipStatic `staticApply` f
423423-- | Apply a static function to a closure
424424closureApplyStatic :: (Typeable a, Typeable b)
425425 => Static (a -> b) -> Closure a -> Closure b
426−closureApplyStatic f (Closure decoder env) =
426+closureApplyStatic f (Closure decoder env) =
427427 closure (f `staticCompose` decoder) env
428428
429429decodeEnvPairStatic :: Static (ByteString -> (ByteString, ByteString))
@@ -432,15 +432,15 @@ decodeEnvPairStatic = staticLabel "$decodeEnvPair"
432432-- | Closure application
433433closureApply :: forall a b. (Typeable a, Typeable b)
434434 => Closure (a -> b) -> Closure a -> Closure b
435−closureApply (Closure fdec fenv) (Closure xdec xenv) =
435+closureApply (Closure fdec fenv) (Closure xdec xenv) =
436436 closure decoder (encode (fenv, xenv))
437437 where
438438 decoder :: Static (ByteString -> b)
439− decoder = appStatic
439+ decoder = appStatic
440440 `staticCompose`
441441 (fdec `staticSplit` xdec)
442442 `staticCompose`
443− decodeEnvPairStatic
443+ decodeEnvPairStatic
444444
445445-- | Closure composition
446446closureCompose :: (Typeable a, Typeable b, Typeable c)
@@ -448,6 +448,6 @@ closureCompose :: (Typeable a, Typeable b, Typeable c)
448448closureCompose g f = composeStatic `closureApplyStatic` g `closureApply` f
449449
450450-- | Closure version of ('Arrow.***')
451−closureSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
451+closureSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')
452452 => Closure (a -> b) -> Closure (a' -> b') -> Closure ((a, a') -> (b, b'))
453−closureSplit f g = splitStatic `closureApplyStatic` f `closureApply` g
453+closureSplit f g = splitStatic `closureApplyStatic` f `closureApply` g
doc/tutorial/tutorial-client.hs+3−3
@@ -1,4 +1,4 @@
1−import Network.Transport
1+import Network.Transport
22import Network.Transport.TCP (createTransport, defaultTCPParameters)
33import System.Environment
44import Control.Monad
@@ -13,12 +13,12 @@ main = do
1313 let addr = EndPointAddress (pack serverAddr)
1414-- Right conn <- connect endpoint addr ReliableOrdered defaultConnectHints
1515 x <- connect endpoint addr ReliableOrdered defaultConnectHints
16− let conn = case x of
16+ let conn = case x of
1717 Right conn -> conn
1818 Left err -> error$ "Error connecting: "++show err
1919 send conn [pack "Hello world"]
2020 close conn
2121
22− replicateM_ 3 $ receive endpoint >>= print
22+ replicateM_ 3 $ receive endpoint >>= print
2323
2424 closeTransport transport
doc/tutorial/tutorial-server.hs+10−10
@@ -1,7 +1,7 @@
11import Network.Transport
22import Network.Transport.TCP (createTransport, defaultTCPParameters)
33import Control.Concurrent
4−import Data.Map
4+import Data.Map
55import Control.Exception
66import System.Environment
77
@@ -9,7 +9,7 @@ import System.Environment
99echoServer :: EndPoint -> MVar () -> IO ()
1010echoServer endpoint serverDone = go empty
1111 where
12− go :: Map ConnectionId (MVar Connection) -> IO ()
12+ go :: Map ConnectionId (MVar Connection) -> IO ()
1313 go cs = do
1414 event <- receive endpoint
1515 case event of
@@ -18,20 +18,20 @@ echoServer endpoint serverDone = go empty
1818 connMVar <- newEmptyMVar
1919 forkIO $ do
2020 Right conn <- connect endpoint addr rel defaultConnectHints
21− putMVar connMVar conn
22− go (insert cid connMVar cs)
21+ putMVar connMVar conn
22+ go (insert cid connMVar cs)
2323 Received cid payload -> do
2424 forkIO $ do
2525 conn <- readMVar (cs ! cid)
26− send conn payload
26+ send conn payload
2727 return ()
2828 go cs
29− ConnectionClosed cid -> do
29+ ConnectionClosed cid -> do
3030 putStrLn$ " Closed connection: ID "++show cid
3131 forkIO $ do
3232 conn <- readMVar (cs ! cid)
33− close conn
34− go (delete cid cs)
33+ close conn
34+ go (delete cid cs)
3535 EndPointClosed -> do
3636 putStrLn "Echo server exiting"
3737 putMVar serverDone ()
@@ -39,7 +39,7 @@ echoServer endpoint serverDone = go empty
3939onCtrlC :: IO a -> IO () -> IO a
4040p `onCtrlC` q = catchJust isUserInterrupt p (const $ q >> p `onCtrlC` q)
4141 where
42− isUserInterrupt :: AsyncException -> Maybe ()
42+ isUserInterrupt :: AsyncException -> Maybe ()
4343 isUserInterrupt UserInterrupt = Just ()
4444 isUserInterrupt _ = Nothing
4545
@@ -49,6 +49,6 @@ main = do
4949 serverDone <- newEmptyMVar
5050 Right transport <- createTransport host port defaultTCPParameters
5151 Right endpoint <- newEndPoint transport
52− forkIO $ echoServer endpoint serverDone
52+ forkIO $ echoServer endpoint serverDone
5353 putStrLn $ "Echo server started at " ++ show (address endpoint)
5454 readMVar serverDone `onCtrlC` closeTransport transport
network-transport-composed/src/Network/Transport/Composed.hs+43−43
@@ -8,38 +8,38 @@
88--
99-- When the address of combined endpoint C1 is sent to combined endpoint C2,
1010-- and C2 attempts to make a connection to C1, it needs to choice an underlying
11−-- endpoint to make the connection. The choice is made by a parameter
11+-- endpoint to make the connection. The choice is made by a parameter
1212-- 'resolveAddress' of the composed transport.
1313--
1414-- When C2 connects to C1 then it is assumed that whatever transport C2 uses
1515-- to connect to C1, this is the same transport that C1 needs to use to connect
16−-- back to C2.
16+-- back to C2.
1717--
1818-- TODO: at the moment the address reported by a ConnectionOpened might differ
1919-- from the address reported by the remote endpoint itself. This might cause
2020-- difficulties?
21−module Network.Transport.Composed
21+module Network.Transport.Composed
2222 ( ComposedTransport(..)
2323 , createTransport
2424 ) where
2525
26−import qualified Data.ByteString as BSS
26+import qualified Data.ByteString as BSS
2727 ( concat
2828 , length
2929 , splitAt
3030 , singleton
3131 , uncons
3232 )
33−import Control.Monad (void)
33+import Control.Monad (void)
3434import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan)
3535import Control.Concurrent (forkIO)
36−import Network.Transport
36+import Network.Transport
3737 ( Transport(..)
3838 , EndPointAddress(EndPointAddress)
3939 , TransportError(TransportError)
4040 , NewEndPointErrorCode
4141 , EndPoint(..)
42− , NewMulticastGroupErrorCode(NewMulticastGroupUnsupported)
42+ , NewMulticastGroupErrorCode(NewMulticastGroupUnsupported)
4343 , ResolveMulticastGroupErrorCode(ResolveMulticastGroupUnsupported)
4444 , Event(EndPointClosed, ConnectionOpened, ErrorEvent)
4545 , EventErrorCode(EventConnectionLost)
@@ -57,25 +57,25 @@ data ComposedTransport = ComposedTransport {
5757 , transportB :: Transport
5858 -- | Pick a suitable transport for an address
5959 , resolveAddress :: (EndPoint, EndPoint)
60− -> (EndPointAddress, EndPointAddress)
61− -> IO (EndPoint, EndPointAddress)
60+ -> (EndPointAddress, EndPointAddress)
61+ -> IO (EndPoint, EndPointAddress)
6262 }
6363
64−data ComposedAddress =
64+data ComposedAddress =
6565 LeftAddress EndPointAddress
6666 | RightAddress EndPointAddress
6767 | EitherAddress EndPointAddress EndPointAddress
6868
6969serializeComposedAddress :: ComposedAddress -> EndPointAddress
70−serializeComposedAddress (LeftAddress (EndPointAddress addr)) =
70+serializeComposedAddress (LeftAddress (EndPointAddress addr)) =
7171 EndPointAddress $ BSS.concat [BSS.singleton 0, addr]
72−serializeComposedAddress (RightAddress (EndPointAddress addr)) =
72+serializeComposedAddress (RightAddress (EndPointAddress addr)) =
7373 EndPointAddress $ BSS.concat [BSS.singleton 1, addr]
7474serializeComposedAddress (EitherAddress (EndPointAddress addr1) (EndPointAddress addr2)) =
7575 EndPointAddress $ BSS.concat [BSS.singleton 2, encodeInt32 (BSS.length addr1), addr1, addr2]
7676
7777deserializeComposedAddress :: EndPointAddress -> ComposedAddress
78−deserializeComposedAddress (EndPointAddress addr) =
78+deserializeComposedAddress (EndPointAddress addr) =
7979 let (header, remainder) = case BSS.uncons addr of
8080 Just (x, xs) -> (x, xs)
8181 Nothing -> error "deserializeComposedAddress"
@@ -86,19 +86,19 @@ deserializeComposedAddress (EndPointAddress addr) =
8686 (a, b) = BSS.splitAt (decodeInt32 len) remainder'
8787 in EitherAddress (EndPointAddress a) (EndPointAddress b)
8888 _ -> error "deserializeComposedAddress"
89−
90−createTransport :: ComposedTransport -> IO Transport
91−createTransport composed =
89+
90+createTransport :: ComposedTransport -> IO Transport
91+createTransport composed =
9292 return Transport {
93− newEndPoint = apiNewEndPoint composed
94− , closeTransport = apiCloseTransport composed
93+ newEndPoint = apiNewEndPoint composed
94+ , closeTransport = apiCloseTransport composed
9595 }
96−
96+
9797apiNewEndPoint :: ComposedTransport -> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
98−apiNewEndPoint composed = do
99− mEndPoints <- createEndPoints
98+apiNewEndPoint composed = do
99+ mEndPoints <- createEndPoints
100100 case mEndPoints of
101− Left err ->
101+ Left err ->
102102 return $ Left err
103103 Right (endPointA, endPointB) -> do
104104 let addr = serializeComposedAddress (EitherAddress (address endPointA) (address endPointB))
@@ -106,21 +106,21 @@ apiNewEndPoint composed = do
106106 void . forkIO $ forwardEvents endPointA chan LeftAddress
107107 void . forkIO $ forwardEvents endPointB chan RightAddress
108108 return . Right $ EndPoint {
109− receive = readChan chan
110− , address = addr
111− , connect = apiConnect composed endPointA endPointB
109+ receive = readChan chan
110+ , address = addr
111+ , connect = apiConnect composed endPointA endPointB
112112 , closeEndPoint = apiCloseEndPoint endPointA endPointB
113− , newMulticastGroup = return . Left $ newMulticastGroupError
113+ , newMulticastGroup = return . Left $ newMulticastGroupError
114114 , resolveMulticastGroup = return . Left . const resolveMulticastGroupError
115115 }
116116 where
117− newMulticastGroupError =
118− TransportError NewMulticastGroupUnsupported "Multicast not supported"
119− resolveMulticastGroupError =
120− TransportError ResolveMulticastGroupUnsupported "Multicast not supported"
117+ newMulticastGroupError =
118+ TransportError NewMulticastGroupUnsupported "Multicast not supported"
119+ resolveMulticastGroupError =
120+ TransportError ResolveMulticastGroupUnsupported "Multicast not supported"
121121
122122 createEndPoints = do
123− mEndPointA <- newEndPoint (transportA composed)
123+ mEndPointA <- newEndPoint (transportA composed)
124124 case mEndPointA of
125125 Left err -> return $ Left err
126126 Right endPointA -> do
@@ -129,7 +129,7 @@ apiNewEndPoint composed = do
129129 Left err -> do
130130 closeEndPoint endPointA
131131 return $ Left err
132− Right endPointB ->
132+ Right endPointB ->
133133 return $ Right (endPointA, endPointB)
134134
135135 forwardEvents :: EndPoint -> Chan Event -> (EndPointAddress -> ComposedAddress) -> IO ()
@@ -138,19 +138,19 @@ apiNewEndPoint composed = do
138138 go = do
139139 event <- receive endPoint
140140 case event of
141− ConnectionOpened cid rel addr -> do
141+ ConnectionOpened cid rel addr -> do
142142 let addr' = serializeComposedAddress (inj addr)
143143 writeChan chan (ConnectionOpened cid rel addr')
144− go
144+ go
145145 ErrorEvent (TransportError (EventConnectionLost addr) msg) -> do
146146 let addr' = serializeComposedAddress (inj addr)
147147 writeChan chan $ ErrorEvent (TransportError (EventConnectionLost addr') msg)
148148 go
149149 EndPointClosed -> do
150− writeChan chan event
150+ writeChan chan event
151151 return ()
152152 _ -> do
153− writeChan chan event
153+ writeChan chan event
154154 go
155155
156156apiCloseTransport :: ComposedTransport -> IO ()
@@ -161,21 +161,21 @@ apiCloseTransport composed = do
161161apiConnect :: ComposedTransport
162162 -> EndPoint
163163 -> EndPoint
164− -> EndPointAddress
165− -> Reliability
166− -> ConnectHints
164+ -> EndPointAddress
165+ -> Reliability
166+ -> ConnectHints
167167 -> IO (Either (TransportError ConnectErrorCode) Connection)
168−apiConnect composed endPointA endPointB theirComposedAddr rel hints =
168+apiConnect composed endPointA endPointB theirComposedAddr rel hints =
169169 case deserializeComposedAddress theirComposedAddr of
170− LeftAddress addr ->
170+ LeftAddress addr ->
171171 connect endPointA addr rel hints
172− RightAddress addr ->
172+ RightAddress addr ->
173173 connect endPointB addr rel hints
174174 EitherAddress addrA addrB -> do
175175 (endPoint, addr) <- resolveAddress composed (endPointA, endPointB) (addrA, addrB)
176176 connect endPoint addr rel hints
177177
178178apiCloseEndPoint :: EndPoint -> EndPoint -> IO ()
179−apiCloseEndPoint endPointA endPointB = do
179+apiCloseEndPoint endPointA endPointB = do
180180 closeEndPoint endPointA
181181 closeEndPoint endPointB
network-transport-inmemory/src/Network/Transport/Chan.hs+38−38
@@ -1,7 +1,7 @@
11-- | In-memory implementation of the Transport API.
22module Network.Transport.Chan (createTransport) where
33
4−import Network.Transport
4+import Network.Transport
55import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
66import Control.Applicative ((<$>))
77import Control.Category ((>>>))
@@ -15,11 +15,11 @@ import qualified Data.Set as Set (empty, elems, insert, delete)
1515import Data.ByteString (ByteString)
1616import qualified Data.ByteString.Char8 as BSC (pack)
1717import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))
18−import qualified Data.Accessor.Container as DAC (mapMaybe)
18+import qualified Data.Accessor.Container as DAC (mapMaybe)
1919
2020-- Global state: next available "address", mapping from addresses to channels and next available connection
21−data TransportState = State { _channels :: Map EndPointAddress (Chan Event)
22− , _nextConnectionId :: Map EndPointAddress ConnectionId
21+data TransportState = State { _channels :: Map EndPointAddress (Chan Event)
22+ , _nextConnectionId :: Map EndPointAddress ConnectionId
2323 , _multigroups :: Map MulticastAddress (MVar (Set EndPointAddress))
2424 }
2525
@@ -29,11 +29,11 @@ data TransportState = State { _channels :: Map EndPointAddress (Chan Eve
2929-- (threads can, and should, create their own endpoints though).
3030createTransport :: IO Transport
3131createTransport = do
32− state <- newMVar State { _channels = Map.empty
32+ state <- newMVar State { _channels = Map.empty
3333 , _nextConnectionId = Map.empty
3434 , _multigroups = Map.empty
3535 }
36− return Transport { newEndPoint = apiNewEndPoint state
36+ return Transport { newEndPoint = apiNewEndPoint state
3737 , closeTransport = throwIO (userError "closeEndPoint not implemented")
3838 }
3939
@@ -44,46 +44,46 @@ apiNewEndPoint state = do
4444 addr <- modifyMVar state $ \st -> do
4545 let addr = EndPointAddress . BSC.pack . show . Map.size $ st ^. channels
4646 return ((channelAt addr ^= chan) . (nextConnectionIdAt addr ^= 1) $ st, addr)
47− return . Right $ EndPoint { receive = readChan chan
47+ return . Right $ EndPoint { receive = readChan chan
4848 , address = addr
49− , connect = apiConnect addr state
49+ , connect = apiConnect addr state
5050 , closeEndPoint = throwIO (userError "closeEndPoint not implemented")
5151 , newMulticastGroup = apiNewMulticastGroup state addr
5252 , resolveMulticastGroup = apiResolveMulticastGroup state addr
5353 }
54−
54+
5555-- | Create a new connection
56−apiConnect :: EndPointAddress
57− -> MVar TransportState
58− -> EndPointAddress
59− -> Reliability
60− -> ConnectHints
56+apiConnect :: EndPointAddress
57+ -> MVar TransportState
58+ -> EndPointAddress
59+ -> Reliability
60+ -> ConnectHints
6161 -> IO (Either (TransportError ConnectErrorCode) Connection)
62−apiConnect myAddress state theirAddress _reliability _hints = do
62+apiConnect myAddress state theirAddress _reliability _hints = do
6363 (chan, conn) <- modifyMVar state $ \st -> do
6464 let chan = st ^. channelAt theirAddress
6565 let conn = st ^. nextConnectionIdAt theirAddress
6666 return (nextConnectionIdAt theirAddress ^: (+ 1) $ st, (chan, conn))
6767 writeChan chan $ ConnectionOpened conn ReliableOrdered myAddress
6868 connAlive <- newMVar True
69− return . Right $ Connection { send = apiSend chan conn connAlive
70− , close = apiClose chan conn connAlive
71− }
69+ return . Right $ Connection { send = apiSend chan conn connAlive
70+ , close = apiClose chan conn connAlive
71+ }
7272
7373-- | Send a message over a connection
7474apiSend :: Chan Event -> ConnectionId -> MVar Bool -> [ByteString] -> IO (Either (TransportError SendErrorCode) ())
75−apiSend chan conn connAlive msg =
76− modifyMVar connAlive $ \alive ->
77− if alive
78− then do
75+apiSend chan conn connAlive msg =
76+ modifyMVar connAlive $ \alive ->
77+ if alive
78+ then do
7979 writeChan chan (Received conn msg)
8080 return (alive, Right ())
81− else
81+ else
8282 return (alive, Left (TransportError SendFailed "Connection closed"))
8383
8484-- | Close a connection
8585apiClose :: Chan Event -> ConnectionId -> MVar Bool -> IO ()
86−apiClose chan conn connAlive =
86+apiClose chan conn connAlive =
8787 modifyMVar_ connAlive $ \alive -> do
8888 when alive . writeChan chan $ ConnectionClosed conn
8989 return False
@@ -91,7 +91,7 @@ apiClose chan conn connAlive =
9191-- | Create a new multicast group
9292apiNewMulticastGroup :: MVar TransportState -> EndPointAddress -> IO (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
9393apiNewMulticastGroup state ourAddress = do
94− group <- newMVar Set.empty
94+ group <- newMVar Set.empty
9595 groupAddr <- modifyMVar state $ \st -> do
9696 let addr = MulticastAddress . BSC.pack . show . Map.size $ st ^. multigroups
9797 return (multigroupAt addr ^= group $ st, addr)
@@ -105,30 +105,30 @@ apiNewMulticastGroup state ourAddress = do
105105-- deleted.
106106createMulticastGroup :: MVar TransportState -> EndPointAddress -> MulticastAddress -> MVar (Set EndPointAddress) -> MulticastGroup
107107createMulticastGroup state ourAddress groupAddress group =
108− MulticastGroup { multicastAddress = groupAddress
108+ MulticastGroup { multicastAddress = groupAddress
109109 , deleteMulticastGroup = modifyMVar_ state $ return . (multigroups ^: Map.delete groupAddress)
110110 , maxMsgSize = Nothing
111− , multicastSend = \payload -> do
111+ , multicastSend = \payload -> do
112112 cs <- (^. channels) <$> readMVar state
113− es <- readMVar group
114− forM_ (Set.elems es) $ \ep -> do
113+ es <- readMVar group
114+ forM_ (Set.elems es) $ \ep -> do
115115 let ch = cs ^. at ep "Invalid endpoint"
116− writeChan ch (ReceivedMulticast groupAddress payload)
116+ writeChan ch (ReceivedMulticast groupAddress payload)
117117 , multicastSubscribe = modifyMVar_ group $ return . Set.insert ourAddress
118118 , multicastUnsubscribe = modifyMVar_ group $ return . Set.delete ourAddress
119− , multicastClose = return ()
119+ , multicastClose = return ()
120120 }
121121
122122-- | Resolve a multicast group
123−apiResolveMulticastGroup :: MVar TransportState
123+apiResolveMulticastGroup :: MVar TransportState
124124 -> EndPointAddress
125− -> MulticastAddress
125+ -> MulticastAddress
126126 -> IO (Either (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
127127apiResolveMulticastGroup state ourAddress groupAddress = do
128− group <- (^. (multigroups >>> DAC.mapMaybe groupAddress)) <$> readMVar state
128+ group <- (^. (multigroups >>> DAC.mapMaybe groupAddress)) <$> readMVar state
129129 case group of
130130 Nothing -> return . Left $ TransportError ResolveMulticastGroupNotFound ("Group " ++ show groupAddress ++ " not found")
131− Just mvar -> return . Right $ createMulticastGroup state ourAddress groupAddress mvar
131+ Just mvar -> return . Right $ createMulticastGroup state ourAddress groupAddress mvar
132132
133133--------------------------------------------------------------------------------
134134-- Lens definitions --
@@ -141,12 +141,12 @@ nextConnectionId :: Accessor TransportState (Map EndPointAddress ConnectionId)
141141nextConnectionId = accessor _nextConnectionId (\cid st -> st { _nextConnectionId = cid })
142142
143143multigroups :: Accessor TransportState (Map MulticastAddress (MVar (Set EndPointAddress)))
144−multigroups = accessor _multigroups (\gs st -> st { _multigroups = gs })
144+multigroups = accessor _multigroups (\gs st -> st { _multigroups = gs })
145145
146146at :: Ord k => k -> String -> Accessor (Map k v) v
147−at k err = accessor (Map.findWithDefault (error err) k) (Map.insert k)
147+at k err = accessor (Map.findWithDefault (error err) k) (Map.insert k)
148148
149−channelAt :: EndPointAddress -> Accessor TransportState (Chan Event)
149+channelAt :: EndPointAddress -> Accessor TransportState (Chan Event)
150150channelAt addr = channels >>> at addr "Invalid channel"
151151
152152nextConnectionIdAt :: EndPointAddress -> Accessor TransportState ConnectionId
network-transport-inmemory/tests/TestInMemory.hs+1−1
@@ -3,6 +3,6 @@ module Main where
33import Network.Transport.Tests
44import Network.Transport.Chan
55import Control.Applicative ((<$>))
6−
6+
77main :: IO ()
88main = testTransport (Right <$> createTransport)
network-transport-tcp/benchmarks/JustPingCacheHeader.hs+15−15
@@ -40,7 +40,7 @@ main = do
4040 -- Start the server
4141 forkIO $ do
4242 putStrLn "server: creating TCP connection"
43− serverAddrs <- getAddrInfo
43+ serverAddrs <- getAddrInfo
4444 (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
4545 Nothing
4646 (Just "8080")
@@ -61,15 +61,15 @@ main = do
6161 forkIO $ do
6262 takeMVar serverReady
6363 let pings = read pingsStr
64− serverAddrs <- getAddrInfo
64+ serverAddrs <- getAddrInfo
6565 Nothing
6666 (Just "127.0.0.1")
6767 (Just "8080")
6868 let serverAddr = head serverAddrs
6969 sock <- socket (addrFamily serverAddr) Stream defaultProtocol
70−
70+
7171 N.connect sock (addrAddress serverAddr)
72−
72+
7373 ping sock pings
7474 putMVar clientDone ()
7575
@@ -79,20 +79,20 @@ main = do
7979pingMessage :: ByteString
8080pingMessage = pack "ping123"
8181
82−ping :: Socket -> Int -> IO ()
82+ping :: Socket -> Int -> IO ()
8383ping sock pings = go pings
8484 where
8585 go :: Int -> IO ()
86− go 0 = do
86+ go 0 = do
8787 putStrLn $ "client did " ++ show pings ++ " pings"
8888 go !i = do
8989 before <- getCurrentTime
90− send sock pingMessage
90+ send sock pingMessage
9191 bs <- recv sock 8
9292 after <- getCurrentTime
9393 -- putStrLn $ "client received " ++ unpack bs
9494 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
95− hPutStrLn stderr $ show i ++ " " ++ show latency
95+ hPutStrLn stderr $ show i ++ " " ++ show latency
9696 go (i - 1)
9797
9898pong :: Socket -> IO ()
@@ -103,7 +103,7 @@ pong sock = do
103103 send sock bs
104104 pong sock
105105
106−-- | Wrapper around NBS.recv (for profiling)
106+-- | Wrapper around NBS.recv (for profiling)
107107recv :: Socket -> Int -> IO ByteString
108108recv sock i = do
109109 (header, payload) <- BS.splitAt 4 `fmap` NBS.recv sock (4 + i)
@@ -112,23 +112,23 @@ recv sock i = do
112112
113113-- | Cached header
114114header :: ByteString
115−header = pack "fake"
115+header = pack "fake"
116116
117117-- | Wrapper around NBS.send (for profiling)
118−send :: Socket -> ByteString -> IO ()
118+send :: Socket -> ByteString -> IO ()
119119send sock bs = do
120120 NBS.sendMany sock [header, bs]
121121
122122-- | Encode length (manual for now)
123123encodeLength :: Int32 -> IO ByteString
124−encodeLength i32 =
124+encodeLength i32 =
125125 BSI.create 4 $ \p ->
126126 pokeByteOff p 0 (htonl (fromIntegral i32))
127127
128128-- | Decode length (manual for now)
129129decodeLength :: ByteString -> IO Int32
130−decodeLength bs =
131− let (fp, _, _) = BSI.toForeignPtr bs in
130+decodeLength bs =
131+ let (fp, _, _) = BSI.toForeignPtr bs in
132132 withForeignPtr fp $ \p -> do
133− w32 <- peekByteOff p 0
133+ w32 <- peekByteOff p 0
134134 return (fromIntegral (ntohl w32))
network-transport-tcp/benchmarks/JustPingHaskell.hs+9−9
@@ -33,7 +33,7 @@ main = do
3333 -- Start the server
3434 forkIO $ do
3535 putStrLn "server: creating TCP connection"
36− serverAddrs <- getAddrInfo
36+ serverAddrs <- getAddrInfo
3737 (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
3838 Nothing
3939 (Just "8080")
@@ -54,15 +54,15 @@ main = do
5454 forkIO $ do
5555 takeMVar serverReady
5656 let pings = read pingsStr
57− serverAddrs <- getAddrInfo
57+ serverAddrs <- getAddrInfo
5858 Nothing
5959 (Just "127.0.0.1")
6060 (Just "8080")
6161 let serverAddr = head serverAddrs
6262 sock <- socket (addrFamily serverAddr) Stream defaultProtocol
63−
63+
6464 N.connect sock (addrAddress serverAddr)
65−
65+
6666 ping sock pings
6767 putMVar clientDone ()
6868
@@ -72,20 +72,20 @@ main = do
7272pingMessage :: ByteString
7373pingMessage = pack "ping123"
7474
75−ping :: Socket -> Int -> IO ()
75+ping :: Socket -> Int -> IO ()
7676ping sock pings = go pings
7777 where
7878 go :: Int -> IO ()
79− go 0 = do
79+ go 0 = do
8080 putStrLn $ "client did " ++ show pings ++ " pings"
8181 go !i = do
8282 before <- getCurrentTime
83− send sock pingMessage
83+ send sock pingMessage
8484 bs <- recv sock 8
8585 after <- getCurrentTime
8686 -- putStrLn $ "client received " ++ unpack bs
8787 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
88− hPutStrLn stderr $ show i ++ " " ++ show latency
88+ hPutStrLn stderr $ show i ++ " " ++ show latency
8989 go (i - 1)
9090
9191pong :: Socket -> IO ()
@@ -96,7 +96,7 @@ pong sock = do
9696 send sock bs
9797 pong sock
9898
99−-- | Wrapper around NBS.recv (for profiling)
99+-- | Wrapper around NBS.recv (for profiling)
100100recv :: Socket -> Int -> IO ByteString
101101recv = NBS.recv
102102
network-transport-tcp/benchmarks/JustPingOneRecv.hs+14−14
@@ -40,7 +40,7 @@ main = do
4040 -- Start the server
4141 forkIO $ do
4242 putStrLn "server: creating TCP connection"
43− serverAddrs <- getAddrInfo
43+ serverAddrs <- getAddrInfo
4444 (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
4545 Nothing
4646 (Just "8080")
@@ -61,15 +61,15 @@ main = do
6161 forkIO $ do
6262 takeMVar serverReady
6363 let pings = read pingsStr
64− serverAddrs <- getAddrInfo
64+ serverAddrs <- getAddrInfo
6565 Nothing
6666 (Just "127.0.0.1")
6767 (Just "8080")
6868 let serverAddr = head serverAddrs
6969 sock <- socket (addrFamily serverAddr) Stream defaultProtocol
70−
70+
7171 N.connect sock (addrAddress serverAddr)
72−
72+
7373 ping sock pings
7474 putMVar clientDone ()
7575
@@ -79,20 +79,20 @@ main = do
7979pingMessage :: ByteString
8080pingMessage = pack "ping123"
8181
82−ping :: Socket -> Int -> IO ()
82+ping :: Socket -> Int -> IO ()
8383ping sock pings = go pings
8484 where
8585 go :: Int -> IO ()
86− go 0 = do
86+ go 0 = do
8787 putStrLn $ "client did " ++ show pings ++ " pings"
8888 go !i = do
8989 before <- getCurrentTime
90− send sock pingMessage
90+ send sock pingMessage
9191 bs <- recv sock 8
9292 after <- getCurrentTime
9393 -- putStrLn $ "client received " ++ unpack bs
9494 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
95− hPutStrLn stderr $ show i ++ " " ++ show latency
95+ hPutStrLn stderr $ show i ++ " " ++ show latency
9696 go (i - 1)
9797
9898pong :: Socket -> IO ()
@@ -103,7 +103,7 @@ pong sock = do
103103 send sock bs
104104 pong sock
105105
106−-- | Wrapper around NBS.recv (for profiling)
106+-- | Wrapper around NBS.recv (for profiling)
107107recv :: Socket -> Int -> IO ByteString
108108recv sock i = do
109109 (header, payload) <- BS.splitAt 4 `fmap` NBS.recv sock (4 + i)
@@ -111,21 +111,21 @@ recv sock i = do
111111 return payload
112112
113113-- | Wrapper around NBS.send (for profiling)
114−send :: Socket -> ByteString -> IO ()
114+send :: Socket -> ByteString -> IO ()
115115send sock bs = do
116116 length <- encodeLength (fromIntegral (BS.length bs))
117117 NBS.sendMany sock [length, bs]
118118
119119-- | Encode length (manual for now)
120120encodeLength :: Int32 -> IO ByteString
121−encodeLength i32 =
121+encodeLength i32 =
122122 BSI.create 4 $ \p ->
123123 pokeByteOff p 0 (htonl (fromIntegral i32))
124124
125125-- | Decode length (manual for now)
126126decodeLength :: ByteString -> IO Int32
127−decodeLength bs =
128− let (fp, _, _) = BSI.toForeignPtr bs in
127+decodeLength bs =
128+ let (fp, _, _) = BSI.toForeignPtr bs in
129129 withForeignPtr fp $ \p -> do
130− w32 <- peekByteOff p 0
130+ w32 <- peekByteOff p 0
131131 return (fromIntegral (ntohl w32))
network-transport-tcp/benchmarks/JustPingThroughChan.hs+15−15
@@ -56,9 +56,9 @@ main = do
5656 putMVar serverReady ()
5757 (clientSock, pingAddr) <- accept sock
5858 forkIO $ socketToChan clientSock multiplexChannel
59−
60− -- Reply to the client
61− forever $ readChan multiplexChannel >>= send clientSock
59+
60+ -- Reply to the client
61+ forever $ readChan multiplexChannel >>= send clientSock
6262
6363 -- Start the client
6464 forkIO $ do
@@ -83,45 +83,45 @@ socketToChan sock chan = go
8383pingMessage :: ByteString
8484pingMessage = pack "ping123"
8585
86−ping :: Socket -> Int -> IO ()
86+ping :: Socket -> Int -> IO ()
8787ping sock pings = go pings
8888 where
8989 go :: Int -> IO ()
90− go 0 = do
90+ go 0 = do
9191 putStrLn $ "client did " ++ show pings ++ " pings"
9292 go !i = do
9393 before <- getCurrentTime
94− send sock pingMessage
95− bs <- recv sock
94+ send sock pingMessage
95+ bs <- recv sock
9696 after <- getCurrentTime
9797 -- putStrLn $ "client received " ++ unpack bs
9898 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
99− hPutStrLn stderr $ show i ++ " " ++ show latency
99+ hPutStrLn stderr $ show i ++ " " ++ show latency
100100 go (i - 1)
101101
102−-- | Receive a package
102+-- | Receive a package
103103recv :: Socket -> IO ByteString
104104recv sock = do
105105 header <- NBS.recv sock 4
106− length <- decodeLength header
106+ length <- decodeLength header
107107 NBS.recv sock (fromIntegral (length :: Int32))
108108
109109-- | Send a package
110−send :: Socket -> ByteString -> IO ()
110+send :: Socket -> ByteString -> IO ()
111111send sock bs = do
112112 length <- encodeLength (fromIntegral (BS.length bs))
113113 NBS.sendMany sock [length, bs]
114114
115115-- | Encode length (manual for now)
116116encodeLength :: Int32 -> IO ByteString
117−encodeLength i32 =
117+encodeLength i32 =
118118 BSI.create 4 $ \p ->
119119 pokeByteOff p 0 (htonl (fromIntegral i32))
120120
121121-- | Decode length (manual for now)
122122decodeLength :: ByteString -> IO Int32
123−decodeLength bs =
124− let (fp, _, _) = BSI.toForeignPtr bs in
123+decodeLength bs =
124+ let (fp, _, _) = BSI.toForeignPtr bs in
125125 withForeignPtr fp $ \p -> do
126− w32 <- peekByteOff p 0
126+ w32 <- peekByteOff p 0
127127 return (fromIntegral (ntohl w32))
network-transport-tcp/benchmarks/JustPingThroughMVar.hs+15−15
@@ -56,9 +56,9 @@ main = do
5656 putMVar serverReady ()
5757 (clientSock, pingAddr) <- accept sock
5858 forkIO $ socketToMVar clientSock multiplexMVar
59−
60− -- Reply to the client
61− forever $ takeMVar multiplexMVar >>= send clientSock
59+
60+ -- Reply to the client
61+ forever $ takeMVar multiplexMVar >>= send clientSock
6262
6363 -- Start the client
6464 forkIO $ do
@@ -83,45 +83,45 @@ socketToMVar sock mvar = go
8383pingMessage :: ByteString
8484pingMessage = pack "ping123"
8585
86−ping :: Socket -> Int -> IO ()
86+ping :: Socket -> Int -> IO ()
8787ping sock pings = go pings
8888 where
8989 go :: Int -> IO ()
90− go 0 = do
90+ go 0 = do
9191 putStrLn $ "client did " ++ show pings ++ " pings"
9292 go !i = do
9393 before <- getCurrentTime
94− send sock pingMessage
95− bs <- recv sock
94+ send sock pingMessage
95+ bs <- recv sock
9696 after <- getCurrentTime
9797 -- putStrLn $ "client received " ++ unpack bs
9898 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
99− hPutStrLn stderr $ show i ++ " " ++ show latency
99+ hPutStrLn stderr $ show i ++ " " ++ show latency
100100 go (i - 1)
101101
102−-- | Receive a package
102+-- | Receive a package
103103recv :: Socket -> IO ByteString
104104recv sock = do
105105 header <- NBS.recv sock 4
106− length <- decodeLength header
106+ length <- decodeLength header
107107 NBS.recv sock (fromIntegral (length :: Int32))
108108
109109-- | Send a package
110−send :: Socket -> ByteString -> IO ()
110+send :: Socket -> ByteString -> IO ()
111111send sock bs = do
112112 length <- encodeLength (fromIntegral (BS.length bs))
113113 NBS.sendMany sock [length, bs]
114114
115115-- | Encode length (manual for now)
116116encodeLength :: Int32 -> IO ByteString
117−encodeLength i32 =
117+encodeLength i32 =
118118 BSI.create 4 $ \p ->
119119 pokeByteOff p 0 (htonl (fromIntegral i32))
120120
121121-- | Decode length (manual for now)
122122decodeLength :: ByteString -> IO Int32
123−decodeLength bs =
124− let (fp, _, _) = BSI.toForeignPtr bs in
123+decodeLength bs =
124+ let (fp, _, _) = BSI.toForeignPtr bs in
125125 withForeignPtr fp $ \p -> do
126− w32 <- peekByteOff p 0
126+ w32 <- peekByteOff p 0
127127 return (fromIntegral (ntohl w32))
network-transport-tcp/benchmarks/JustPingTransport.hs+14−14
@@ -31,18 +31,18 @@ main = do
3131 forkIO $ do
3232 -- establish transport and endpoint
3333 putStrLn "server: creating TCP connection"
34− Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
35− Right endpoint <- newEndPoint transport
34+ Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
35+ Right endpoint <- newEndPoint transport
3636 putMVar serverAddr (address endpoint)
3737
38− -- Connect to the client so that we can reply
38+ -- Connect to the client so that we can reply
3939 theirAddr <- takeMVar clientAddr
40− Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
40+ Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
4141
4242 -- reply to pings with pongs
4343 putStrLn "server: awaiting client connection"
4444 ConnectionOpened _ _ _ <- receive endpoint
45− pong endpoint conn
45+ pong endpoint conn
4646
4747 -- Start the client
4848 forkIO $ do
@@ -55,9 +55,9 @@ main = do
5555
5656 -- Connect to the server to send pings
5757 theirAddr <- takeMVar serverAddr
58− Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
58+ Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
5959
60− -- Send pings, waiting for a reply after every ping
60+ -- Send pings, waiting for a reply after every ping
6161 ConnectionOpened _ _ _ <- receive endpoint
6262 ping endpoint conn pings
6363 putMVar clientDone ()
@@ -68,27 +68,27 @@ main = do
6868pingMessage :: [ByteString]
6969pingMessage = [pack "ping123"]
7070
71−ping :: EndPoint -> Connection -> Int -> IO ()
71+ping :: EndPoint -> Connection -> Int -> IO ()
7272ping endpoint conn pings = go pings
7373 where
7474 go :: Int -> IO ()
75− go 0 = do
75+ go 0 = do
7676 putStrLn $ "client did " ++ show pings ++ " pings"
7777 go !i = do
7878 before <- getCurrentTime
7979 send conn pingMessage
80− Received _ _payload <- receive endpoint
80+ Received _ _payload <- receive endpoint
8181 after <- getCurrentTime
82− -- putStrLn $ "client received " ++ show _payload
82+ -- putStrLn $ "client received " ++ show _payload
8383 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
84− hPutStrLn stderr $ show i ++ " " ++ show latency
84+ hPutStrLn stderr $ show i ++ " " ++ show latency
8585 go (i - 1)
8686
8787pong :: EndPoint -> Connection -> IO ()
8888pong endpoint conn = go
89− where
89+ where
9090 go = do
91− msg <- receive endpoint
91+ msg <- receive endpoint
9292 case msg of
9393 Received _ payload -> send conn payload >> go
9494 ConnectionClosed _ -> return ()
network-transport-tcp/benchmarks/JustPingTwoSocketPairs.hs+14−14
@@ -60,7 +60,7 @@ main = do
6060 pongSock <- socket (addrFamily clientAddr) Stream defaultProtocol
6161 N.connect pongSock (addrAddress clientAddr)
6262 when ("--NoDelay" `elem` args) $ setSocketOption pongSock NoDelay 1
63− forever $ readChan multiplexChannel >>= send pongSock
63+ forever $ readChan multiplexChannel >>= send pongSock
6464
6565 -- Wait for incoming connections (pings from the client)
6666 putMVar serverReady ()
@@ -89,7 +89,7 @@ main = do
8989 putMVar clientDone ()
9090
9191 -- Wait for incoming connections (pongs from the server)
92− putMVar clientReady ()
92+ putMVar clientReady ()
9393 (pongSock, pongAddr) <- accept sock
9494 socketToChan pongSock multiplexChannel
9595
@@ -107,45 +107,45 @@ socketToChan sock chan = go
107107pingMessage :: ByteString
108108pingMessage = pack "ping123"
109109
110−ping :: Socket -> Chan ByteString -> Int -> IO ()
110+ping :: Socket -> Chan ByteString -> Int -> IO ()
111111ping sock chan pings = go pings
112112 where
113113 go :: Int -> IO ()
114− go 0 = do
114+ go 0 = do
115115 putStrLn $ "client did " ++ show pings ++ " pings"
116116 go !i = do
117117 before <- getCurrentTime
118− send sock pingMessage
119− bs <- readChan chan
118+ send sock pingMessage
119+ bs <- readChan chan
120120 after <- getCurrentTime
121121 -- putStrLn $ "client received " ++ unpack bs
122122 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
123− hPutStrLn stderr $ show i ++ " " ++ show latency
123+ hPutStrLn stderr $ show i ++ " " ++ show latency
124124 go (i - 1)
125125
126−-- | Receive a package
126+-- | Receive a package
127127recv :: Socket -> IO ByteString
128128recv sock = do
129129 header <- NBS.recv sock 4
130− length <- decodeLength header
130+ length <- decodeLength header
131131 NBS.recv sock (fromIntegral (length :: Int32))
132132
133133-- | Send a package
134−send :: Socket -> ByteString -> IO ()
134+send :: Socket -> ByteString -> IO ()
135135send sock bs = do
136136 length <- encodeLength (fromIntegral (BS.length bs))
137137 NBS.sendMany sock [length, bs]
138138
139139-- | Encode length (manual for now)
140140encodeLength :: Int32 -> IO ByteString
141−encodeLength i32 =
141+encodeLength i32 =
142142 BSI.create 4 $ \p ->
143143 pokeByteOff p 0 (htonl (fromIntegral i32))
144144
145145-- | Decode length (manual for now)
146146decodeLength :: ByteString -> IO Int32
147−decodeLength bs =
148− let (fp, _, _) = BSI.toForeignPtr bs in
147+decodeLength bs =
148+ let (fp, _, _) = BSI.toForeignPtr bs in
149149 withForeignPtr fp $ \p -> do
150− w32 <- peekByteOff p 0
150+ w32 <- peekByteOff p 0
151151 return (fromIntegral (ntohl w32))
network-transport-tcp/benchmarks/JustPingWithHeader.hs+15−15
@@ -40,7 +40,7 @@ main = do
4040 -- Start the server
4141 forkIO $ do
4242 putStrLn "server: creating TCP connection"
43− serverAddrs <- getAddrInfo
43+ serverAddrs <- getAddrInfo
4444 (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))
4545 Nothing
4646 (Just "8080")
@@ -61,15 +61,15 @@ main = do
6161 forkIO $ do
6262 takeMVar serverReady
6363 let pings = read pingsStr
64− serverAddrs <- getAddrInfo
64+ serverAddrs <- getAddrInfo
6565 Nothing
6666 (Just "127.0.0.1")
6767 (Just "8080")
6868 let serverAddr = head serverAddrs
6969 sock <- socket (addrFamily serverAddr) Stream defaultProtocol
70−
70+
7171 N.connect sock (addrAddress serverAddr)
72−
72+
7373 ping sock pings
7474 putMVar clientDone ()
7575
@@ -79,20 +79,20 @@ main = do
7979pingMessage :: ByteString
8080pingMessage = pack "ping123"
8181
82−ping :: Socket -> Int -> IO ()
82+ping :: Socket -> Int -> IO ()
8383ping sock pings = go pings
8484 where
8585 go :: Int -> IO ()
86− go 0 = do
86+ go 0 = do
8787 putStrLn $ "client did " ++ show pings ++ " pings"
8888 go !i = do
8989 before <- getCurrentTime
90− send sock pingMessage
90+ send sock pingMessage
9191 bs <- recv sock 8
9292 after <- getCurrentTime
9393 -- putStrLn $ "client received " ++ unpack bs
9494 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)
95− hPutStrLn stderr $ show i ++ " " ++ show latency
95+ hPutStrLn stderr $ show i ++ " " ++ show latency
9696 go (i - 1)
9797
9898pong :: Socket -> IO ()
@@ -103,29 +103,29 @@ pong sock = do
103103 send sock bs
104104 pong sock
105105
106−-- | Wrapper around NBS.recv (for profiling)
106+-- | Wrapper around NBS.recv (for profiling)
107107recv :: Socket -> Int -> IO ByteString
108108recv sock _ = do
109109 header <- NBS.recv sock 4
110− length <- decodeLength header
110+ length <- decodeLength header
111111 NBS.recv sock (fromIntegral (length :: Int32))
112112
113113-- | Wrapper around NBS.send (for profiling)
114−send :: Socket -> ByteString -> IO ()
114+send :: Socket -> ByteString -> IO ()
115115send sock bs = do
116116 length <- encodeLength (fromIntegral (BS.length bs))
117117 NBS.sendMany sock [length, bs]
118118
119119-- | Encode length (manual for now)
120120encodeLength :: Int32 -> IO ByteString
121−encodeLength i32 =
121+encodeLength i32 =
122122 BSI.create 4 $ \p ->
123123 pokeByteOff p 0 (htonl (fromIntegral i32))
124124
125125-- | Decode length (manual for now)
126126decodeLength :: ByteString -> IO Int32
127−decodeLength bs =
128− let (fp, _, _) = BSI.toForeignPtr bs in
127+decodeLength bs =
128+ let (fp, _, _) = BSI.toForeignPtr bs in
129129 withForeignPtr fp $ \p -> do
130− w32 <- peekByteOff p 0
130+ w32 <- peekByteOff p 0
131131 return (fromIntegral (ntohl w32))
network-transport-tcp/src/Network/Transport/TCP.hs+368−368
@@ -1,22 +1,22 @@
1−-- | TCP implementation of the transport layer.
2−--
1+-- | TCP implementation of the transport layer.
2+--
33-- The TCP implementation guarantees that only a single TCP connection (socket)
44-- will be used between endpoints, provided that the addresses specified are
55-- canonical. If /A/ connects to /B/ and reports its address as
66-- @192.168.0.1:8080@ and /B/ subsequently connects tries to connect to /A/ as
77-- @client1.local:http-alt@ then the transport layer will not realize that the
8−-- TCP connection can be reused.
8+-- TCP connection can be reused.
99--
1010-- Applications that use the TCP transport should use
1111-- 'Network.Socket.withSocketsDo' in their main function for Windows
1212-- compatibility (see "Network.Socket").
13−module Network.Transport.TCP
13+module Network.Transport.TCP
1414 ( -- * Main API
1515 createTransport
1616 , TCPParameters(..)
1717 , defaultTCPParameters
18− -- * Internals (exposed for unit tests)
19− , createTransportExposeInternals
18+ -- * Internals (exposed for unit tests)
19+ , createTransportExposeInternals
2020 , TransportInternals(..)
2121 , EndPointId
2222 , encodeEndPointAddress
@@ -25,27 +25,27 @@ module Network.Transport.TCP
2525 , ConnectionRequestResponse(..)
2626 , firstNonReservedLightweightConnectionId
2727 , firstNonReservedHeavyweightConnectionId
28− , socketToEndPoint
28+ , socketToEndPoint
2929 , LightweightConnectionId
3030 -- * Design notes
3131 -- $design
3232 ) where
3333
34−import Prelude hiding
34+import Prelude hiding
3535 ( mapM_
3636#if ! MIN_VERSION_base(4,6,0)
3737 , catch
3838#endif
3939 )
40−
40+
4141import Network.Transport
42−import Network.Transport.TCP.Internal
42+import Network.Transport.TCP.Internal
4343 ( forkServer
4444 , recvWithLength
4545 , recvInt32
4646 , tryCloseSocket
4747 )
48−import Network.Transport.Internal
48+import Network.Transport.Internal
4949 ( encodeInt32
5050 , prependLength
5151 , mapIOException
@@ -59,7 +59,7 @@ import Network.Transport.Internal
5959#ifdef USE_MOCK_NETWORK
6060import qualified Network.Transport.TCP.Mock.Socket as N
6161#else
62−import qualified Network.Socket as N
62+import qualified Network.Socket as N
6363#endif
6464 ( HostName
6565 , ServiceName
@@ -71,7 +71,7 @@ import qualified Network.Socket as N
7171 , SocketType(Stream)
7272 , defaultProtocol
7373 , setSocketOption
74− , SocketOption(ReuseAddr)
74+ , SocketOption(ReuseAddr)
7575 , connect
7676 , sOMAXCONN
7777 , AddrInfo
@@ -85,7 +85,7 @@ import Network.Socket.ByteString (sendMany)
8585
8686import Control.Concurrent (forkIO, ThreadId, killThread, myThreadId)
8787import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
88−import Control.Concurrent.MVar
88+import Control.Concurrent.MVar
8989 ( MVar
9090 , newMVar
9191 , modifyMVar
@@ -98,7 +98,7 @@ import Control.Concurrent.MVar
9898import Control.Category ((>>>))
9999import Control.Applicative ((<$>))
100100import Control.Monad (when, unless, join)
101−import Control.Exception
101+import Control.Exception
102102 ( IOException
103103 , SomeException
104104 , AsyncException
@@ -117,7 +117,7 @@ import qualified Data.ByteString.Char8 as BSC (pack, unpack)
117117import Data.Bits (shiftL, (.|.))
118118import Data.Word (Word32)
119119import Data.Set (Set)
120−import qualified Data.Set as Set
120+import qualified Data.Set as Set
121121 ( empty
122122 , insert
123123 , elems
@@ -128,11 +128,11 @@ import qualified Data.Set as Set
128128 )
129129import Data.Map (Map)
130130import qualified Data.Map as Map (empty)
131−import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))
131+import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))
132132import qualified Data.Accessor.Container as DAC (mapMaybe)
133133import Data.Foldable (forM_, mapM_)
134134
135−-- $design
135+-- $design
136136--
137137-- [Goals]
138138--
@@ -146,7 +146,7 @@ import Data.Foldable (forM_, mapM_)
146146-- > | \~~~|~~~~~~~~~~~~~~~~~~~~~~~~~<| |
147147-- > | |==========================| |
148148-- > +-------+ +-------+
149−--
149+--
150150-- Ignoring the complications detailed below, the TCP connection is set up is
151151-- when the first lightweight connection is created (in either direction), and
152152-- torn down when the last lightweight connection (in either direction) is
@@ -177,7 +177,7 @@ import Data.Foldable (forM_, mapM_)
177177-- with /B/'s connection request completes.
178178--
179179-- [Disconnecting]
180−--
180+--
181181-- The TCP connection is created as soon as the first logical connection from
182182-- /A/ to /B/ (or /B/ to /A/) is established. At this point a thread (@#@) is
183183-- spawned that listens for incoming connections from /B/:
@@ -193,21 +193,21 @@ import Data.Foldable (forM_, mapM_)
193193-- The question is when the TCP connection can be closed again. Conceptually,
194194-- we want to do reference counting: when there are no logical connections left
195195-- between /A/ and /B/ we want to close the socket (possibly after some
196−-- timeout).
196+-- timeout).
197197--
198198-- However, /A/ and /B/ need to agree that the refcount has reached zero. It
199199-- might happen that /B/ sends a connection request over the existing socket at
200200-- the same time that /A/ closes its logical connection to /B/ and closes the
201201-- socket. This will cause a failure in /B/ (which will have to retry) which is
202202-- not caused by a network failure, which is unfortunate. (Note that the
203−-- connection request from /B/ might succeed even if /A/ closes the socket.)
203+-- connection request from /B/ might succeed even if /A/ closes the socket.)
204204--
205205-- Instead, when /A/ is ready to close the socket it sends a 'CloseSocket'
206206-- request to /B/ and records that its connection to /B/ is closing. If /A/
207207-- receives a new connection request from /B/ after having sent the
208208-- 'CloseSocket' request it simply forgets that it sent a 'CloseSocket' request
209209-- and increments the reference count of the connection again.
210−--
210+--
211211-- When /B/ receives a 'CloseSocket' message and it too is ready to close the
212212-- connection, it will respond with a reciprocal 'CloseSocket' request to /A/
213213-- and then actually close the socket. /A/ meanwhile will not send any more
@@ -216,11 +216,11 @@ import Data.Foldable (forM_, mapM_)
216216-- from /B/. (Since /A/ recorded that its connection to /B/ is in closing state
217217-- after sending a 'CloseSocket' request to /B/, it knows not to reciprocate /B/
218218-- reciprocal 'CloseSocket' message.)
219−--
219+--
220220-- If there is a concurrent thread in /A/ waiting to connect to /B/ after /A/
221221-- has sent a 'CloseSocket' request then this thread will block until /A/ knows
222222-- whether to reuse the old socket (if /B/ sends a new connection request
223−-- instead of acknowledging the 'CloseSocket') or to set up a new socket.
223+-- instead of acknowledging the 'CloseSocket') or to set up a new socket.
224224
225225--------------------------------------------------------------------------------
226226-- Internal datatypes --
@@ -229,30 +229,30 @@ import Data.Foldable (forM_, mapM_)
229229-- We use underscores for fields that we might update (using accessors)
230230--
231231-- All data types follow the same structure:
232−--
232+--
233233-- * A top-level data type describing static properties (TCPTransport,
234234-- LocalEndPoint, RemoteEndPoint)
235235-- * The 'static' properties include an MVar containing a data structure for
236236-- the dynamic properties (TransportState, LocalEndPointState,
237−-- RemoteEndPointState). The state could be invalid/valid/closed,/etc.
237+-- RemoteEndPointState). The state could be invalid/valid/closed,/etc.
238238-- * For the case of "valid" we use third data structure to give more details
239239-- about the state (ValidTransportState, ValidLocalEndPointState,
240240-- ValidRemoteEndPointState).
241241
242−data TCPTransport = TCPTransport
242+data TCPTransport = TCPTransport
243243 { transportHost :: !N.HostName
244244 , transportPort :: !N.ServiceName
245245 , transportState :: !(MVar TransportState)
246246 , transportParams :: !TCPParameters
247247 }
248248
249−data TransportState =
249+data TransportState =
250250 TransportValid !ValidTransportState
251251 | TransportClosed
252252
253−data ValidTransportState = ValidTransportState
253+data ValidTransportState = ValidTransportState
254254 { _localEndPoints :: !(Map EndPointAddress LocalEndPoint)
255− , _nextEndPointId :: !EndPointId
255+ , _nextEndPointId :: !EndPointId
256256 }
257257
258258data LocalEndPoint = LocalEndPoint
@@ -261,12 +261,12 @@ data LocalEndPoint = LocalEndPoint
261261 , localState :: !(MVar LocalEndPointState)
262262 }
263263
264−data LocalEndPointState =
264+data LocalEndPointState =
265265 LocalEndPointValid !ValidLocalEndPointState
266266 | LocalEndPointClosed
267267
268−data ValidLocalEndPointState = ValidLocalEndPointState
269− { -- Next available ID for an outgoing lightweight self-connection
268+data ValidLocalEndPointState = ValidLocalEndPointState
269+ { -- Next available ID for an outgoing lightweight self-connection
270270 -- (see also remoteNextConnOutId)
271271 _localNextConnOutId :: !LightweightConnectionId
272272 -- Next available ID for an incoming heavyweight connection
@@ -275,7 +275,7 @@ data ValidLocalEndPointState = ValidLocalEndPointState
275275 , _localConnections :: !(Map EndPointAddress RemoteEndPoint)
276276 }
277277
278−-- REMOTE ENDPOINTS
278+-- REMOTE ENDPOINTS
279279--
280280-- Remote endpoints (basically, TCP connections) have the following lifecycle:
281281--
@@ -302,7 +302,7 @@ data ValidLocalEndPointState = ValidLocalEndPointState
302302-- createConnectionTo when we fail to connect.
303303--
304304-- Valid: This is the "normal" state for a working remote endpoint.
305−--
305+--
306306-- Closing: When we detect that a remote endpoint is no longer used, we send a
307307-- CloseSocket request across the connection and put the remote endpoint in
308308-- closing state. As with Init, 'Closing' carries an MVar () 'resolved' which
@@ -335,16 +335,16 @@ data ValidLocalEndPointState = ValidLocalEndPointState
335335-- localConnections it is guaranteed to either find a different remote
336336-- endpoint, or else none at all (if we don't insist in this order some
337337-- threads might start spinning).
338−--
338+--
339339-- INV-RESOLVE: We should only signal on 'resolved' while the remote endpoint is
340340-- locked, and the remote endpoint must be in Valid or Closed state once
341341-- unlocked. This guarantees that there will not be two threads attempting to
342−-- both signal on 'resolved'.
342+-- both signal on 'resolved'.
343343--
344344-- INV-LOST: If a send or recv fails, or a socket is closed unexpectedly, we
345345-- first put the remote endpoint in Closed state, and then send a
346346-- EventConnectionLost event. This guarantees that we only send this event
347−-- once.
347+-- once.
348348--
349349-- INV-CLOSING: An endpoint in closing state is for all intents and purposes
350350-- closed; that is, we shouldn't do any 'send's on it (although 'recv' is
@@ -357,23 +357,23 @@ data ValidLocalEndPointState = ValidLocalEndPointState
357357-- particular, it is okay to call removeRemoteEndPoint inside
358358-- modifyRemoteState.
359359
360−data RemoteEndPoint = RemoteEndPoint
360+data RemoteEndPoint = RemoteEndPoint
361361 { remoteAddress :: !EndPointAddress
362362 , remoteState :: !(MVar RemoteState)
363363 , remoteId :: !HeavyweightConnectionId
364364 , remoteScheduled :: !(Chan (IO ()))
365365 }
366366
367−data RequestedBy = RequestedByUs | RequestedByThem
367+data RequestedBy = RequestedByUs | RequestedByThem
368368 deriving (Eq, Show)
369369
370370data RemoteState =
371371 -- | Invalid remote endpoint (for example, invalid address)
372372 RemoteEndPointInvalid !(TransportError ConnectErrorCode)
373373 -- | The remote endpoint is being initialized
374− | RemoteEndPointInit !(MVar ()) !(MVar ()) !RequestedBy
374+ | RemoteEndPointInit !(MVar ()) !(MVar ()) !RequestedBy
375375 -- | "Normal" working endpoint
376− | RemoteEndPointValid !ValidRemoteEndPointState
376+ | RemoteEndPointValid !ValidRemoteEndPointState
377377 -- | The remote endpoint is being closed (garbage collected)
378378 | RemoteEndPointClosing !(MVar ()) !ValidRemoteEndPointState
379379 -- | The remote endpoint has been closed (garbage collected)
@@ -382,12 +382,12 @@ data RemoteState =
382382 -- using a closeTransport or closeEndPoint API call
383383 | RemoteEndPointFailed !IOException
384384
385−-- TODO: we might want to replace Set (here and elsewhere) by faster
385+-- TODO: we might want to replace Set (here and elsewhere) by faster
386386-- containers
387387--
388388-- TODO: we could get rid of 'remoteIncoming' (and maintain less state) if
389−-- we introduce a new event 'AllConnectionsClosed'
390−data ValidRemoteEndPointState = ValidRemoteEndPointState
389+-- we introduce a new event 'AllConnectionsClosed'
390+data ValidRemoteEndPointState = ValidRemoteEndPointState
391391 { _remoteOutgoing :: !Int
392392 , _remoteIncoming :: !(Set LightweightConnectionId)
393393 , _remoteMaxIncoming :: !LightweightConnectionId
@@ -414,24 +414,24 @@ type LightweightConnectionId = Word32
414414-- 'LightweightConnectionId'.
415415type HeavyweightConnectionId = Word32
416416
417−-- | Control headers
418−data ControlHeader =
417+-- | Control headers
418+data ControlHeader =
419419 -- | Tell the remote endpoint that we created a new connection
420− CreatedNewConnection
420+ CreatedNewConnection
421421 -- | Tell the remote endpoint we will no longer be using a connection
422− | CloseConnection
422+ | CloseConnection
423423 -- | Request to close the connection (see module description)
424− | CloseSocket
424+ | CloseSocket
425425 deriving (Enum, Bounded, Show)
426426
427427-- | Response sent by /B/ to /A/ when /A/ tries to connect
428428data ConnectionRequestResponse =
429429 -- | /B/ accepts the connection
430− ConnectionRequestAccepted
430+ ConnectionRequestAccepted
431431 -- | /A/ requested an invalid endpoint
432− | ConnectionRequestInvalid
432+ | ConnectionRequestInvalid
433433 -- | /A/s request crossed with a request from /B/ (see protocols)
434− | ConnectionRequestCrossed
434+ | ConnectionRequestCrossed
435435 deriving (Enum, Bounded, Show)
436436
437437-- | Parameters for setting up the TCP transport
@@ -439,7 +439,7 @@ data TCPParameters = TCPParameters {
439439 -- | Backlog for 'listen'.
440440 -- Defaults to SOMAXCONN.
441441 tcpBacklog :: Int
442− -- | Should we set SO_REUSEADDR on the server socket?
442+ -- | Should we set SO_REUSEADDR on the server socket?
443443 -- Defaults to True.
444444 , tcpReuseServerAddr :: Bool
445445 -- | Should we set SO_REUSEADDR on client sockets?
@@ -448,13 +448,13 @@ data TCPParameters = TCPParameters {
448448 }
449449
450450-- | Internal functionality we expose for unit testing
451−data TransportInternals = TransportInternals
451+data TransportInternals = TransportInternals
452452 { -- | The ID of the thread that listens for new incoming connections
453453 transportThread :: ThreadId
454454 -- | Find the socket between a local and a remote endpoint
455− , socketBetween :: EndPointAddress
456− -> EndPointAddress
457− -> IO N.Socket
455+ , socketBetween :: EndPointAddress
456+ -> EndPointAddress
457+ -> IO N.Socket
458458 }
459459
460460--------------------------------------------------------------------------------
@@ -462,62 +462,62 @@ data TransportInternals = TransportInternals
462462--------------------------------------------------------------------------------
463463
464464-- | Create a TCP transport
465−createTransport :: N.HostName
466− -> N.ServiceName
465+createTransport :: N.HostName
466+ -> N.ServiceName
467467 -> TCPParameters
468468 -> IO (Either IOException Transport)
469−createTransport host port params =
469+createTransport host port params =
470470 either Left (Right . fst) <$> createTransportExposeInternals host port params
471471
472472-- | You should probably not use this function (used for unit testing only)
473−createTransportExposeInternals
474− :: N.HostName
475− -> N.ServiceName
473+createTransportExposeInternals
474+ :: N.HostName
475+ -> N.ServiceName
476476 -> TCPParameters
477− -> IO (Either IOException (Transport, TransportInternals))
478−createTransportExposeInternals host port params = do
479− state <- newMVar . TransportValid $ ValidTransportState
480− { _localEndPoints = Map.empty
481− , _nextEndPointId = 0
477+ -> IO (Either IOException (Transport, TransportInternals))
478+createTransportExposeInternals host port params = do
479+ state <- newMVar . TransportValid $ ValidTransportState
480+ { _localEndPoints = Map.empty
481+ , _nextEndPointId = 0
482482 }
483483 let transport = TCPTransport { transportState = state
484484 , transportHost = host
485485 , transportPort = port
486486 , transportParams = params
487487 }
488− tryIO $ bracketOnError (forkServer
489− host
490− port
491− (tcpBacklog params)
488+ tryIO $ bracketOnError (forkServer
489+ host
490+ port
491+ (tcpBacklog params)
492492 (tcpReuseServerAddr params)
493− (terminationHandler transport)
493+ (terminationHandler transport)
494494 (handleConnectionRequest transport))
495495 killThread
496496 (mkTransport transport)
497497 where
498− mkTransport :: TCPTransport
499− -> ThreadId
498+ mkTransport :: TCPTransport
499+ -> ThreadId
500500 -> IO (Transport, TransportInternals)
501501 mkTransport transport tid = return
502− ( Transport
503− { newEndPoint = apiNewEndPoint transport
502+ ( Transport
503+ { newEndPoint = apiNewEndPoint transport
504504 , closeTransport = let evs = [ EndPointClosed
505505 , throw $ userError "Transport closed"
506506 ] in
507− apiCloseTransport transport (Just tid) evs
508− }
509− , TransportInternals
507+ apiCloseTransport transport (Just tid) evs
508+ }
509+ , TransportInternals
510510 { transportThread = tid
511511 , socketBetween = internalSocketBetween transport
512512 }
513513 )
514514
515515 terminationHandler :: TCPTransport -> SomeException -> IO ()
516− terminationHandler transport ex = do
516+ terminationHandler transport ex = do
517517 let evs = [ ErrorEvent (TransportError EventTransportFailed (show ex))
518− , throw $ userError "Transport closed"
518+ , throw $ userError "Transport closed"
519519 ]
520− apiCloseTransport transport Nothing evs
520+ apiCloseTransport transport Nothing evs
521521
522522-- | Default TCP parameters
523523defaultTCPParameters :: TCPParameters
@@ -533,39 +533,39 @@ defaultTCPParameters = TCPParameters {
533533
534534-- | Close the transport
535535apiCloseTransport :: TCPTransport -> Maybe ThreadId -> [Event] -> IO ()
536−apiCloseTransport transport mTransportThread evs =
536+apiCloseTransport transport mTransportThread evs =
537537 asyncWhenCancelled return $ do
538538 mTSt <- modifyMVar (transportState transport) $ \st -> case st of
539539 TransportValid vst -> return (TransportClosed, Just vst)
540540 TransportClosed -> return (TransportClosed, Nothing)
541− forM_ mTSt $ mapM_ (apiCloseEndPoint transport evs) . (^. localEndPoints)
541+ forM_ mTSt $ mapM_ (apiCloseEndPoint transport evs) . (^. localEndPoints)
542542 -- This will invoke the termination handler, which in turn will call
543543 -- apiCloseTransport again, but then the transport will already be closed
544544 -- and we won't be passed a transport thread, so we terminate immmediate
545− forM_ mTransportThread killThread
546−
547−-- | Create a new endpoint
548−apiNewEndPoint :: TCPTransport
545+ forM_ mTransportThread killThread
546+
547+-- | Create a new endpoint
548+apiNewEndPoint :: TCPTransport
549549 -> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
550−apiNewEndPoint transport =
550+apiNewEndPoint transport =
551551 try . asyncWhenCancelled closeEndPoint $ do
552552 ourEndPoint <- createLocalEndPoint transport
553− return EndPoint
553+ return EndPoint
554554 { receive = readChan (localChannel ourEndPoint)
555555 , address = localAddress ourEndPoint
556− , connect = apiConnect (transportParams transport) ourEndPoint
556+ , connect = apiConnect (transportParams transport) ourEndPoint
557557 , closeEndPoint = let evs = [ EndPointClosed
558− , throw $ userError "Endpoint closed"
558+ , throw $ userError "Endpoint closed"
559559 ] in
560560 apiCloseEndPoint transport evs ourEndPoint
561− , newMulticastGroup = return . Left $ newMulticastGroupError
561+ , newMulticastGroup = return . Left $ newMulticastGroupError
562562 , resolveMulticastGroup = return . Left . const resolveMulticastGroupError
563563 }
564564 where
565− newMulticastGroupError =
566− TransportError NewMulticastGroupUnsupported "Multicast not supported"
567− resolveMulticastGroupError =
568− TransportError ResolveMulticastGroupUnsupported "Multicast not supported"
565+ newMulticastGroupError =
566+ TransportError NewMulticastGroupUnsupported "Multicast not supported"
567+ resolveMulticastGroupError =
568+ TransportError ResolveMulticastGroupUnsupported "Multicast not supported"
569569
570570-- | Connnect to an endpoint
571571apiConnect :: TCPParameters -- ^ Parameters
@@ -575,35 +575,35 @@ apiConnect :: TCPParameters -- ^ Parameters
575575 -> ConnectHints -- ^ Hints
576576 -> IO (Either (TransportError ConnectErrorCode) Connection)
577577apiConnect params ourEndPoint theirAddress _reliability hints =
578− try . asyncWhenCancelled close $
579− if localAddress ourEndPoint == theirAddress
580− then connectToSelf ourEndPoint
578+ try . asyncWhenCancelled close $
579+ if localAddress ourEndPoint == theirAddress
580+ then connectToSelf ourEndPoint
581581 else do
582582 resetIfBroken ourEndPoint theirAddress
583− (theirEndPoint, connId) <-
583+ (theirEndPoint, connId) <-
584584 createConnectionTo params ourEndPoint theirAddress hints
585585 -- connAlive can be an IORef rather than an MVar because it is protected
586586 -- by the remoteState MVar. We don't need the overhead of locking twice.
587587 connAlive <- newIORef True
588− return Connection
589− { send = apiSend (ourEndPoint, theirEndPoint) connId connAlive
590− , close = apiClose (ourEndPoint, theirEndPoint) connId connAlive
588+ return Connection
589+ { send = apiSend (ourEndPoint, theirEndPoint) connId connAlive
590+ , close = apiClose (ourEndPoint, theirEndPoint) connId connAlive
591591 }
592592
593593-- | Close a connection
594594apiClose :: EndPointPair -> LightweightConnectionId -> IORef Bool -> IO ()
595−apiClose (ourEndPoint, theirEndPoint) connId connAlive =
596− void . tryIO . asyncWhenCancelled return $ do
595+apiClose (ourEndPoint, theirEndPoint) connId connAlive =
596+ void . tryIO . asyncWhenCancelled return $ do
597597 mAct <- modifyMVar (remoteState theirEndPoint) $ \st -> case st of
598598 RemoteEndPointValid vst -> do
599599 alive <- readIORef connAlive
600− if alive
600+ if alive
601601 then do
602602 writeIORef connAlive False
603− act <- schedule theirEndPoint $
604− sendOn vst [encodeInt32 CloseConnection, encodeInt32 connId]
605− return ( RemoteEndPointValid
606− . (remoteOutgoing ^: (\x -> x - 1))
603+ act <- schedule theirEndPoint $
604+ sendOn vst [encodeInt32 CloseConnection, encodeInt32 connId]
605+ return ( RemoteEndPointValid
606+ . (remoteOutgoing ^: (\x -> x - 1))
607607 $ vst
608608 , Just act
609609 )
@@ -616,12 +616,12 @@ apiClose (ourEndPoint, theirEndPoint) connId connAlive =
616616
617617
618618-- | Send data across a connection
619−apiSend :: EndPointPair -- ^ Local and remote endpoint
619+apiSend :: EndPointPair -- ^ Local and remote endpoint
620620 -> LightweightConnectionId -- ^ Connection ID
621621 -> IORef Bool -- ^ Is the connection still alive?
622622 -> [ByteString] -- ^ Payload
623623 -> IO (Either (TransportError SendErrorCode) ())
624−apiSend (ourEndPoint, theirEndPoint) connId connAlive payload =
624+apiSend (ourEndPoint, theirEndPoint) connId connAlive payload =
625625 -- We don't need the overhead of asyncWhenCancelled here
626626 try . mapIOException sendFailed $ do
627627 act <- withMVar (remoteState theirEndPoint) $ \st -> case st of
@@ -631,70 +631,70 @@ apiSend (ourEndPoint, theirEndPoint) connId connAlive payload =
631631 relyViolation (ourEndPoint, theirEndPoint) "apiSend"
632632 RemoteEndPointValid vst -> do
633633 alive <- readIORef connAlive
634− if alive
635− then schedule theirEndPoint $
634+ if alive
635+ then schedule theirEndPoint $
636636 sendOn vst (encodeInt32 connId : prependLength payload)
637637 else throwIO $ TransportError SendClosed "Connection closed"
638− RemoteEndPointClosing _ _ -> do
638+ RemoteEndPointClosing _ _ -> do
639639 alive <- readIORef connAlive
640− if alive
641− then relyViolation (ourEndPoint, theirEndPoint) "apiSend"
640+ if alive
641+ then relyViolation (ourEndPoint, theirEndPoint) "apiSend"
642642 else throwIO $ TransportError SendClosed "Connection closed"
643643 RemoteEndPointClosed -> do
644644 alive <- readIORef connAlive
645− if alive
646− then relyViolation (ourEndPoint, theirEndPoint) "apiSend"
645+ if alive
646+ then relyViolation (ourEndPoint, theirEndPoint) "apiSend"
647647 else throwIO $ TransportError SendClosed "Connection closed"
648648 RemoteEndPointFailed err -> do
649649 alive <- readIORef connAlive
650− if alive
651− then throwIO $ TransportError SendFailed (show err)
650+ if alive
651+ then throwIO $ TransportError SendFailed (show err)
652652 else throwIO $ TransportError SendClosed "Connection closed"
653653 runScheduledAction (ourEndPoint, theirEndPoint) act
654654 where
655655 sendFailed = TransportError SendFailed . show
656656
657657-- | Force-close the endpoint
658−apiCloseEndPoint :: TCPTransport -- ^ Transport
659− -> [Event] -- ^ Events used to report closure
658+apiCloseEndPoint :: TCPTransport -- ^ Transport
659+ -> [Event] -- ^ Events used to report closure
660660 -> LocalEndPoint -- ^ Local endpoint
661661 -> IO ()
662662apiCloseEndPoint transport evs ourEndPoint =
663663 asyncWhenCancelled return $ do
664664 -- Remove the reference from the transport state
665665 removeLocalEndPoint transport ourEndPoint
666− -- Close the local endpoint
666+ -- Close the local endpoint
667667 mOurState <- modifyMVar (localState ourEndPoint) $ \st ->
668668 case st of
669− LocalEndPointValid vst ->
669+ LocalEndPointValid vst ->
670670 return (LocalEndPointClosed, Just vst)
671671 LocalEndPointClosed ->
672672 return (LocalEndPointClosed, Nothing)
673673 forM_ mOurState $ \vst -> do
674674 forM_ (vst ^. localConnections) tryCloseRemoteSocket
675− forM_ evs $ writeChan (localChannel ourEndPoint)
675+ forM_ evs $ writeChan (localChannel ourEndPoint)
676676 where
677677 -- Close the remote socket and return the set of all incoming connections
678− tryCloseRemoteSocket :: RemoteEndPoint -> IO ()
678+ tryCloseRemoteSocket :: RemoteEndPoint -> IO ()
679679 tryCloseRemoteSocket theirEndPoint = do
680− -- We make an attempt to close the connection nicely
680+ -- We make an attempt to close the connection nicely
681681 -- (by sending a CloseSocket first)
682682 let closed = RemoteEndPointFailed . userError $ "apiCloseEndPoint"
683683 mAct <- modifyMVar (remoteState theirEndPoint) $ \st ->
684684 case st of
685− RemoteEndPointInvalid _ ->
685+ RemoteEndPointInvalid _ ->
686686 return (st, Nothing)
687687 RemoteEndPointInit resolved _ _ -> do
688688 putMVar resolved ()
689689 return (closed, Nothing)
690− RemoteEndPointValid vst -> do
690+ RemoteEndPointValid vst -> do
691691 act <- schedule theirEndPoint $ do
692692 tryIO $ sendOn vst [ encodeInt32 CloseSocket
693693 , encodeInt32 (vst ^. remoteMaxIncoming)
694694 ]
695695 tryCloseSocket (remoteSocket vst)
696696 return (closed, Just act)
697− RemoteEndPointClosing resolved vst -> do
697+ RemoteEndPointClosing resolved vst -> do
698698 putMVar resolved ()
699699 act <- schedule theirEndPoint $ tryCloseSocket (remoteSocket vst)
700700 return (closed, Just act)
@@ -703,7 +703,7 @@ apiCloseEndPoint transport evs ourEndPoint =
703703 RemoteEndPointFailed err ->
704704 return (RemoteEndPointFailed err, Nothing)
705705 forM_ mAct $ runScheduledAction (ourEndPoint, theirEndPoint)
706−
706+
707707
708708--------------------------------------------------------------------------------
709709-- Incoming requests --
@@ -720,11 +720,11 @@ apiCloseEndPoint transport evs ourEndPoint =
720720-- the transport down. We must be careful to close the socket when a (possibly
721721-- asynchronous, ThreadKilled) exception occurs. (If an exception escapes from
722722-- handleConnectionRequest the transport will be shut down.)
723−handleConnectionRequest :: TCPTransport -> N.Socket -> IO ()
724−handleConnectionRequest transport sock = handle handleException $ do
723+handleConnectionRequest :: TCPTransport -> N.Socket -> IO ()
724+handleConnectionRequest transport sock = handle handleException $ do
725725 ourEndPointId <- recvInt32 sock
726− theirAddress <- EndPointAddress . BS.concat <$> recvWithLength sock
727− let ourAddress = encodeEndPointAddress (transportHost transport)
726+ theirAddress <- EndPointAddress . BS.concat <$> recvWithLength sock
727+ let ourAddress = encodeEndPointAddress (transportHost transport)
728728 (transportPort transport)
729729 ourEndPointId
730730 ourEndPoint <- withMVar (transportState transport) $ \st -> case st of
@@ -735,32 +735,32 @@ handleConnectionRequest transport sock = handle handleException $ do
735735 throwIO $ userError "handleConnectionRequest: Invalid endpoint"
736736 Just ourEndPoint ->
737737 return ourEndPoint
738− TransportClosed ->
738+ TransportClosed ->
739739 throwIO $ userError "Transport closed"
740740 void . forkIO $ go ourEndPoint theirAddress
741741 where
742742 go :: LocalEndPoint -> EndPointAddress -> IO ()
743− go ourEndPoint theirAddress = do
743+ go ourEndPoint theirAddress = do
744744 -- This runs in a thread that will never be killed
745− mEndPoint <- handle ((>> return Nothing) . handleException) $ do
745+ mEndPoint <- handle ((>> return Nothing) . handleException) $ do
746746 resetIfBroken ourEndPoint theirAddress
747− (theirEndPoint, isNew) <-
747+ (theirEndPoint, isNew) <-
748748 findRemoteEndPoint ourEndPoint theirAddress RequestedByThem
749−
750− if not isNew
749+
750+ if not isNew
751751 then do
752752 tryIO $ sendMany sock [encodeInt32 ConnectionRequestCrossed]
753753 tryCloseSocket sock
754− return Nothing
754+ return Nothing
755755 else do
756756 sendLock <- newMVar ()
757− let vst = ValidRemoteEndPointState
757+ let vst = ValidRemoteEndPointState
758758 { remoteSocket = sock
759759 , remoteSendLock = sendLock
760760 , _remoteOutgoing = 0
761761 , _remoteIncoming = Set.empty
762762 , _remoteMaxIncoming = 0
763− , _remoteNextConnOutId = firstNonReservedLightweightConnectionId
763+ , _remoteNextConnOutId = firstNonReservedLightweightConnectionId
764764 }
765765 sendMany sock [encodeInt32 ConnectionRequestAccepted]
766766 resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointValid vst)
@@ -769,30 +769,30 @@ handleConnectionRequest transport sock = handle handleException $ do
769769 -- Nothing then the socket is already closed; otherwise, the socket has
770770 -- been recorded as part of the remote endpoint. Either way, we no longer
771771 -- have to worry about closing the socket on receiving an asynchronous
772− -- exception from this point forward.
772+ -- exception from this point forward.
773773 forM_ mEndPoint $ handleIncomingMessages . (,) ourEndPoint
774774
775775 handleException :: SomeException -> IO ()
776− handleException ex = do
777− tryCloseSocket sock
776+ handleException ex = do
777+ tryCloseSocket sock
778778 rethrowIfAsync (fromException ex)
779779
780− rethrowIfAsync :: Maybe AsyncException -> IO ()
781− rethrowIfAsync = mapM_ throwIO
780+ rethrowIfAsync :: Maybe AsyncException -> IO ()
781+ rethrowIfAsync = mapM_ throwIO
782782
783783-- | Handle requests from a remote endpoint.
784−--
784+--
785785-- Returns only if the remote party closes the socket or if an error occurs.
786786-- This runs in a thread that will never be killed.
787−handleIncomingMessages :: EndPointPair -> IO ()
787+handleIncomingMessages :: EndPointPair -> IO ()
788788handleIncomingMessages (ourEndPoint, theirEndPoint) = do
789789 mSock <- withMVar theirState $ \st ->
790790 case st of
791791 RemoteEndPointInvalid _ ->
792− relyViolation (ourEndPoint, theirEndPoint)
793− "handleIncomingMessages (invalid)"
792+ relyViolation (ourEndPoint, theirEndPoint)
793+ "handleIncomingMessages (invalid)"
794794 RemoteEndPointInit _ _ _ ->
795− relyViolation (ourEndPoint, theirEndPoint)
795+ relyViolation (ourEndPoint, theirEndPoint)
796796 "handleIncomingMessages (init)"
797797 RemoteEndPointValid ep ->
798798 return . Just $ remoteSocket ep
@@ -800,13 +800,13 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do
800800 return . Just $ remoteSocket ep
801801 RemoteEndPointClosed ->
802802 return Nothing
803− RemoteEndPointFailed _ ->
803+ RemoteEndPointFailed _ ->
804804 return Nothing
805−
806− forM_ mSock $ \sock ->
805+
806+ forM_ mSock $ \sock ->
807807 tryIO (go sock) >>= either (prematureExit sock) return
808808 where
809− -- Dispatch
809+ -- Dispatch
810810 --
811811 -- If a recv throws an exception this will be caught top-level and
812812 -- 'prematureExit' will be invoked. The same will happen if the remote
@@ -817,38 +817,38 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do
817817 go :: N.Socket -> IO ()
818818 go sock = do
819819 lcid <- recvInt32 sock :: IO LightweightConnectionId
820− if lcid >= firstNonReservedLightweightConnectionId
820+ if lcid >= firstNonReservedLightweightConnectionId
821821 then do
822− readMessage sock lcid
822+ readMessage sock lcid
823823 go sock
824− else
824+ else
825825 case tryToEnum (fromIntegral lcid) of
826826 Just CreatedNewConnection -> do
827− recvInt32 sock >>= createdNewConnection
828− go sock
827+ recvInt32 sock >>= createdNewConnection
828+ go sock
829829 Just CloseConnection -> do
830− recvInt32 sock >>= closeConnection
830+ recvInt32 sock >>= closeConnection
831831 go sock
832− Just CloseSocket -> do
833− didClose <- recvInt32 sock >>= closeSocket sock
832+ Just CloseSocket -> do
833+ didClose <- recvInt32 sock >>= closeSocket sock
834834 unless didClose $ go sock
835835 Nothing ->
836836 throwIO $ userError "Invalid control request"
837−
837+
838838 -- Create a new connection
839− createdNewConnection :: LightweightConnectionId -> IO ()
839+ createdNewConnection :: LightweightConnectionId -> IO ()
840840 createdNewConnection lcid = do
841841 modifyMVar_ theirState $ \st -> do
842842 vst <- case st of
843843 RemoteEndPointInvalid _ ->
844− relyViolation (ourEndPoint, theirEndPoint)
844+ relyViolation (ourEndPoint, theirEndPoint)
845845 "handleIncomingMessages:createNewConnection (invalid)"
846846 RemoteEndPointInit _ _ _ ->
847− relyViolation (ourEndPoint, theirEndPoint)
847+ relyViolation (ourEndPoint, theirEndPoint)
848848 "handleIncomingMessages:createNewConnection (init)"
849849 RemoteEndPointValid vst ->
850850 return ( (remoteIncoming ^: Set.insert lcid)
851− $ (remoteMaxIncoming ^= lcid)
851+ $ (remoteMaxIncoming ^= lcid)
852852 vst
853853 )
854854 RemoteEndPointClosing resolved vst -> do
@@ -863,36 +863,36 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do
863863 . (remoteMaxIncoming ^= lcid)
864864 $ vst
865865 )
866− RemoteEndPointFailed err ->
866+ RemoteEndPointFailed err ->
867867 throwIO err
868868 RemoteEndPointClosed ->
869− relyViolation (ourEndPoint, theirEndPoint)
869+ relyViolation (ourEndPoint, theirEndPoint)
870870 "createNewConnection (closed)"
871871 return (RemoteEndPointValid vst)
872− writeChan ourChannel (ConnectionOpened (connId lcid) ReliableOrdered theirAddr)
872+ writeChan ourChannel (ConnectionOpened (connId lcid) ReliableOrdered theirAddr)
873873
874− -- Close a connection
874+ -- Close a connection
875875 -- It is important that we verify that the connection is in fact open,
876876 -- because otherwise we should not decrement the reference count
877− closeConnection :: LightweightConnectionId -> IO ()
877+ closeConnection :: LightweightConnectionId -> IO ()
878878 closeConnection lcid = do
879879 modifyMVar_ theirState $ \st -> case st of
880880 RemoteEndPointInvalid _ ->
881881 relyViolation (ourEndPoint, theirEndPoint) "closeConnection (invalid)"
882882 RemoteEndPointInit _ _ _ ->
883883 relyViolation (ourEndPoint, theirEndPoint) "closeConnection (init)"
884− RemoteEndPointValid vst -> do
885− unless (Set.member lcid (vst ^. remoteIncoming)) $
884+ RemoteEndPointValid vst -> do
885+ unless (Set.member lcid (vst ^. remoteIncoming)) $
886886 throwIO $ userError "Invalid CloseConnection"
887− return ( RemoteEndPointValid
888− . (remoteIncoming ^: Set.delete lcid)
887+ return ( RemoteEndPointValid
888+ . (remoteIncoming ^: Set.delete lcid)
889889 $ vst
890890 )
891891 RemoteEndPointClosing _ _ ->
892892 -- If the remote endpoint is in Closing state, that means that are as
893893 -- far as we are concerned there are no incoming connections. This
894894 -- means that a CloseConnection request at this point is invalid.
895− throwIO $ userError "Invalid CloseConnection request"
895+ throwIO $ userError "Invalid CloseConnection request"
896896 RemoteEndPointFailed err ->
897897 throwIO err
898898 RemoteEndPointClosed ->
@@ -900,7 +900,7 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do
900900 writeChan ourChannel (ConnectionClosed (connId lcid))
901901
902902 -- Close the socket (if we don't have any outgoing connections)
903− closeSocket :: N.Socket -> LightweightConnectionId -> IO Bool
903+ closeSocket :: N.Socket -> LightweightConnectionId -> IO Bool
904904 closeSocket sock lastReceivedId = do
905905 mAct <- modifyMVar theirState $ \st -> do
906906 case st of
@@ -908,38 +908,38 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do
908908 relyViolation (ourEndPoint, theirEndPoint)
909909 "handleIncomingMessages:closeSocket (invalid)"
910910 RemoteEndPointInit _ _ _ ->
911− relyViolation (ourEndPoint, theirEndPoint)
911+ relyViolation (ourEndPoint, theirEndPoint)
912912 "handleIncomingMessages:closeSocket (init)"
913913 RemoteEndPointValid vst -> do
914914 -- We regard a CloseSocket message as an (optimized) way for the
915915 -- remote endpoint to indicate that all its connections to us are
916916 -- now properly closed
917− forM_ (Set.elems $ vst ^. remoteIncoming) $
917+ forM_ (Set.elems $ vst ^. remoteIncoming) $
918918 writeChan ourChannel . ConnectionClosed . connId
919− let vst' = remoteIncoming ^= Set.empty $ vst
919+ let vst' = remoteIncoming ^= Set.empty $ vst
920920 -- If we still have outgoing connections then we ignore the
921921 -- CloseSocket request (we sent a ConnectionCreated message to the
922922 -- remote endpoint, but it did not receive it before sending the
923923 -- CloseSocket request). Similarly, if lastReceivedId < lastSentId
924924 -- then we sent a ConnectionCreated *AND* a ConnectionClosed
925925 -- message to the remote endpoint, *both of which* it did not yet
926− -- receive before sending the CloseSocket request.
927− if vst' ^. remoteOutgoing > 0 || lastReceivedId < lastSentId vst
926+ -- receive before sending the CloseSocket request.
927+ if vst' ^. remoteOutgoing > 0 || lastReceivedId < lastSentId vst
928928 then
929929 return (RemoteEndPointValid vst', Nothing)
930− else do
930+ else do
931931 removeRemoteEndPoint (ourEndPoint, theirEndPoint)
932932 -- Attempt to reply (but don't insist)
933933 act <- schedule theirEndPoint $ do
934934 tryIO $ sendOn vst' [ encodeInt32 CloseSocket
935935 , encodeInt32 (vst ^. remoteMaxIncoming)
936936 ]
937− tryCloseSocket sock
937+ tryCloseSocket sock
938938 return (RemoteEndPointClosed, Just act)
939939 RemoteEndPointClosing resolved vst -> do
940940 -- Like above, we need to check if there is a ConnectionCreated
941− -- message that we sent but that the remote endpoint has not yet
942− -- received. However, since we are in 'closing' state, the only
941+ -- message that we sent but that the remote endpoint has not yet
942+ -- received. However, since we are in 'closing' state, the only
943943 -- way this may happen is when we sent a ConnectionCreated,
944944 -- ConnectionClosed, and CloseSocket message, none of which have
945945 -- yet been received. We leave the endpoint in closing state in
@@ -949,29 +949,29 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do
949949 return (RemoteEndPointClosing resolved vst, Nothing)
950950 else do
951951 removeRemoteEndPoint (ourEndPoint, theirEndPoint)
952− act <- schedule theirEndPoint $ tryCloseSocket sock
952+ act <- schedule theirEndPoint $ tryCloseSocket sock
953953 putMVar resolved ()
954954 return (RemoteEndPointClosed, Just act)
955955 RemoteEndPointFailed err ->
956956 throwIO err
957957 RemoteEndPointClosed ->
958− relyViolation (ourEndPoint, theirEndPoint)
958+ relyViolation (ourEndPoint, theirEndPoint)
959959 "handleIncomingMessages:closeSocket (closed)"
960960 case mAct of
961961 Nothing -> return False
962962 Just act -> do
963963 runScheduledAction (ourEndPoint, theirEndPoint) act
964964 return True
965−
965+
966966 -- Read a message and output it on the endPoint's channel. By rights we
967967 -- should verify that the connection ID is valid, but this is unnecessary
968968 -- overhead
969− readMessage :: N.Socket -> LightweightConnectionId -> IO ()
970− readMessage sock lcid =
971− recvWithLength sock >>= writeChan ourChannel . Received (connId lcid)
969+ readMessage :: N.Socket -> LightweightConnectionId -> IO ()
970+ readMessage sock lcid =
971+ recvWithLength sock >>= writeChan ourChannel . Received (connId lcid)
972972
973973 -- Arguments
974− ourChannel = localChannel ourEndPoint
974+ ourChannel = localChannel ourEndPoint
975975 theirState = remoteState theirEndPoint
976976 theirAddr = remoteAddress theirEndPoint
977977
@@ -982,20 +982,20 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do
982982 modifyMVar_ theirState $ \st ->
983983 case st of
984984 RemoteEndPointInvalid _ ->
985− relyViolation (ourEndPoint, theirEndPoint)
985+ relyViolation (ourEndPoint, theirEndPoint)
986986 "handleIncomingMessages:prematureExit"
987987 RemoteEndPointInit _ _ _ ->
988− relyViolation (ourEndPoint, theirEndPoint)
988+ relyViolation (ourEndPoint, theirEndPoint)
989989 "handleIncomingMessages:prematureExit"
990990 RemoteEndPointValid _ -> do
991− let code = EventConnectionLost (remoteAddress theirEndPoint)
991+ let code = EventConnectionLost (remoteAddress theirEndPoint)
992992 writeChan ourChannel . ErrorEvent $ TransportError code (show err)
993993 return (RemoteEndPointFailed err)
994994 RemoteEndPointClosing resolved _ -> do
995995 putMVar resolved ()
996996 return (RemoteEndPointFailed err)
997997 RemoteEndPointClosed ->
998− relyViolation (ourEndPoint, theirEndPoint)
998+ relyViolation (ourEndPoint, theirEndPoint)
999999 "handleIncomingMessages:prematureExit"
10001000 RemoteEndPointFailed err' ->
10011001 return (RemoteEndPointFailed err')
@@ -1006,7 +1006,7 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do
10061006
10071007 -- The ID of the last connection _we_ created (or 0 for none)
10081008 lastSentId :: ValidRemoteEndPointState -> LightweightConnectionId
1009− lastSentId vst =
1009+ lastSentId vst =
10101010 if vst ^. remoteNextConnOutId == firstNonReservedLightweightConnectionId
10111011 then 0
10121012 else (vst ^. remoteNextConnOutId) - 1
@@ -1021,12 +1021,12 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do
10211021-- | Create a connection to a remote endpoint
10221022--
10231023-- If the remote endpoint is in 'RemoteEndPointClosing' state then we will
1024−-- block until that is resolved.
1024+-- block until that is resolved.
10251025--
10261026-- May throw a TransportError ConnectErrorCode exception.
1027−createConnectionTo :: TCPParameters
1028− -> LocalEndPoint
1029− -> EndPointAddress
1027+createConnectionTo :: TCPParameters
1028+ -> LocalEndPoint
1029+ -> EndPointAddress
10301030 -> ConnectHints
10311031 -> IO (RemoteEndPoint, LightweightConnectionId)
10321032createConnectionTo params ourEndPoint theirAddress hints = go
@@ -1035,27 +1035,27 @@ createConnectionTo params ourEndPoint theirAddress hints = go
10351035 (theirEndPoint, isNew) <- mapIOException connectFailed $
10361036 findRemoteEndPoint ourEndPoint theirAddress RequestedByUs
10371037
1038− if isNew
1038+ if isNew
10391039 then do
1040− forkIO . handle absorbAllExceptions $
1041− setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints
1040+ forkIO . handle absorbAllExceptions $
1041+ setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints
10421042 go
10431043 else do
10441044 -- 'findRemoteEndPoint' will have increased 'remoteOutgoing'
10451045 mapIOException connectFailed $ do
10461046 act <- modifyMVar (remoteState theirEndPoint) $ \st -> case st of
1047− RemoteEndPointValid vst -> do
1048− let connId = vst ^. remoteNextConnOutId
1047+ RemoteEndPointValid vst -> do
1048+ let connId = vst ^. remoteNextConnOutId
10491049 act <- schedule theirEndPoint $ do
10501050 sendOn vst [encodeInt32 CreatedNewConnection, encodeInt32 connId]
10511051 return connId
1052− return ( RemoteEndPointValid
1053− $ remoteNextConnOutId ^= connId + 1
1052+ return ( RemoteEndPointValid
1053+ $ remoteNextConnOutId ^= connId + 1
10541054 $ vst
1055− , act
1055+ , act
10561056 )
10571057 -- Error cases
1058− RemoteEndPointInvalid err ->
1058+ RemoteEndPointInvalid err ->
10591059 throwIO err
10601060 RemoteEndPointFailed err ->
10611061 throwIO err
@@ -1065,32 +1065,32 @@ createConnectionTo params ourEndPoint theirAddress hints = go
10651065 -- TODO: deal with exception case?
10661066 connId <- runScheduledAction (ourEndPoint, theirEndPoint) act
10671067 return (theirEndPoint, connId)
1068−
1068+
10691069
10701070 connectFailed :: IOException -> TransportError ConnectErrorCode
10711071 connectFailed = TransportError ConnectFailed . show
10721072
10731073 absorbAllExceptions :: SomeException -> IO ()
1074− absorbAllExceptions _ex =
1074+ absorbAllExceptions _ex =
10751075 return ()
10761076
10771077-- | Set up a remote endpoint
1078−setupRemoteEndPoint :: TCPParameters -> EndPointPair -> ConnectHints -> IO ()
1078+setupRemoteEndPoint :: TCPParameters -> EndPointPair -> ConnectHints -> IO ()
10791079setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints = do
1080− result <- socketToEndPoint ourAddress
1081− theirAddress
1080+ result <- socketToEndPoint ourAddress
1081+ theirAddress
10821082 (tcpReuseClientAddr params)
10831083 (connectTimeout hints)
10841084 didAccept <- case result of
1085− Right (sock, ConnectionRequestAccepted) -> do
1086− sendLock <- newMVar ()
1087− let vst = ValidRemoteEndPointState
1085+ Right (sock, ConnectionRequestAccepted) -> do
1086+ sendLock <- newMVar ()
1087+ let vst = ValidRemoteEndPointState
10881088 { remoteSocket = sock
10891089 , remoteSendLock = sendLock
1090− , _remoteOutgoing = 0
1090+ , _remoteOutgoing = 0
10911091 , _remoteIncoming = Set.empty
10921092 , _remoteMaxIncoming = 0
1093− , _remoteNextConnOutId = firstNonReservedLightweightConnectionId
1093+ , _remoteNextConnOutId = firstNonReservedLightweightConnectionId
10941094 }
10951095 resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointValid vst)
10961096 return True
@@ -1101,7 +1101,7 @@ setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints = do
11011101 return False
11021102 Right (sock, ConnectionRequestCrossed) -> do
11031103 withMVar (remoteState theirEndPoint) $ \st -> case st of
1104− RemoteEndPointInit _ crossed _ ->
1104+ RemoteEndPointInit _ crossed _ ->
11051105 putMVar crossed ()
11061106 RemoteEndPointFailed ex ->
11071107 throwIO ex
@@ -1109,11 +1109,11 @@ setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints = do
11091109 relyViolation (ourEndPoint, theirEndPoint) "setupRemoteEndPoint: Crossed"
11101110 tryCloseSocket sock
11111111 return False
1112− Left err -> do
1112+ Left err -> do
11131113 resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointInvalid err)
11141114 return False
11151115
1116− when didAccept $ handleIncomingMessages (ourEndPoint, theirEndPoint)
1116+ when didAccept $ handleIncomingMessages (ourEndPoint, theirEndPoint)
11171117 where
11181118 ourAddress = localAddress ourEndPoint
11191119 theirAddress = remoteAddress theirEndPoint
@@ -1121,23 +1121,23 @@ setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints = do
11211121
11221122-- | Send a CloseSocket request if the remote endpoint is unused
11231123closeIfUnused :: EndPointPair -> IO ()
1124−closeIfUnused (ourEndPoint, theirEndPoint) = do
1124+closeIfUnused (ourEndPoint, theirEndPoint) = do
11251125 mAct <- modifyMVar (remoteState theirEndPoint) $ \st -> case st of
11261126 RemoteEndPointValid vst ->
1127− if vst ^. remoteOutgoing == 0 && Set.null (vst ^. remoteIncoming)
1128− then do
1127+ if vst ^. remoteOutgoing == 0 && Set.null (vst ^. remoteIncoming)
1128+ then do
11291129 resolved <- newEmptyMVar
1130− act <- schedule theirEndPoint $
1130+ act <- schedule theirEndPoint $
11311131 sendOn vst [ encodeInt32 CloseSocket
11321132 , encodeInt32 (vst ^. remoteMaxIncoming)
11331133 ]
11341134 return (RemoteEndPointClosing resolved vst, Just act)
1135− else
1135+ else
11361136 return (RemoteEndPointValid vst, Nothing)
11371137 _ ->
11381138 return (st, Nothing)
1139− forM_ mAct $ runScheduledAction (ourEndPoint, theirEndPoint)
1140−
1139+ forM_ mAct $ runScheduledAction (ourEndPoint, theirEndPoint)
1140+
11411141-- | Reset a remote endpoint if it is in Invalid mode
11421142--
11431143-- If the remote endpoint is currently in broken state, and
@@ -1156,7 +1156,7 @@ resetIfBroken ourEndPoint theirAddress = do
11561156 return (vst ^. localConnectionTo theirAddress)
11571157 LocalEndPointClosed ->
11581158 throwIO $ TransportError ConnectFailed "Endpoint closed"
1159− forM_ mTheirEndPoint $ \theirEndPoint ->
1159+ forM_ mTheirEndPoint $ \theirEndPoint ->
11601160 withMVar (remoteState theirEndPoint) $ \st -> case st of
11611161 RemoteEndPointInvalid _ ->
11621162 removeRemoteEndPoint (ourEndPoint, theirEndPoint)
@@ -1166,26 +1166,26 @@ resetIfBroken ourEndPoint theirAddress = do
11661166 return ()
11671167
11681168-- | Special case of 'apiConnect': connect an endpoint to itself
1169−--
1169+--
11701170-- May throw a TransportError ConnectErrorCode (if the local endpoint is closed)
1171−connectToSelf :: LocalEndPoint
1171+connectToSelf :: LocalEndPoint
11721172 -> IO Connection
1173−connectToSelf ourEndPoint = do
1173+connectToSelf ourEndPoint = do
11741174 connAlive <- newIORef True -- Protected by the local endpoint lock
1175− lconnId <- mapIOException connectFailed $ getLocalNextConnOutId ourEndPoint
1175+ lconnId <- mapIOException connectFailed $ getLocalNextConnOutId ourEndPoint
11761176 let connId = createConnectionId heavyweightSelfConnectionId lconnId
11771177 writeChan ourChan $
11781178 ConnectionOpened connId ReliableOrdered (localAddress ourEndPoint)
1179− return Connection
1180− { send = selfSend connAlive connId
1179+ return Connection
1180+ { send = selfSend connAlive connId
11811181 , close = selfClose connAlive connId
11821182 }
11831183 where
1184− selfSend :: IORef Bool
1185− -> ConnectionId
1186− -> [ByteString]
1184+ selfSend :: IORef Bool
1185+ -> ConnectionId
1186+ -> [ByteString]
11871187 -> IO (Either (TransportError SendErrorCode) ())
1188− selfSend connAlive connId msg =
1188+ selfSend connAlive connId msg =
11891189 try . withMVar ourState $ \st -> case st of
11901190 LocalEndPointValid _ -> do
11911191 alive <- readIORef connAlive
@@ -1196,19 +1196,19 @@ connectToSelf ourEndPoint = do
11961196 throwIO $ TransportError SendFailed "Endpoint closed"
11971197
11981198 selfClose :: IORef Bool -> ConnectionId -> IO ()
1199− selfClose connAlive connId =
1199+ selfClose connAlive connId =
12001200 withMVar ourState $ \st -> case st of
12011201 LocalEndPointValid _ -> do
12021202 alive <- readIORef connAlive
12031203 when alive $ do
1204− writeChan ourChan (ConnectionClosed connId)
1204+ writeChan ourChan (ConnectionClosed connId)
12051205 writeIORef connAlive False
12061206 LocalEndPointClosed ->
1207− return ()
1207+ return ()
12081208
12091209 ourChan = localChannel ourEndPoint
12101210 ourState = localState ourEndPoint
1211− connectFailed = TransportError ConnectFailed . show
1211+ connectFailed = TransportError ConnectFailed . show
12121212
12131213-- | Resolve an endpoint currently in 'Init' state
12141214resolveInit :: EndPointPair -> RemoteState -> IO ()
@@ -1216,57 +1216,57 @@ resolveInit (ourEndPoint, theirEndPoint) newState =
12161216 modifyMVar_ (remoteState theirEndPoint) $ \st -> case st of
12171217 RemoteEndPointInit resolved _ _ -> do
12181218 putMVar resolved ()
1219− case newState of
1220− RemoteEndPointClosed ->
1219+ case newState of
1220+ RemoteEndPointClosed ->
12211221 removeRemoteEndPoint (ourEndPoint, theirEndPoint)
12221222 _ ->
12231223 return ()
12241224 return newState
1225− RemoteEndPointFailed ex ->
1225+ RemoteEndPointFailed ex ->
12261226 throwIO ex
12271227 _ ->
12281228 relyViolation (ourEndPoint, theirEndPoint) "resolveInit"
12291229
12301230-- | Get the next outgoing self-connection ID
1231−--
1231+--
12321232-- Throws an IO exception when the endpoint is closed.
12331233getLocalNextConnOutId :: LocalEndPoint -> IO LightweightConnectionId
1234−getLocalNextConnOutId ourEndpoint =
1234+getLocalNextConnOutId ourEndpoint =
12351235 modifyMVar (localState ourEndpoint) $ \st -> case st of
12361236 LocalEndPointValid vst -> do
1237− let connId = vst ^. localNextConnOutId
1238− return ( LocalEndPointValid
1239− . (localNextConnOutId ^= connId + 1)
1237+ let connId = vst ^. localNextConnOutId
1238+ return ( LocalEndPointValid
1239+ . (localNextConnOutId ^= connId + 1)
12401240 $ vst
12411241 , connId)
12421242 LocalEndPointClosed ->
12431243 throwIO $ userError "Local endpoint closed"
12441244
12451245-- | Create a new local endpoint
1246−--
1246+--
12471247-- May throw a TransportError NewEndPointErrorCode exception if the transport
12481248-- is closed.
12491249createLocalEndPoint :: TCPTransport -> IO LocalEndPoint
1250−createLocalEndPoint transport = do
1250+createLocalEndPoint transport = do
12511251 chan <- newChan
1252− state <- newMVar . LocalEndPointValid $ ValidLocalEndPointState
1252+ state <- newMVar . LocalEndPointValid $ ValidLocalEndPointState
12531253 { _localNextConnOutId = firstNonReservedLightweightConnectionId
12541254 , _localConnections = Map.empty
1255− , _nextConnInId = firstNonReservedHeavyweightConnectionId
1255+ , _nextConnInId = firstNonReservedHeavyweightConnectionId
12561256 }
12571257 modifyMVar (transportState transport) $ \st -> case st of
12581258 TransportValid vst -> do
12591259 let ix = vst ^. nextEndPointId
1260− let addr = encodeEndPointAddress (transportHost transport)
1260+ let addr = encodeEndPointAddress (transportHost transport)
12611261 (transportPort transport)
1262− ix
1262+ ix
12631263 let localEndPoint = LocalEndPoint { localAddress = addr
12641264 , localChannel = chan
12651265 , localState = state
12661266 }
1267− return ( TransportValid
1268− . (localEndPointAt addr ^= Just localEndPoint)
1269− . (nextEndPointId ^= ix + 1)
1267+ return ( TransportValid
1268+ . (localEndPointAt addr ^= Just localEndPoint)
1269+ . (nextEndPointId ^= ix + 1)
12701270 $ vst
12711271 , localEndPoint
12721272 )
@@ -1282,13 +1282,13 @@ removeRemoteEndPoint (ourEndPoint, theirEndPoint) =
12821282 modifyMVar_ ourState $ \st -> case st of
12831283 LocalEndPointValid vst ->
12841284 case vst ^. localConnectionTo theirAddress of
1285− Nothing ->
1285+ Nothing ->
12861286 return st
12871287 Just remoteEndPoint' ->
1288− if remoteId remoteEndPoint' == remoteId theirEndPoint
1289− then return
1290− ( LocalEndPointValid
1291− . (localConnectionTo (remoteAddress theirEndPoint) ^= Nothing)
1288+ if remoteId remoteEndPoint' == remoteId theirEndPoint
1289+ then return
1290+ ( LocalEndPointValid
1291+ . (localConnectionTo (remoteAddress theirEndPoint) ^= Nothing)
12921292 $ vst
12931293 )
12941294 else return st
@@ -1302,23 +1302,23 @@ removeRemoteEndPoint (ourEndPoint, theirEndPoint) =
13021302--
13031303-- Does nothing if the transport is closed
13041304removeLocalEndPoint :: TCPTransport -> LocalEndPoint -> IO ()
1305−removeLocalEndPoint transport ourEndPoint =
1306− modifyMVar_ (transportState transport) $ \st -> case st of
1305+removeLocalEndPoint transport ourEndPoint =
1306+ modifyMVar_ (transportState transport) $ \st -> case st of
13071307 TransportValid vst ->
1308− return ( TransportValid
1309− . (localEndPointAt (localAddress ourEndPoint) ^= Nothing)
1308+ return ( TransportValid
1309+ . (localEndPointAt (localAddress ourEndPoint) ^= Nothing)
13101310 $ vst
13111311 )
13121312 TransportClosed ->
13131313 return TransportClosed
13141314
13151315-- | Find a remote endpoint. If the remote endpoint does not yet exist we
1316−-- create it in Init state. Returns if the endpoint was new.
1317−findRemoteEndPoint
1316+-- create it in Init state. Returns if the endpoint was new.
1317+findRemoteEndPoint
13181318 :: LocalEndPoint
13191319 -> EndPointAddress
1320− -> RequestedBy
1321− -> IO (RemoteEndPoint, Bool)
1320+ -> RequestedBy
1321+ -> IO (RemoteEndPoint, Bool)
13221322findRemoteEndPoint ourEndPoint theirAddress findOrigin = go
13231323 where
13241324 go = do
@@ -1335,55 +1335,55 @@ findRemoteEndPoint ourEndPoint theirAddress findOrigin = go
13351335 { remoteAddress = theirAddress
13361336 , remoteState = theirState
13371337 , remoteId = vst ^. nextConnInId
1338− , remoteScheduled = scheduled
1338+ , remoteScheduled = scheduled
13391339 }
1340− return ( LocalEndPointValid
1341− . (localConnectionTo theirAddress ^= Just theirEndPoint)
1342− . (nextConnInId ^: (+ 1))
1340+ return ( LocalEndPointValid
1341+ . (localConnectionTo theirAddress ^= Just theirEndPoint)
1342+ . (nextConnInId ^: (+ 1))
13431343 $ vst
1344− , (theirEndPoint, True)
1344+ , (theirEndPoint, True)
13451345 )
13461346 LocalEndPointClosed ->
13471347 throwIO $ userError "Local endpoint closed"
1348−
1349− if isNew
1348+
1349+ if isNew
13501350 then
13511351 return (theirEndPoint, True)
13521352 else do
13531353 let theirState = remoteState theirEndPoint
13541354 snapshot <- modifyMVar theirState $ \st -> case st of
1355− RemoteEndPointValid vst ->
1355+ RemoteEndPointValid vst ->
13561356 case findOrigin of
13571357 RequestedByUs -> do
1358− let st' = RemoteEndPointValid
1359− . (remoteOutgoing ^: (+ 1))
1360− $ vst
1358+ let st' = RemoteEndPointValid
1359+ . (remoteOutgoing ^: (+ 1))
1360+ $ vst
13611361 return (st', st')
13621362 RequestedByThem ->
1363− return (st, st)
1363+ return (st, st)
13641364 _ ->
13651365 return (st, st)
13661366 -- The snapshot may no longer be up to date at this point, but if we
1367− -- increased the refcount then it can only either be Valid or Failed
1368− -- (after an explicit call to 'closeEndPoint' or 'closeTransport')
1367+ -- increased the refcount then it can only either be Valid or Failed
1368+ -- (after an explicit call to 'closeEndPoint' or 'closeTransport')
13691369 case snapshot of
13701370 RemoteEndPointInvalid err ->
13711371 throwIO err
13721372 RemoteEndPointInit resolved crossed initOrigin ->
13731373 case (findOrigin, initOrigin) of
1374− (RequestedByUs, RequestedByUs) ->
1375− readMVar resolved >> go
1376− (RequestedByUs, RequestedByThem) ->
1374+ (RequestedByUs, RequestedByUs) ->
13771375 readMVar resolved >> go
1378− (RequestedByThem, RequestedByUs) ->
1379− if ourAddress > theirAddress
1376+ (RequestedByUs, RequestedByThem) ->
1377+ readMVar resolved >> go
1378+ (RequestedByThem, RequestedByUs) ->
1379+ if ourAddress > theirAddress
13801380 then do
13811381 -- Wait for the Crossed message
1382− readMVar crossed
1382+ readMVar crossed
13831383 return (theirEndPoint, True)
13841384 else
13851385 return (theirEndPoint, False)
1386− (RequestedByThem, RequestedByThem) ->
1386+ (RequestedByThem, RequestedByThem) ->
13871387 throwIO $ userError "Already connected"
13881388 RemoteEndPointValid _ ->
13891389 -- We assume that the request crossed if we find the endpoint in
@@ -1395,15 +1395,15 @@ findRemoteEndPoint ourEndPoint theirAddress findOrigin = go
13951395 readMVar resolved >> go
13961396 RemoteEndPointClosed ->
13971397 go
1398− RemoteEndPointFailed err ->
1398+ RemoteEndPointFailed err ->
13991399 throwIO err
1400−
1401− ourState = localState ourEndPoint
1400+
1401+ ourState = localState ourEndPoint
14021402 ourAddress = localAddress ourEndPoint
14031403
14041404-- | Send a payload over a heavyweight connection (thread safe)
1405−sendOn :: ValidRemoteEndPointState -> [ByteString] -> IO ()
1406−sendOn vst bs = withMVar (remoteSendLock vst) $ \() ->
1405+sendOn :: ValidRemoteEndPointState -> [ByteString] -> IO ()
1406+sendOn vst bs = withMVar (remoteSendLock vst) $ \() ->
14071407 sendMany (remoteSocket vst) bs
14081408
14091409--------------------------------------------------------------------------------
@@ -1417,7 +1417,7 @@ type Action a = MVar (Either SomeException a)
14171417schedule :: RemoteEndPoint -> IO a -> IO (Action a)
14181418schedule theirEndPoint act = do
14191419 mvar <- newEmptyMVar
1420− writeChan (remoteScheduled theirEndPoint) $
1420+ writeChan (remoteScheduled theirEndPoint) $
14211421 catch (act >>= putMVar mvar . Right) (putMVar mvar . Left)
14221422 return mvar
14231423
@@ -1429,7 +1429,7 @@ schedule theirEndPoint act = do
14291429-- > runScheduledAction
14301430--
14311431-- 'runScheduledAction' will run @p@ (it might run some other scheduled action).
1432−-- However, it will then wait until @p@ is executed (by this call to
1432+-- However, it will then wait until @p@ is executed (by this call to
14331433-- 'runScheduledAction' or by another).
14341434runScheduledAction :: EndPointPair -> Action a -> IO a
14351435runScheduledAction (ourEndPoint, theirEndPoint) mvar = do
@@ -1438,21 +1438,21 @@ runScheduledAction (ourEndPoint, theirEndPoint) mvar = do
14381438 case ma of
14391439 Right a -> return a
14401440 Left e -> do
1441− forM_ (fromException e) $ \ioe ->
1441+ forM_ (fromException e) $ \ioe ->
14421442 modifyMVar_ (remoteState theirEndPoint) $ \st ->
1443− case st of
1443+ case st of
14441444 RemoteEndPointValid vst -> handleIOException ioe vst
14451445 _ -> return (RemoteEndPointFailed ioe)
14461446 throwIO e
14471447 where
1448− handleIOException :: IOException
1449− -> ValidRemoteEndPointState
1450− -> IO RemoteState
1448+ handleIOException :: IOException
1449+ -> ValidRemoteEndPointState
1450+ -> IO RemoteState
14511451 handleIOException ex vst = do
14521452 tryCloseSocket (remoteSocket vst)
1453− let code = EventConnectionLost (remoteAddress theirEndPoint)
1453+ let code = EventConnectionLost (remoteAddress theirEndPoint)
14541454 err = TransportError code (show ex)
1455− writeChan (localChannel ourEndPoint) $ ErrorEvent err
1455+ writeChan (localChannel ourEndPoint) $ ErrorEvent err
14561456 return (RemoteEndPointFailed ex)
14571457
14581458--------------------------------------------------------------------------------
@@ -1462,25 +1462,25 @@ runScheduledAction (ourEndPoint, theirEndPoint) mvar = do
14621462-- | Establish a connection to a remote endpoint
14631463--
14641464-- Maybe throw a TransportError
1465−socketToEndPoint :: EndPointAddress -- ^ Our address
1465+socketToEndPoint :: EndPointAddress -- ^ Our address
14661466 -> EndPointAddress -- ^ Their address
14671467 -> Bool -- ^ Use SO_REUSEADDR?
1468− -> Maybe Int -- ^ Timeout for connect
1469− -> IO (Either (TransportError ConnectErrorCode)
1470− (N.Socket, ConnectionRequestResponse))
1471−socketToEndPoint (EndPointAddress ourAddress) theirAddress reuseAddr timeout =
1472− try $ do
1473− (host, port, theirEndPointId) <- case decodeEndPointAddress theirAddress of
1468+ -> Maybe Int -- ^ Timeout for connect
1469+ -> IO (Either (TransportError ConnectErrorCode)
1470+ (N.Socket, ConnectionRequestResponse))
1471+socketToEndPoint (EndPointAddress ourAddress) theirAddress reuseAddr timeout =
1472+ try $ do
1473+ (host, port, theirEndPointId) <- case decodeEndPointAddress theirAddress of
14741474 Nothing -> throwIO (failed . userError $ "Could not parse")
14751475 Just dec -> return dec
1476− addr:_ <- mapIOException invalidAddress $
1476+ addr:_ <- mapIOException invalidAddress $
14771477 N.getAddrInfo Nothing (Just host) (Just port)
14781478 bracketOnError (createSocket addr) tryCloseSocket $ \sock -> do
1479− when reuseAddr $
1479+ when reuseAddr $
14801480 mapIOException failed $ N.setSocketOption sock N.ReuseAddr 1
1481− mapIOException invalidAddress $
1482− timeoutMaybe timeout timeoutError $
1483− N.connect sock (N.addrAddress addr)
1481+ mapIOException invalidAddress $
1482+ timeoutMaybe timeout timeoutError $
1483+ N.connect sock (N.addrAddress addr)
14841484 response <- mapIOException failed $ do
14851485 sendMany sock (encodeInt32 theirEndPointId : prependLength [ourAddress])
14861486 recvInt32 sock
@@ -1489,50 +1489,50 @@ socketToEndPoint (EndPointAddress ourAddress) theirAddress reuseAddr timeout =
14891489 Just r -> return (sock, r)
14901490 where
14911491 createSocket :: N.AddrInfo -> IO N.Socket
1492− createSocket addr = mapIOException insufficientResources $
1492+ createSocket addr = mapIOException insufficientResources $
14931493 N.socket (N.addrFamily addr) N.Stream N.defaultProtocol
14941494
1495− invalidAddress = TransportError ConnectNotFound . show
1496− insufficientResources = TransportError ConnectInsufficientResources . show
1495+ invalidAddress = TransportError ConnectNotFound . show
1496+ insufficientResources = TransportError ConnectInsufficientResources . show
14971497 failed = TransportError ConnectFailed . show
14981498 timeoutError = TransportError ConnectTimeout "Timed out"
14991499
15001500-- | Encode end point address
1501−encodeEndPointAddress :: N.HostName
1502− -> N.ServiceName
1503− -> EndPointId
1501+encodeEndPointAddress :: N.HostName
1502+ -> N.ServiceName
1503+ -> EndPointId
15041504 -> EndPointAddress
15051505encodeEndPointAddress host port ix = EndPointAddress . BSC.pack $
1506− host ++ ":" ++ port ++ ":" ++ show ix
1506+ host ++ ":" ++ port ++ ":" ++ show ix
15071507
15081508-- | Decode end point address
1509−decodeEndPointAddress :: EndPointAddress
1509+decodeEndPointAddress :: EndPointAddress
15101510 -> Maybe (N.HostName, N.ServiceName, EndPointId)
1511−decodeEndPointAddress (EndPointAddress bs) =
1511+decodeEndPointAddress (EndPointAddress bs) =
15121512 case splitMaxFromEnd (== ':') 2 $ BSC.unpack bs of
1513− [host, port, endPointIdStr] ->
1514− case reads endPointIdStr of
1513+ [host, port, endPointIdStr] ->
1514+ case reads endPointIdStr of
15151515 [(endPointId, "")] -> Just (host, port, endPointId)
15161516 _ -> Nothing
15171517 _ ->
15181518 Nothing
15191519
15201520-- | Construct a ConnectionId
1521−createConnectionId :: HeavyweightConnectionId
1522− -> LightweightConnectionId
1521+createConnectionId :: HeavyweightConnectionId
1522+ -> LightweightConnectionId
15231523 -> ConnectionId
1524−createConnectionId hcid lcid =
1524+createConnectionId hcid lcid =
15251525 (fromIntegral hcid `shiftL` 32) .|. fromIntegral lcid
15261526
15271527-- | @spltiMaxFromEnd p n xs@ splits list @xs@ at elements matching @p@,
15281528-- returning at most @p@ segments -- counting from the /end/
1529−--
1529+--
15301530-- > splitMaxFromEnd (== ':') 2 "ab:cd:ef:gh" == ["ab:cd", "ef", "gh"]
15311531splitMaxFromEnd :: (a -> Bool) -> Int -> [a] -> [[a]]
1532−splitMaxFromEnd p = \n -> go [[]] n . reverse
1532+splitMaxFromEnd p = \n -> go [[]] n . reverse
15331533 where
15341534 -- go :: [[a]] -> Int -> [a] -> [[a]]
1535− go accs _ [] = accs
1535+ go accs _ [] = accs
15361536 go ([] : accs) 0 xs = reverse xs : accs
15371537 go (acc : accs) n (x:xs) =
15381538 if p x then go ([] : acc : accs) (n - 1) xs
@@ -1544,40 +1544,40 @@ splitMaxFromEnd p = \n -> go [[]] n . reverse
15441544--------------------------------------------------------------------------------
15451545
15461546-- Find a socket between two endpoints
1547−--
1547+--
15481548-- Throws an IO exception if the socket could not be found.
1549−internalSocketBetween :: TCPTransport -- ^ Transport
1549+internalSocketBetween :: TCPTransport -- ^ Transport
15501550 -> EndPointAddress -- ^ Local endpoint
15511551 -> EndPointAddress -- ^ Remote endpoint
1552− -> IO N.Socket
1552+ -> IO N.Socket
15531553internalSocketBetween transport ourAddress theirAddress = do
15541554 ourEndPoint <- withMVar (transportState transport) $ \st -> case st of
1555− TransportClosed ->
1556− throwIO $ userError "Transport closed"
1557− TransportValid vst ->
1555+ TransportClosed ->
1556+ throwIO $ userError "Transport closed"
1557+ TransportValid vst ->
15581558 case vst ^. localEndPointAt ourAddress of
15591559 Nothing -> throwIO $ userError "Local endpoint not found"
15601560 Just ep -> return ep
15611561 theirEndPoint <- withMVar (localState ourEndPoint) $ \st -> case st of
15621562 LocalEndPointClosed ->
15631563 throwIO $ userError "Local endpoint closed"
1564− LocalEndPointValid vst ->
1564+ LocalEndPointValid vst ->
15651565 case vst ^. localConnectionTo theirAddress of
15661566 Nothing -> throwIO $ userError "Remote endpoint not found"
15671567 Just ep -> return ep
15681568 withMVar (remoteState theirEndPoint) $ \st -> case st of
15691569 RemoteEndPointInit _ _ _ ->
15701570 throwIO $ userError "Remote endpoint not yet initialized"
1571− RemoteEndPointValid vst ->
1571+ RemoteEndPointValid vst ->
15721572 return $ remoteSocket vst
15731573 RemoteEndPointClosing _ vst ->
1574− return $ remoteSocket vst
1574+ return $ remoteSocket vst
15751575 RemoteEndPointClosed ->
15761576 throwIO $ userError "Remote endpoint closed"
15771577 RemoteEndPointInvalid err ->
1578− throwIO err
1578+ throwIO err
15791579 RemoteEndPointFailed err ->
1580− throwIO err
1580+ throwIO err
15811581
15821582--------------------------------------------------------------------------------
15831583-- Constants --
@@ -1611,7 +1611,7 @@ localNextConnOutId = accessor _localNextConnOutId (\cix st -> st { _localNextCon
16111611localConnections :: Accessor ValidLocalEndPointState (Map EndPointAddress RemoteEndPoint)
16121612localConnections = accessor _localConnections (\es st -> st { _localConnections = es })
16131613
1614−nextConnInId :: Accessor ValidLocalEndPointState HeavyweightConnectionId
1614+nextConnInId :: Accessor ValidLocalEndPointState HeavyweightConnectionId
16151615nextConnInId = accessor _nextConnInId (\rid st -> st { _nextConnInId = rid })
16161616
16171617remoteOutgoing :: Accessor ValidRemoteEndPointState Int
@@ -1627,10 +1627,10 @@ remoteNextConnOutId :: Accessor ValidRemoteEndPointState LightweightConnectionId
16271627remoteNextConnOutId = accessor _remoteNextConnOutId (\cix st -> st { _remoteNextConnOutId = cix })
16281628
16291629localEndPointAt :: EndPointAddress -> Accessor ValidTransportState (Maybe LocalEndPoint)
1630−localEndPointAt addr = localEndPoints >>> DAC.mapMaybe addr
1630+localEndPointAt addr = localEndPoints >>> DAC.mapMaybe addr
16311631
16321632localConnectionTo :: EndPointAddress -> Accessor ValidLocalEndPointState (Maybe RemoteEndPoint)
1633−localConnectionTo addr = localConnections >>> DAC.mapMaybe addr
1633+localConnectionTo addr = localConnections >>> DAC.mapMaybe addr
16341634
16351635-------------------------------------------------------------------------------
16361636-- Debugging --
@@ -1638,14 +1638,14 @@ localConnectionTo addr = localConnections >>> DAC.mapMaybe addr
16381638
16391639relyViolation :: EndPointPair -> String -> IO a
16401640relyViolation (ourEndPoint, theirEndPoint) str = do
1641− elog (ourEndPoint, theirEndPoint) (str ++ " RELY violation")
1641+ elog (ourEndPoint, theirEndPoint) (str ++ " RELY violation")
16421642 fail (str ++ " RELY violation")
16431643
16441644elog :: EndPointPair -> String -> IO ()
16451645elog (ourEndPoint, theirEndPoint) msg = do
16461646 tid <- myThreadId
1647− putStrLn $ show (localAddress ourEndPoint)
1648− ++ "/" ++ show (remoteAddress theirEndPoint)
1647+ putStrLn $ show (localAddress ourEndPoint)
1648+ ++ "/" ++ show (remoteAddress theirEndPoint)
16491649 ++ "(" ++ show (remoteId theirEndPoint) ++ ")"
1650− ++ "/" ++ show tid
1650+ ++ "/" ++ show tid
16511651 ++ ": " ++ msg
network-transport-tcp/src/Network/Transport/TCP/Internal.hs+22−22
@@ -1,8 +1,8 @@
1−-- | Utility functions for TCP sockets
2−module Network.Transport.TCP.Internal
1+-- | Utility functions for TCP sockets
2+module Network.Transport.TCP.Internal
33 ( forkServer
44 , recvWithLength
5− , recvExact
5+ , recvExact
66 , recvInt32
77 , tryCloseSocket
88 ) where
@@ -16,7 +16,7 @@ import Network.Transport.Internal (decodeInt32, void, tryIO, forkIOWithUnmask)
1616#ifdef USE_MOCK_NETWORK
1717import qualified Network.Transport.TCP.Mock.Socket as N
1818#else
19−import qualified Network.Socket as N
19+import qualified Network.Socket as N
2020#endif
2121 ( HostName
2222 , ServiceName
@@ -49,10 +49,10 @@ import Control.Applicative ((<$>))
4949import Data.ByteString (ByteString)
5050import qualified Data.ByteString as BS (length, concat, null)
5151import Data.Int (Int32)
52−import Data.ByteString.Lazy.Internal (smallChunkSize)
52+import Data.ByteString.Lazy.Internal (smallChunkSize)
5353
5454-- | Start a server at the specified address.
55−--
55+--
5656-- This sets up a server socket for the specified host and port. Exceptions
5757-- thrown during setup are not caught.
5858--
@@ -67,15 +67,15 @@ import Data.ByteString.Lazy.Internal (smallChunkSize)
6767-- The request handler should spawn threads to handle each individual request
6868-- or the server will block. Once a thread has been spawned it will be the
6969-- responsibility of the new thread to close the socket when an exception
70−-- occurs.
70+-- occurs.
7171forkServer :: N.HostName -- ^ Host
72− -> N.ServiceName -- ^ Port
72+ -> N.ServiceName -- ^ Port
7373 -> Int -- ^ Backlog (maximum number of queued connections)
7474 -> Bool -- ^ Set ReuseAddr option?
7575 -> (SomeException -> IO ()) -- ^ Termination handler
76− -> (N.Socket -> IO ()) -- ^ Request handler
76+ -> (N.Socket -> IO ()) -- ^ Request handler
7777 -> IO ThreadId
78−forkServer host port backlog reuseAddr terminationHandler requestHandler = do
78+forkServer host port backlog reuseAddr terminationHandler requestHandler = do
7979 -- Resolve the specified address. By specification, getAddrInfo will never
8080 -- return an empty list (but will throw an exception instead) and will return
8181 -- the "best" address first, whatever that means
@@ -84,14 +84,14 @@ forkServer host port backlog reuseAddr terminationHandler requestHandler = do
8484 tryCloseSocket $ \sock -> do
8585 when reuseAddr $ N.setSocketOption sock N.ReuseAddr 1
8686 N.bindSocket sock (N.addrAddress addr)
87− N.listen sock backlog
87+ N.listen sock backlog
8888 -- We start listening for incoming requests in a separate thread. When
8989 -- that thread is killed, we close the server socket and the termination
9090 -- handler. We have to make sure that the exception handler is installed
9191 -- /before/ any asynchronous exception occurs. So we mask_, then fork
9292 -- (the child thread inherits the masked state from the parent), then
9393 -- unmask only inside the catch.
94− mask_ $ forkIOWithUnmask $ \unmask ->
94+ mask_ $ forkIOWithUnmask $ \unmask ->
9595 catch (unmask (forever $ acceptRequest sock)) $ \ex -> do
9696 tryCloseSocket sock
9797 terminationHandler ex
@@ -100,34 +100,34 @@ forkServer host port backlog reuseAddr terminationHandler requestHandler = do
100100 acceptRequest sock = bracketOnError (N.accept sock)
101101 (tryCloseSocket . fst)
102102 (requestHandler . fst)
103−
103+
104104-- | Read a length and then a payload of that length
105105recvWithLength :: N.Socket -> IO [ByteString]
106106recvWithLength sock = recvInt32 sock >>= recvExact sock
107107
108108-- | Receive a 32-bit integer
109−recvInt32 :: Num a => N.Socket -> IO a
110−recvInt32 sock = decodeInt32 . BS.concat <$> recvExact sock 4
109+recvInt32 :: Num a => N.Socket -> IO a
110+recvInt32 sock = decodeInt32 . BS.concat <$> recvExact sock 4
111111
112112-- | Close a socket, ignoring I/O exceptions
113113tryCloseSocket :: N.Socket -> IO ()
114−tryCloseSocket sock = void . tryIO $
114+tryCloseSocket sock = void . tryIO $
115115 N.sClose sock
116116
117117-- | Read an exact number of bytes from a socket
118−--
118+--
119119-- Throws an I/O exception if the socket closes before the specified
120120-- number of bytes could be read
121−recvExact :: N.Socket -- ^ Socket to read from
121+recvExact :: N.Socket -- ^ Socket to read from
122122 -> Int32 -- ^ Number of bytes to read
123123 -> IO [ByteString]
124−recvExact _ len | len < 0 = throwIO (userError "recvExact: Negative length")
124+recvExact _ len | len < 0 = throwIO (userError "recvExact: Negative length")
125125recvExact sock len = go [] len
126126 where
127− go :: [ByteString] -> Int32 -> IO [ByteString]
128− go acc 0 = return (reverse acc)
127+ go :: [ByteString] -> Int32 -> IO [ByteString]
128+ go acc 0 = return (reverse acc)
129129 go acc l = do
130130 bs <- NBS.recv sock (fromIntegral l `min` smallChunkSize)
131− if BS.null bs
131+ if BS.null bs
132132 then throwIO (userError "recvExact: Socket closed")
133133 else go (bs : acc) (l - fromIntegral (BS.length bs))
network-transport-tcp/src/Network/Transport/TCP/Mock/Socket.hs+47−47
@@ -38,7 +38,7 @@ import Data.Map (Map)
3838import qualified Data.Map as Map
3939import Control.Exception (throwIO)
4040import Control.Category ((>>>))
41−import Control.Concurrent.MVar
41+import Control.Concurrent.MVar
4242import Control.Concurrent.Chan
4343import System.IO.Unsafe (unsafePerformIO)
4444import Data.Accessor (Accessor, accessor, (^=), (^.), (^:))
@@ -70,7 +70,7 @@ get :: Accessor MockState a -> IO a
7070get acc = timeoutThrow mvarThreshold $ withMVar mockState $ return . (^. acc)
7171
7272set :: Accessor MockState a -> a -> IO ()
73−set acc val = timeoutThrow mvarThreshold $ modifyMVar_ mockState $ return . (acc ^= val)
73+set acc val = timeoutThrow mvarThreshold $ modifyMVar_ mockState $ return . (acc ^= val)
7474
7575boundSockets :: Accessor MockState (Map SockAddr Socket)
7676boundSockets = accessor _boundSockets (\bs st -> st { _boundSockets = bs })
@@ -90,34 +90,34 @@ validHostnames = accessor _validHostnames (\ns st -> st { _validHostnames = ns }
9090
9191type HostName = String
9292type ServiceName = String
93−type PortNumber = String
94−type HostAddress = String
93+type PortNumber = String
94+type HostAddress = String
9595
96−data SocketType = Stream
96+data SocketType = Stream
9797data SocketOption = ReuseAddr
9898data ShutdownCmd = ShutdownSend
9999
100100data Family
101101data ProtocolNumber
102102
103−data Socket = Socket {
103+data Socket = Socket {
104104 socketState :: MVar SocketState
105105 , socketDescription :: String
106106 }
107107
108−data SocketState =
108+data SocketState =
109109 Uninit
110− | BoundSocket {
111− socketBacklog :: Chan (Socket, SockAddr, MVar Socket)
110+ | BoundSocket {
111+ socketBacklog :: Chan (Socket, SockAddr, MVar Socket)
112112 }
113− | Connected {
114− socketBuff :: Chan Message
113+ | Connected {
114+ socketBuff :: Chan Message
115115 , _socketPeer :: Maybe Socket
116116 , _scheduledReadActions :: [(Int, IO ())]
117117 }
118118 | Closed
119119
120−data Message =
120+data Message =
121121 Payload Word8
122122 | CloseSocket
123123
@@ -145,43 +145,43 @@ getAddrInfo :: Maybe AddrInfo -> Maybe HostName -> Maybe ServiceName -> IO [Addr
145145getAddrInfo _ (Just host) (Just port) = do
146146 validHosts <- get validHostnames
147147 if host `elem` validHosts
148− then return . return $ AddrInfo {
149− addrFamily = error "Family unused"
150− , addrAddress = SockAddrInet port host
148+ then return . return $ AddrInfo {
149+ addrFamily = error "Family unused"
150+ , addrAddress = SockAddrInet port host
151151 }
152152 else throwSocketError $ "getAddrInfo: invalid hostname '" ++ host ++ "'"
153153getAddrInfo _ _ _ = error "getAddrInfo: unsupported arguments"
154154
155155defaultHints :: AddrInfo
156−defaultHints = error "defaultHints not implemented"
156+defaultHints = error "defaultHints not implemented"
157157
158158socket :: Family -> SocketType -> ProtocolNumber -> IO Socket
159159socket _ Stream _ = do
160160 state <- newMVar Uninit
161161 sid <- get nextSocketId
162162 set nextSocketId (sid + 1)
163− return Socket {
163+ return Socket {
164164 socketState = state
165165 , socketDescription = show sid
166166 }
167−
167+
168168bindSocket :: Socket -> SockAddr -> IO ()
169169bindSocket sock addr = do
170170 timeoutThrow mvarThreshold $ modifyMVar_ (socketState sock) $ \st -> case st of
171171 Uninit -> do
172172 backlog <- newChan
173− return BoundSocket {
174− socketBacklog = backlog
173+ return BoundSocket {
174+ socketBacklog = backlog
175175 }
176176 _ ->
177177 throwSocketError "bind: socket already initialized"
178178 set (boundSocketAt addr) (Just sock)
179−
179+
180180listen :: Socket -> Int -> IO ()
181−listen _ _ = return ()
181+listen _ _ = return ()
182182
183183defaultProtocol :: ProtocolNumber
184−defaultProtocol = error "defaultProtocol not implemented"
184+defaultProtocol = error "defaultProtocol not implemented"
185185
186186setSocketOption :: Socket -> SocketOption -> Int -> IO ()
187187setSocketOption _ ReuseAddr 1 = return ()
@@ -190,13 +190,13 @@ setSocketOption _ _ _ = error "setSocketOption: unsupported arguments"
190190accept :: Socket -> IO (Socket, SockAddr)
191191accept serverSock = do
192192 backlog <- timeoutThrow mvarThreshold $ withMVar (socketState serverSock) $ \st -> case st of
193− BoundSocket {} ->
193+ BoundSocket {} ->
194194 return (socketBacklog st)
195195 _ ->
196196 throwSocketError "accept: socket not bound"
197− (theirSocket, theirAddress, reply) <- readChan backlog
197+ (theirSocket, theirAddress, reply) <- readChan backlog
198198 ourBuff <- newChan
199− ourState <- newMVar Connected {
199+ ourState <- newMVar Connected {
200200 socketBuff = ourBuff
201201 , _socketPeer = Just theirSocket
202202 , _scheduledReadActions = []
@@ -205,13 +205,13 @@ accept serverSock = do
205205 socketState = ourState
206206 , socketDescription = ""
207207 }
208− timeoutThrow mvarThreshold $ putMVar reply ourSocket
208+ timeoutThrow mvarThreshold $ putMVar reply ourSocket
209209 return (ourSocket, theirAddress)
210210
211211sClose :: Socket -> IO ()
212212sClose sock = do
213213 -- Close the peer socket
214− writeSocket sock CloseSocket
214+ writeSocket sock CloseSocket
215215
216216 -- Close our socket
217217 timeoutThrow mvarThreshold $ modifyMVar_ (socketState sock) $ \st ->
@@ -220,7 +220,7 @@ sClose sock = do
220220 -- In case there is a parallel read stuck on a readChan
221221 writeChan (socketBuff st) CloseSocket
222222 return Closed
223− _ ->
223+ _ ->
224224 return Closed
225225
226226connect :: Socket -> SockAddr -> IO ()
@@ -235,13 +235,13 @@ connect us serverAddr = do
235235 throwSocketError "connect: server socket not bound"
236236 reply <- newEmptyMVar
237237 writeChan serverBacklog (us, SockAddrInet "" "", reply)
238− them <- timeoutThrow mvarThreshold $ readMVar reply
238+ them <- timeoutThrow mvarThreshold $ readMVar reply
239239 timeoutThrow mvarThreshold $ modifyMVar_ (socketState us) $ \st -> case st of
240− Uninit -> do
240+ Uninit -> do
241241 buff <- newChan
242− return Connected {
242+ return Connected {
243243 socketBuff = buff
244− , _socketPeer = Just them
244+ , _socketPeer = Just them
245245 , _scheduledReadActions = []
246246 }
247247 _ ->
@@ -249,7 +249,7 @@ connect us serverAddr = do
249249 Nothing -> throwSocketError "connect: unknown address"
250250
251251sOMAXCONN :: Int
252−sOMAXCONN = error "sOMAXCONN not implemented"
252+sOMAXCONN = error "sOMAXCONN not implemented"
253253
254254shutdown :: Socket -> ShutdownCmd -> IO ()
255255shutdown sock ShutdownSend = do
@@ -267,7 +267,7 @@ shutdown sock ShutdownSend = do
267267peerBuffer :: Socket -> IO (Either String (Chan Message))
268268peerBuffer sock = do
269269 mPeer <- timeoutThrow mvarThreshold $ withMVar (socketState sock) $ \st -> case st of
270− Connected {} ->
270+ Connected {} ->
271271 return (st ^. socketPeer)
272272 _ ->
273273 return Nothing
@@ -276,9 +276,9 @@ peerBuffer sock = do
276276 Connected {} ->
277277 return (Right (socketBuff st))
278278 _ ->
279− return (Left "Peer socket closed")
280− Nothing ->
281− return (Left "Socket closed")
279+ return (Left "Peer socket closed")
280+ Nothing ->
281+ return (Left "Socket closed")
282282
283283throwSocketError :: String -> IO a
284284throwSocketError = throwIO . userError
@@ -287,8 +287,8 @@ writeSocket :: Socket -> Message -> IO ()
287287writeSocket sock msg = do
288288 theirBuff <- peerBuffer sock
289289 case theirBuff of
290− Right buff -> writeChan buff msg
291− Left err -> case msg of Payload _ -> throwSocketError $ "writeSocket: " ++ err
290+ Right buff -> writeChan buff msg
291+ Left err -> case msg of Payload _ -> throwSocketError $ "writeSocket: " ++ err
292292 CloseSocket -> return ()
293293
294294readSocket :: Socket -> IO (Maybe Word8)
@@ -304,7 +304,7 @@ readSocket sock = do
304304 case mBuff of
305305 Just (buff, actions) -> do
306306 sequence actions
307− msg <- timeoutThrow readSocketThreshold $ readChan buff
307+ msg <- timeoutThrow readSocketThreshold $ readChan buff
308308 case msg of
309309 Payload w -> return (Just w)
310310 CloseSocket -> timeoutThrow mvarThreshold $ modifyMVar (socketState sock) $ \st -> case st of
@@ -312,7 +312,7 @@ readSocket sock = do
312312 return (Closed, Nothing)
313313 _ ->
314314 throwSocketError "readSocket: socket in unexpected state"
315− Nothing ->
315+ Nothing ->
316316 return Nothing
317317
318318-- | Given a list of scheduled actions, reduce all delays by 1, and return the
@@ -321,7 +321,7 @@ tick :: [(Int, IO ())] -> ([(Int, IO ())], [IO ()])
321321tick = go [] []
322322 where
323323 go later now [] = (reverse later, reverse now)
324− go later now ((n, action) : actions)
324+ go later now ((n, action) : actions)
325325 | n == 0 = go later (action : now) actions
326326 | otherwise = go ((n - 1, action) : later) now actions
327327
@@ -330,16 +330,16 @@ tick = go [] []
330330--------------------------------------------------------------------------------
331331
332332-- | Schedule an action to be executed after /n/ reads on this socket
333−--
333+--
334334-- If /n/ is zero we execute the action immediately.
335335scheduleReadAction :: Socket -> Int -> IO () -> IO ()
336336scheduleReadAction _ 0 action = action
337−scheduleReadAction sock n action =
338− modifyMVar_ (socketState sock) $ \st -> case st of
337+scheduleReadAction sock n action =
338+ modifyMVar_ (socketState sock) $ \st -> case st of
339339 Connected {} ->
340340 return (scheduledReadActions ^: ((n, action) :) $ st)
341341 _ ->
342− throwSocketError "scheduleReadAction: socket not connected"
342+ throwSocketError "scheduleReadAction: socket not connected"
343343
344344--------------------------------------------------------------------------------
345345-- Util --
network-transport-tcp/tests/TestQC.hs+120−120
@@ -1,10 +1,10 @@
11-- Test the TCP transport using QuickCheck generated scripts
22--
3−-- TODO: This is not quite working yet. The main problem, I think, is the
3+-- TODO: This is not quite working yet. The main problem, I think, is the
44-- allocation of "bundle ID"s to connections. The problem is exposed by the
55-- aptly-named regression test script_Foo (to be renamed once I figure out what
66-- bug that test is actually exposing :)
7−module Main
7+module Main
88 ( main
99 -- Shush the compiler about unused definitions
1010 , log
@@ -18,7 +18,7 @@ import Prelude hiding (log)
1818import Test.Framework (Test, TestName, defaultMain, testGroup)
1919import Test.Framework.Providers.QuickCheck2 (testProperty)
2020import Test.Framework.Providers.HUnit (testCase)
21−import Test.QuickCheck
21+import Test.QuickCheck
2222 ( Gen
2323 , choose
2424 , suchThatMaybe
@@ -55,7 +55,7 @@ import qualified Data.Set as Set
5555import GHC.Stack (currentCallStack, renderStack)
5656
5757import Network.Transport
58−import Network.Transport.TCP
58+import Network.Transport.TCP
5959 ( createTransportExposeInternals
6060 , defaultTCPParameters
6161 , TransportInternals(socketBetween)
@@ -74,26 +74,26 @@ type ConnectionIx = Int
7474-- | We randomly generate /scripts/ which are essentially a deep embedding of
7575-- the Transport API. These scripts are then executed and the results compared
7676-- against an abstract interpreter.
77−data ScriptCmd =
77+data ScriptCmd =
7878 -- | Create a new endpoint
7979 NewEndPoint
8080 -- | @Connect i j@ creates a connection from endpoint @i@ to endpoint @j@,
8181 -- where @i@ and @j@ are indices and refer to the @i@th and @j@th endpoint
8282 -- created by NewEndPoint
83− | Connect SourceEndPointIx TargetEndPointIx
83+ | Connect SourceEndPointIx TargetEndPointIx
8484 -- | @Close i@ closes the @i@ connection created using 'Connect'. Note that
8585 -- closing a connection does not shift other indices; in other words, in
8686 -- @[Connect 0 0, Close 0, Connect 0 0, Close 0]@ the second 'Close'
8787 -- refers to the first (already closed) connection
88− | Close ConnectionIx
89− -- | @Send i bs@ sends payload @bs@ on the @i@ connection created
88+ | Close ConnectionIx
89+ -- | @Send i bs@ sends payload @bs@ on the @i@ connection created
9090 | Send ConnectionIx [ByteString]
9191 -- | @BreakAfterReads n i j@ force-closes the socket between endpoints @i@
92− -- and @j@ after @n@ reads by @i@
93− --
92+ -- and @j@ after @n@ reads by @i@
93+ --
9494 -- We should have @i /= j@ because the TCP transport does not use sockets
9595 -- for connections from an endpoint to itself
96− | BreakAfterReads Int SourceEndPointIx TargetEndPointIx
96+ | BreakAfterReads Int SourceEndPointIx TargetEndPointIx
9797 deriving Show
9898
9999type Script = [ScriptCmd]
@@ -111,7 +111,7 @@ instance Show a => Show (Variable a) where
111111
112112-- | In the implementation "bundles" are purely a conceptual idea, but in the
113113-- verifier we need to concretize this notion
114−type BundleId = Int
114+type BundleId = Int
115115
116116data ConnectionInfo = ConnectionInfo {
117117 source :: EndPointAddress
@@ -120,10 +120,10 @@ data ConnectionInfo = ConnectionInfo {
120120 , connectionBundle :: BundleId
121121 }
122122 deriving Show
123−
123+
124124data ExpEvent =
125125 ExpConnectionOpened ConnectionInfo
126− | ExpConnectionClosed ConnectionInfo
126+ | ExpConnectionClosed ConnectionInfo
127127 | ExpReceived ConnectionInfo [ByteString]
128128 | ExpConnectionLost BundleId EndPointAddress
129129 deriving Show
@@ -149,18 +149,18 @@ data RunState = RunState {
149149 -- | Current bundle ID between two endpoints
150150 --
151151 -- Invariant: For all keys (A, B), A <= B
152− , _currentBundle :: Map (EndPointAddress, EndPointAddress) BundleId
152+ , _currentBundle :: Map (EndPointAddress, EndPointAddress) BundleId
153153 }
154154
155−initialRunState :: RunState
155+initialRunState :: RunState
156156initialRunState = RunState {
157157 _endPoints = []
158158 , _connections = []
159159 , _expectedEvents = Map.empty
160160 , _forwardingThreads = []
161− , _mayBreak = Set.empty
161+ , _mayBreak = Set.empty
162162 , _broken = Set.empty
163− , _currentBundle = Map.empty
163+ , _currentBundle = Map.empty
164164 }
165165
166166verify :: (Transport, TransportInternals) -> Script -> IO (Either String ())
@@ -168,17 +168,17 @@ verify (transport, transportInternals) script = do
168168 allEvents <- newQ
169169
170170 let runScript :: Script -> StateT RunState IO ()
171− runScript = mapM_ runCmd
171+ runScript = mapM_ runCmd
172172
173− runCmd :: ScriptCmd -> StateT RunState IO ()
173+ runCmd :: ScriptCmd -> StateT RunState IO ()
174174 runCmd NewEndPoint = do
175175 mEndPoint <- liftIO $ newEndPoint transport
176176 case mEndPoint of
177177 Right endPoint -> do
178− tid <- liftIO $ forkIO (forward endPoint)
179− append endPoints endPoint
180− append forwardingThreads tid
181− set (expectedEventsAt (address endPoint)) []
178+ tid <- liftIO $ forkIO (forward endPoint)
179+ append endPoints endPoint
180+ append forwardingThreads tid
181+ set (expectedEventsAt (address endPoint)) []
182182 Left err ->
183183 liftIO $ throwIO err
184184 runCmd (Connect i j) = do
@@ -190,11 +190,11 @@ verify (transport, transportInternals) script = do
190190 connMayBreak = mayBreak (address endPointA) endPointB
191191 case mConn of
192192 Right conn -> do
193− bundleBroken <- get bundleId >>= get . connBroken
194− currentBundleId <- if bundleBroken
193+ bundleBroken <- get bundleId >>= get . connBroken
194+ currentBundleId <- if bundleBroken
195195 then modify bundleId (+ 1) >> get bundleId
196− else get bundleId
197− connId <- Variable <$> liftIO newUnique
196+ else get bundleId
197+ connId <- Variable <$> liftIO newUnique
198198 let connInfo = ConnectionInfo {
199199 source = address endPointA
200200 , target = endPointB
@@ -204,17 +204,17 @@ verify (transport, transportInternals) script = do
204204 append connections (conn, connInfo)
205205 append (expectedEventsAt endPointB) (ExpConnectionOpened connInfo)
206206 Left err -> do
207− currentBundleId <- get bundleId
207+ currentBundleId <- get bundleId
208208 expectingBreak <- get $ connMayBreak currentBundleId
209− if expectingBreak
209+ if expectingBreak
210210 then do
211211 set (connMayBreak currentBundleId) False
212212 set (connBroken currentBundleId) True
213− else
213+ else
214214 liftIO $ throwIO err
215215 runCmd (Close i) = do
216216 (conn, connInfo) <- get (connectionAt i)
217− liftIO $ close conn
217+ liftIO $ close conn
218218 append (expectedEventsAt (target connInfo)) (ExpConnectionClosed connInfo)
219219 runCmd (Send i payload) = do
220220 (conn, connInfo) <- get (connectionAt i)
@@ -224,16 +224,16 @@ verify (transport, transportInternals) script = do
224224 case mResult of
225225 Right () -> return ()
226226 Left err -> do
227− expectingBreak <- get connMayBreak
227+ expectingBreak <- get connMayBreak
228228 isBroken <- get connBroken
229229 if expectingBreak || isBroken
230230 then do
231231 set connMayBreak False
232232 set connBroken True
233− else
233+ else
234234 liftIO $ throwIO err
235235 append (expectedEventsAt (target connInfo)) (ExpReceived connInfo payload)
236− -- TODO: This will only work if a connection between 'i' and 'j' has
236+ -- TODO: This will only work if a connection between 'i' and 'j' has
237237 -- already been established. We would need to modify the mock network
238238 -- layer to support breaking "future" connections
239239 runCmd (BreakAfterReads n i j) = do
@@ -247,13 +247,13 @@ verify (transport, transportInternals) script = do
247247 set (mayBreak endPointB endPointA currentBundleId) True
248248 append (expectedEventsAt endPointA) (ExpConnectionLost currentBundleId endPointB)
249249 append (expectedEventsAt endPointB) (ExpConnectionLost currentBundleId endPointA)
250−
250+
251251 forward :: EndPoint -> IO ()
252252 forward endPoint = forever $ do
253253 ev <- receive endPoint
254254 pushL allEvents (address endPoint, ev)
255255
256− collectEvents :: RunState -> IO (Map EndPointAddress [Event])
256+ collectEvents :: RunState -> IO (Map EndPointAddress [Event])
257257 collectEvents st = do
258258 threadDelay 10000
259259 mapM_ killThread (st ^. forwardingThreads)
@@ -264,17 +264,17 @@ verify (transport, transportInternals) script = do
264264 mEv <- tryPopR allEvents
265265 case mEv of
266266 Just ev -> go (ev : acc)
267− Nothing -> return (reverse acc)
268−
269− st <- execStateT (runScript script) initialRunState
267+ Nothing -> return (reverse acc)
268+
269+ st <- execStateT (runScript script) initialRunState
270270 actualEvents <- collectEvents st
271−
272− let eventsMatch = all (uncurry match) $
271+
272+ let eventsMatch = all (uncurry match) $
273273 zip (Map.elems (st ^. expectedEvents))
274274 (Map.elems actualEvents)
275275
276− return $ if eventsMatch
277− then Right ()
276+ return $ if eventsMatch
277+ then Right ()
278278 else Left ("Could not match " ++ show (st ^. expectedEvents)
279279 ++ " and " ++ show actualEvents)
280280
@@ -296,7 +296,7 @@ possibleTraces :: [ExpEvent] -> [[ExpEvent]]
296296possibleTraces = go
297297 where
298298 go [] = [[]]
299− go (ev@(ExpConnectionLost _ _) : evs) =
299+ go (ev@(ExpConnectionLost _ _) : evs) =
300300 [ trace | evs' <- possibleTraces evs, trace <- insertConnectionLost ev evs' ]
301301 go (ev : evs) =
302302 [ trace | evs' <- possibleTraces evs, trace <- insertEvent ev evs' ]
@@ -304,38 +304,38 @@ possibleTraces = go
304304 -- We don't know when exactly the error will occur (indeed, it may never
305305 -- happen at all), but it must occur before any future connection lost
306306 -- event to the same destination.
307− -- If it occurs now, then all other events on this bundle will not happen.
307+ -- If it occurs now, then all other events on this bundle will not happen.
308308 insertConnectionLost :: ExpEvent -> [ExpEvent] -> [[ExpEvent]]
309309 insertConnectionLost ev [] = [[ev], []]
310310 insertConnectionLost ev@(ExpConnectionLost bid addr) (ev' : evs) =
311311 (ev : removeBundle bid (ev' : evs)) :
312312 case ev' of
313− ExpConnectionLost _ addr' | addr == addr' -> []
313+ ExpConnectionLost _ addr' | addr == addr' -> []
314314 _ -> [ev' : evs' | evs' <- insertConnectionLost ev evs]
315315 insertConnectionLost _ _ = error "The impossible happened"
316−
316+
317317 -- All other events can be arbitrarily reordered /across/ connections, but
318318 -- never /within/ connections
319319 insertEvent :: ExpEvent -> [ExpEvent] -> [[ExpEvent]]
320320 insertEvent ev [] = [[ev]]
321321 insertEvent ev (ev' : evs) =
322− (ev : ev' : evs) :
323− if eventConnId ev == eventConnId ev'
322+ (ev : ev' : evs) :
323+ if eventConnId ev == eventConnId ev'
324324 then []
325325 else [ev' : evs' | evs' <- insertEvent ev evs]
326326
327327 removeBundle :: BundleId -> [ExpEvent] -> [ExpEvent]
328− removeBundle bid = filter ((/= bid) . eventBundleId)
328+ removeBundle bid = filter ((/= bid) . eventBundleId)
329329
330330 eventBundleId :: ExpEvent -> BundleId
331331 eventBundleId (ExpConnectionOpened connInfo) = connectionBundle connInfo
332332 eventBundleId (ExpConnectionClosed connInfo) = connectionBundle connInfo
333333 eventBundleId (ExpReceived connInfo _) = connectionBundle connInfo
334334 eventBundleId (ExpConnectionLost bid _) = bid
335−
336− eventConnId :: ExpEvent -> Maybe (Variable ConnectionId)
337− eventConnId (ExpConnectionOpened connInfo) = Just $ connectionId connInfo
338− eventConnId (ExpConnectionClosed connInfo) = Just $ connectionId connInfo
335+
336+ eventConnId :: ExpEvent -> Maybe (Variable ConnectionId)
337+ eventConnId (ExpConnectionOpened connInfo) = Just $ connectionId connInfo
338+ eventConnId (ExpConnectionClosed connInfo) = Just $ connectionId connInfo
339339 eventConnId (ExpReceived connInfo _) = Just $ connectionId connInfo
340340 eventConnId (ExpConnectionLost _ _) = Nothing
341341
@@ -343,56 +343,56 @@ possibleTraces = go
343343-- Unification --
344344--------------------------------------------------------------------------------
345345
346−type Substitution = Map Unique ConnectionId
346+type Substitution = Map Unique ConnectionId
347347
348−newtype Unifier a = Unifier {
349− runUnifier :: Substitution -> Maybe (a, Substitution)
350− }
348+newtype Unifier a = Unifier {
349+ runUnifier :: Substitution -> Maybe (a, Substitution)
350+ }
351351
352352instance Monad Unifier where
353353 return x = Unifier $ \subst -> Just (x, subst)
354354 x >>= f = Unifier $ \subst -> case runUnifier x subst of
355355 Nothing -> Nothing
356356 Just (a, subst') -> runUnifier (f a) subst'
357− fail _str = mzero
357+ fail _str = mzero
358358
359−instance MonadPlus Unifier where
359+instance MonadPlus Unifier where
360360 mzero = Unifier $ const Nothing
361361 f `mplus` g = Unifier $ \subst -> case runUnifier f subst of
362362 Nothing -> runUnifier g subst
363363 Just (a, subst') -> Just (a, subst')
364364
365365class Unify a b where
366− unify :: a -> b -> Unifier ()
366+ unify :: a -> b -> Unifier ()
367367
368368canUnify :: Unify a b => a -> b -> Bool
369369canUnify a b = isJust $ runUnifier (unify a b) Map.empty
370370
371371instance Unify Unique ConnectionId where
372− unify x cid = Unifier $ \subst ->
372+ unify x cid = Unifier $ \subst ->
373373 case Map.lookup x subst of
374374 Just cid' -> if cid == cid' then Just ((), subst)
375375 else Nothing
376376 Nothing -> Just ((), Map.insert x cid subst)
377377
378378instance Unify (Variable ConnectionId) ConnectionId where
379− unify (Variable x) connId = unify x connId
380− unify (Value connId') connId = guard $ connId' == connId
379+ unify (Variable x) connId = unify x connId
380+ unify (Value connId') connId = guard $ connId' == connId
381381
382382instance Unify ExpEvent Event where
383− unify (ExpConnectionOpened connInfo) (ConnectionOpened connId _ _) =
384− unify (connectionId connInfo) connId
385− unify (ExpConnectionClosed connInfo) (ConnectionClosed connId) =
383+ unify (ExpConnectionOpened connInfo) (ConnectionOpened connId _ _) =
384+ unify (connectionId connInfo) connId
385+ unify (ExpConnectionClosed connInfo) (ConnectionClosed connId) =
386386 unify (connectionId connInfo) connId
387387 unify (ExpReceived connInfo payload) (Received connId payload') = do
388388 guard $ BSS.concat payload == BSS.concat payload'
389389 unify (connectionId connInfo) connId
390− unify (ExpConnectionLost _ addr) (ErrorEvent (TransportError (EventConnectionLost addr') _)) =
390+ unify (ExpConnectionLost _ addr) (ErrorEvent (TransportError (EventConnectionLost addr') _)) =
391391 guard $ addr == addr'
392− unify _ _ = fail "Cannot unify"
392+ unify _ _ = fail "Cannot unify"
393393
394394instance Unify a b => Unify [a] [b] where
395− unify [] [] = return ()
395+ unify [] [] = return ()
396396 unify (x:xs) (y:ys) = unify x y >> unify xs ys
397397 unify _ _ = fail "Cannot unify"
398398
@@ -422,7 +422,7 @@ script_Connect numEndPoints = do
422422
423423script_ConnectClose :: Int -> Gen Script
424424script_ConnectClose numEndPoints = do
425− script <- go Map.empty
425+ script <- go Map.empty
426426 return (replicate numEndPoints NewEndPoint ++ script)
427427 where
428428 go :: Map Int Bool -> Gen Script
@@ -432,15 +432,15 @@ script_ConnectClose numEndPoints = do
432432 0 -> do
433433 fr <- choose (0, numEndPoints - 1)
434434 to <- choose (0, numEndPoints - 1)
435− cmds <- go (Map.insert (Map.size conns) True conns)
435+ cmds <- go (Map.insert (Map.size conns) True conns)
436436 return (Connect fr to : cmds)
437437 1 -> do
438− mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns
439− case mConn of
438+ mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns
439+ case mConn of
440440 Nothing -> go conns
441441 Just conn -> do
442442 cmds <- go (Map.insert conn False conns)
443− return (Close conn : cmds)
443+ return (Close conn : cmds)
444444 _ ->
445445 return []
446446
@@ -449,7 +449,7 @@ script_ConnectClose numEndPoints = do
449449
450450script_ConnectSendClose :: Int -> Gen Script
451451script_ConnectSendClose numEndPoints = do
452− script <- go Map.empty
452+ script <- go Map.empty
453453 return (replicate numEndPoints NewEndPoint ++ script)
454454 where
455455 go :: Map Int Bool -> Gen Script
@@ -459,24 +459,24 @@ script_ConnectSendClose numEndPoints = do
459459 0 -> do
460460 fr <- choose (0, numEndPoints - 1)
461461 to <- choose (0, numEndPoints - 1)
462− cmds <- go (Map.insert (Map.size conns) True conns)
462+ cmds <- go (Map.insert (Map.size conns) True conns)
463463 return (Connect fr to : cmds)
464464 1 -> do
465− mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns
466− case mConn of
465+ mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns
466+ case mConn of
467467 Nothing -> go conns
468468 Just conn -> do
469469 numSegments <- choose (0, 2)
470− payload <- replicateM numSegments arbitrary
471− cmds <- go conns
472− return (Send conn payload : cmds)
470+ payload <- replicateM numSegments arbitrary
471+ cmds <- go conns
472+ return (Send conn payload : cmds)
473473 2 -> do
474− mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns
475− case mConn of
474+ mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns
475+ case mConn of
476476 Nothing -> go conns
477477 Just conn -> do
478478 cmds <- go (Map.insert conn False conns)
479− return (Close conn : cmds)
479+ return (Close conn : cmds)
480480 _ ->
481481 return []
482482
@@ -505,7 +505,7 @@ withErrors numErrors gen = gen >>= insertError numErrors
505505 return $ cmd : cmds'
506506
507507--------------------------------------------------------------------------------
508−-- Individual scripts to test specific bugs --
508+-- Individual scripts to test specific bugs --
509509--------------------------------------------------------------------------------
510510
511511-- | Bug #1
@@ -513,15 +513,15 @@ withErrors numErrors gen = gen >>= insertError numErrors
513513-- When process A wants to close the heavyweight connection to process B it
514514-- sends a CloseSocket request together with the ID of the last connection from
515515-- B. When B receives the CloseSocket request it can compare this ID to the last
516−-- connection it created; if they don't match, B knows that there are some
517−-- messages still on the way from B to A (in particular, a CreatedConnection
518−-- message) which will cancel the CloseSocket request from A. Hence, it will
516+-- connection it created; if they don't match, B knows that there are some
517+-- messages still on the way from B to A (in particular, a CreatedConnection
518+-- message) which will cancel the CloseSocket request from A. Hence, it will
519519-- know to ignore the CloseSocket request from A.
520520--
521521-- The bug was that we recorded the last _created_ outgoing connection on the
522522-- local endpoint, but the last _received_ incoming connection on the state of
523523-- the heavyweight connection. So, in the script below, the following happened:
524−--
524+--
525525-- A connects to B, records "last connection ID is 1024"
526526-- A closes the lightweight connection, sends [CloseConnection 1024]
527527-- A closes the heivyweight connection, sends [CloseSocket 0]
@@ -541,7 +541,7 @@ withErrors numErrors gen = gen >>= insertError numErrors
541541-- A receives the [CloseSocket 0] request, compares it to the last recorded
542542-- outgoing ID (1024), sees that they are not equal, and concludes that this
543543-- must mean that there is still a CreatedConnection message on the way from A
544−-- to B.
544+-- to B.
545545--
546546-- This of course is not the case, so B will wait forever for A to confirm
547547-- the CloseSocket request, and deadlock arises. (This deadlock doesn't become
@@ -572,7 +572,7 @@ script_MultipleSends = [
572572 , Send 0 ["E"]
573573 ]
574574
575−-- | Simulate broken network connection during send
575+-- | Simulate broken network connection during send
576576script_BreakSend :: Script
577577script_BreakSend = [
578578 NewEndPoint
@@ -650,12 +650,12 @@ tests transport = [
650650 , testOne "Foo" transport script_Foo
651651 ]
652652 , testGroup "Without errors" [
653− testGroup "One endpoint, with delays" (basicTests transport 1 id)
654− , testGroup "Two endpoints, with delays" (basicTests transport 2 id)
653+ testGroup "One endpoint, with delays" (basicTests transport 1 id)
654+ , testGroup "Two endpoints, with delays" (basicTests transport 2 id)
655655 , testGroup "Three endpoints, with delays" (basicTests transport 3 id)
656656 ]
657657 , testGroup "Single error" [
658− testGroup "Two endpoints, with delays" (basicTests transport 2 (withErrors 1))
658+ testGroup "Two endpoints, with delays" (basicTests transport 2 (withErrors 1))
659659 , testGroup "Three endpoints, with delays" (basicTests transport 3 (withErrors 1))
660660 ]
661661 ]
@@ -665,7 +665,7 @@ testOne :: TestName -> (Transport, TransportInternals) -> Script -> Test
665665testOne label transport script = testCase label (testScript transport script)
666666
667667testGen :: TestName -> (Transport, TransportInternals) -> Gen Script -> Test
668−testGen label transport script = testProperty label (testScriptGen transport script)
668+testGen label transport script = testProperty label (testScriptGen transport script)
669669
670670main :: IO ()
671671main = do
@@ -677,10 +677,10 @@ main = do
677677--------------------------------------------------------------------------------
678678
679679testScriptGen :: (Transport, TransportInternals) -> Gen Script -> Property
680−testScriptGen transport scriptGen =
681− forAll scriptGen $ \script ->
682− morallyDubiousIOProperty $ do
683− logShow script
680+testScriptGen transport scriptGen =
681+ forAll scriptGen $ \script ->
682+ morallyDubiousIOProperty $ do
683+ logShow script
684684 mErr <- try $ verify transport script
685685 return $ case mErr of
686686 Left (ExpectedFailure str) ->
@@ -696,12 +696,12 @@ testScriptGen transport scriptGen =
696696
697697testScript :: (Transport, TransportInternals) -> Script -> Assertion
698698testScript transport script = do
699− logShow script
699+ logShow script
700700 mErr <- try $ verify transport script
701701 case mErr of
702− Left (ExpectedFailure _str) ->
702+ Left (ExpectedFailure _str) ->
703703 return ()
704− Right (Left err) ->
704+ Right (Left err) ->
705705 assertFailure $ "Failed with script " ++ show script ++ ": " ++ err ++ "\n"
706706 Right (Right ()) ->
707707 return ()
@@ -756,7 +756,7 @@ verticalList :: Show a => [a] -> PP.Doc
756756verticalList = PP.brackets . PP.vcat . map (PP.text . show)
757757
758758instance Show Script where
759− show = ("\n" ++) . show . verticalList
759+ show = ("\n" ++) . show . verticalList
760760
761761instance Show [Event] where
762762 show = ("\n" ++) . show . verticalList
@@ -765,13 +765,13 @@ instance Show [ExpEvent] where
765765 show = ("\n" ++) . show . verticalList
766766
767767instance Show (Map EndPointAddress [ExpEvent]) where
768− show = ("\n" ++) . show . PP.brackets . PP.vcat
769− . map (\(addr, evs) -> PP.hcat . PP.punctuate PP.comma $ [PP.text (show addr), verticalList evs])
768+ show = ("\n" ++) . show . PP.brackets . PP.vcat
769+ . map (\(addr, evs) -> PP.hcat . PP.punctuate PP.comma $ [PP.text (show addr), verticalList evs])
770770 . Map.toList
771771
772772instance Show (Map EndPointAddress [Event]) where
773− show = ("\n" ++) . show . PP.brackets . PP.vcat
774− . map (\(addr, evs) -> PP.hcat . PP.punctuate PP.comma $ [PP.text (show addr), verticalList evs])
773+ show = ("\n" ++) . show . PP.brackets . PP.vcat
774+ . map (\(addr, evs) -> PP.hcat . PP.punctuate PP.comma $ [PP.text (show addr), verticalList evs])
775775 . Map.toList
776776
777777--------------------------------------------------------------------------------
@@ -784,25 +784,25 @@ class Distribution d where
784784 probabilityOf :: d -> Double -> Double
785785
786786instance Distribution NormalD where
787− probabilityOf d x = a * exp (-0.5 * b * b)
787+ probabilityOf d x = a * exp (-0.5 * b * b)
788788 where
789789 a = 1 / (stdDev d * sqrt (2 * pi))
790790 b = (x - mean d) / stdDev d
791791
792−-- | Choose from a distribution
792+-- | Choose from a distribution
793793chooseFrom :: Distribution d => d -> (Double, Double) -> Gen Double
794−chooseFrom d (lo, hi) = findCandidate
794+chooseFrom d (lo, hi) = findCandidate
795795 where
796− findCandidate :: Gen Double
796+ findCandidate :: Gen Double
797797 findCandidate = do
798798 candidate <- choose (lo, hi)
799799 uniformSample <- choose (0, 1)
800800 if uniformSample < probabilityOf d candidate
801801 then return candidate
802− else findCandidate
802+ else findCandidate
803803
804804chooseFrom' :: Distribution d => d -> (Int, Int) -> Gen Int
805−chooseFrom' d (lo, hi) =
805+chooseFrom' d (lo, hi) =
806806 round <$> chooseFrom d (fromIntegral lo, fromIntegral hi)
807807
808808--------------------------------------------------------------------------------
@@ -817,15 +817,15 @@ logShow = log . show
817817
818818instance Arbitrary ByteString where
819819 arbitrary = do
820− len <- chooseFrom' NormalD { mean = 5, stdDev = 10 } (0, 100)
820+ len <- chooseFrom' NormalD { mean = 5, stdDev = 10 } (0, 100)
821821 xs <- replicateM len arbitrary
822822 return (pack xs)
823823
824824listAccessor :: Int -> Accessor [a] a
825−listAccessor i = accessor (!! i) (error "listAccessor.set not defined")
825+listAccessor i = accessor (!! i) (error "listAccessor.set not defined")
826826
827827append :: Monad m => Accessor st [a] -> a -> StateT st m ()
828−append acc x = modify acc (snoc x)
828+append acc x = modify acc (snoc x)
829829
830830snoc :: a -> [a] -> [a]
831831snoc x xs = xs ++ [x]
@@ -833,8 +833,8 @@ snoc x xs = xs ++ [x]
833833groupByKey :: Ord a => [a] -> [(a, b)] -> Map a [b]
834834groupByKey keys = go (Map.fromList [(key, []) | key <- keys])
835835 where
836− go acc [] = Map.map reverse acc
837− go acc ((key, val) : rest) = go (Map.adjust (val :) key acc) rest
836+ go acc [] = Map.map reverse acc
837+ go acc ((key, val) : rest) = go (Map.adjust (val :) key acc) rest
838838
839839--------------------------------------------------------------------------------
840840-- Expected failures (can't find explicit support for this in test-framework) --
network-transport-tcp/tests/TestTCP.hs+98−98
@@ -2,7 +2,7 @@
22{-# OPTIONS_GHC -fno-warn-orphans #-}
33module Main where
44
5−import Prelude hiding
5+import Prelude hiding
66 ( (>>=)
77 , return
88 , fail
@@ -49,7 +49,7 @@ import Network.Transport.TCP.Internal (recvInt32, forkServer, recvWithLength)
4949#ifdef USE_MOCK_NETWORK
5050import qualified Network.Transport.TCP.Mock.Socket as N
5151#else
52−import qualified Network.Socket as N
52+import qualified Network.Socket as N
5353#endif
5454 ( sClose
5555 , ServiceName
@@ -69,9 +69,9 @@ import Data.String (fromString)
6969import GHC.IO.Exception (ioe_errno)
7070import Foreign.C.Error (Errno(..), eADDRNOTAVAIL)
7171import System.Timeout (timeout)
72−import Network.Transport.Tests (testTransport)
72+import Network.Transport.Tests (testTransport)
7373import Network.Transport.Tests.Auxiliary (forkTry, runTests)
74−import Network.Transport.Tests.Traced
74+import Network.Transport.Tests.Traced
7575
7676instance Traceable ControlHeader where
7777 trace = traceShow
@@ -80,7 +80,7 @@ instance Traceable ConnectionRequestResponse where
8080 trace = traceShow
8181
8282instance Traceable N.Socket where
83− trace = traceShow
83+ trace = traceShow
8484
8585instance Traceable N.AddrInfo where
8686 trace = traceShow
@@ -112,17 +112,17 @@ testEarlyDisconnect nextPort = do
112112
113113 -- TEST 1: they connect to us, then drop the connection
114114 do
115− ConnectionOpened _ _ addr <- receive endpoint
115+ ConnectionOpened _ _ addr <- receive endpoint
116116 True <- return $ addr == theirAddr
117−
118− ErrorEvent (TransportError (EventConnectionLost addr') _) <- receive endpoint
119− True <- return $ addr' == theirAddr
117+
118+ ErrorEvent (TransportError (EventConnectionLost addr') _) <- receive endpoint
119+ True <- return $ addr' == theirAddr
120120
121121 return ()
122122
123123 -- TEST 2: after they dropped their connection to us, we now try to
124124 -- establish a connection to them. This should re-establish the broken
125− -- TCP connection.
125+ -- TCP connection.
126126 tlog "Trying to connect to client"
127127 Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
128128
@@ -131,39 +131,39 @@ testEarlyDisconnect nextPort = do
131131 -- closes the socket
132132 do
133133 Right () <- send conn ["ping"]
134−
135− ConnectionOpened cid _ addr <- receive endpoint
134+
135+ ConnectionOpened cid _ addr <- receive endpoint
136136 True <- return $ addr == theirAddr
137−
137+
138138 Received cid' ["pong"] <- receive endpoint
139139 True <- return $ cid == cid'
140−
140+
141141 ErrorEvent (TransportError (EventConnectionLost addr') _) <- receive endpoint
142− True <- return $ addr' == theirAddr
142+ True <- return $ addr' == theirAddr
143143
144144 return ()
145145
146146 -- TEST 4: A subsequent send on an already-open connection will now break
147147 Left (TransportError SendFailed _) <- send conn ["ping2"]
148148
149− -- *Pfew*
149+ -- *Pfew*
150150 putMVar serverDone ()
151151
152152 client :: MVar EndPointAddress -> MVar EndPointAddress -> IO ()
153153 client serverAddr clientAddr = do
154154 tlog "Client"
155155 clientPort <- nextPort
156− let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0
157− putMVar clientAddr ourAddress
158−
156+ let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0
157+ putMVar clientAddr ourAddress
158+
159159 -- Listen for incoming messages
160160 forkServer "127.0.0.1" clientPort 5 True throwIO $ \sock -> do
161− -- Initial setup
161+ -- Initial setup
162162 0 <- recvInt32 sock :: IO Int
163− _ <- recvWithLength sock
163+ _ <- recvWithLength sock
164164 sendMany sock [encodeInt32 ConnectionRequestAccepted]
165165
166− -- Server opens a logical connection
166+ -- Server opens a logical connection
167167 CreatedNewConnection <- toEnum <$> (recvInt32 sock :: IO Int)
168168 1024 <- recvInt32 sock :: IO LightweightConnectionId
169169
@@ -171,21 +171,21 @@ testEarlyDisconnect nextPort = do
171171 1024 <- recvInt32 sock :: IO Int
172172 ["ping"] <- recvWithLength sock
173173
174− -- Reply
174+ -- Reply
175175 sendMany sock [encodeInt32 CreatedNewConnection, encodeInt32 (10002 :: Int)]
176− sendMany sock (encodeInt32 10002 : prependLength ["pong"])
176+ sendMany sock (encodeInt32 10002 : prependLength ["pong"])
177177
178178 -- Close the socket
179179 N.sClose sock
180−
180+
181181 -- Connect to the server
182182 Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing
183−
183+
184184 -- Open a new connection
185185 sendMany sock [encodeInt32 CreatedNewConnection, encodeInt32 (10003 :: Int)]
186−
186+
187187 -- Close the socket without closing the connection explicitly
188− -- The server should receive an error event
188+ -- The server should receive an error event
189189 N.sClose sock
190190
191191-- | Test the behaviour of a premature CloseSocket request
@@ -211,19 +211,19 @@ testEarlyCloseSocket nextPort = do
211211
212212 -- TEST 1: they connect to us, then send a CloseSocket. Since we don't
213213 -- have any outgoing connections, this means we will agree to close the
214− -- socket
214+ -- socket
215215 do
216− ConnectionOpened cid _ addr <- receive endpoint
216+ ConnectionOpened cid _ addr <- receive endpoint
217217 True <- return $ addr == theirAddr
218−
219− ConnectionClosed cid' <- receive endpoint
218+
219+ ConnectionClosed cid' <- receive endpoint
220220 True <- return $ cid' == cid
221221
222222 return ()
223223
224224 -- TEST 2: after they dropped their connection to us, we now try to
225225 -- establish a connection to them. This should re-establish the broken
226− -- TCP connection.
226+ -- TCP connection.
227227 tlog "Trying to connect to client"
228228 Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
229229
@@ -234,65 +234,65 @@ testEarlyCloseSocket nextPort = do
234234 -- the socket gets closed
235235 do
236236 Right () <- send conn ["ping"]
237−
237+
238238 ConnectionOpened cid _ addr <- receive endpoint
239239 True <- return $ addr == theirAddr
240−
240+
241241 Received cid' ["pong"] <- receive endpoint
242242 True <- return $ cid' == cid
243−
243+
244244 ConnectionClosed cid'' <- receive endpoint
245245 True <- return $ cid'' == cid
246−
246+
247247 ErrorEvent (TransportError (EventConnectionLost addr') _) <- receive endpoint
248− True <- return $ addr' == theirAddr
249−
248+ True <- return $ addr' == theirAddr
249+
250250 return ()
251251
252252 -- TEST 4: A subsequent send on an already-open connection will now break
253253 Left (TransportError SendFailed _) <- send conn ["ping2"]
254254
255− -- *Pfew*
255+ -- *Pfew*
256256 putMVar serverDone ()
257257
258258 client :: MVar EndPointAddress -> MVar EndPointAddress -> IO ()
259259 client serverAddr clientAddr = do
260260 tlog "Client"
261261 clientPort <- nextPort
262− let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0
263− putMVar clientAddr ourAddress
264−
262+ let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0
263+ putMVar clientAddr ourAddress
264+
265265 -- Listen for incoming messages
266266 forkServer "127.0.0.1" clientPort 5 True throwIO $ \sock -> do
267− -- Initial setup
267+ -- Initial setup
268268 0 <- recvInt32 sock :: IO Int
269− _ <- recvWithLength sock
269+ _ <- recvWithLength sock
270270 sendMany sock [encodeInt32 ConnectionRequestAccepted]
271271
272− -- Server opens a logical connection
272+ -- Server opens a logical connection
273273 CreatedNewConnection <- toEnum <$> (recvInt32 sock :: IO Int)
274− 1024 <- recvInt32 sock :: IO LightweightConnectionId
274+ 1024 <- recvInt32 sock :: IO LightweightConnectionId
275275
276276 -- Server sends a message
277277 1024 <- recvInt32 sock :: IO Int
278278 ["ping"] <- recvWithLength sock
279279
280− -- Reply
280+ -- Reply
281281 sendMany sock [encodeInt32 CreatedNewConnection, encodeInt32 (10002 :: Int)]
282− sendMany sock (encodeInt32 (10002 :: Int) : prependLength ["pong"])
282+ sendMany sock (encodeInt32 (10002 :: Int) : prependLength ["pong"])
283283
284284 -- Send a CloseSocket even though there are still connections *in both
285285 -- directions*
286286 sendMany sock [encodeInt32 CloseSocket, encodeInt32 (1024 :: Int)]
287287 N.sClose sock
288−
288+
289289 -- Connect to the server
290290 Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing
291−
291+
292292 -- Open a new connection
293293 sendMany sock [encodeInt32 CreatedNewConnection, encodeInt32 (10003 :: Int)]
294−
295− -- Send a CloseSocket without sending a closeconnecton
294+
295+ -- Send a CloseSocket without sending a closeconnecton
296296 -- The server should still receive a ConnectionClosed message
297297 sendMany sock [encodeInt32 CloseSocket, encodeInt32 (0 :: Int)]
298298 N.sClose sock
@@ -311,26 +311,26 @@ testInvalidConnect nextPort = do
311311 Right endpoint <- newEndPoint transport
312312
313313 -- Syntax error in the endpoint address
314− Left (TransportError ConnectFailed _) <-
314+ Left (TransportError ConnectFailed _) <-
315315 connect endpoint (EndPointAddress "InvalidAddress") ReliableOrdered defaultConnectHints
316−
316+
317317 -- Syntax connect, but invalid hostname (TCP address lookup failure)
318− Left (TransportError ConnectNotFound _) <-
318+ Left (TransportError ConnectNotFound _) <-
319319 connect endpoint (encodeEndPointAddress "invalidHost" "port" 0) ReliableOrdered defaultConnectHints
320−
320+
321321 -- TCP address correct, but nobody home at that address
322− Left (TransportError ConnectNotFound _) <-
322+ Left (TransportError ConnectNotFound _) <-
323323 connect endpoint (encodeEndPointAddress "127.0.0.1" "9000" 0) ReliableOrdered defaultConnectHints
324−
324+
325325 -- Valid TCP address but invalid endpoint number
326− Left (TransportError ConnectNotFound _) <-
326+ Left (TransportError ConnectNotFound _) <-
327327 connect endpoint (encodeEndPointAddress "127.0.0.1" port 1) ReliableOrdered defaultConnectHints
328328
329329 return ()
330330
331331-- | Test that an endpoint can ignore CloseSocket requests (in "reality" this
332332-- would happen when the endpoint sends a new connection request before
333−-- receiving an (already underway) CloseSocket request)
333+-- receiving an (already underway) CloseSocket request)
334334testIgnoreCloseSocket :: IO N.ServiceName -> IO ()
335335testIgnoreCloseSocket nextPort = do
336336 serverAddr <- newEmptyMVar
@@ -397,7 +397,7 @@ testIgnoreCloseSocket nextPort = do
397397
398398 -- Close it again
399399 tlog "Closing connection"
400− sendMany sock [encodeInt32 CloseConnection, encodeInt32 (1024 :: Int)]
400+ sendMany sock [encodeInt32 CloseConnection, encodeInt32 (1024 :: Int)]
401401
402402 -- And close the connection completely
403403 tlog "Closing socket"
@@ -471,7 +471,7 @@ testBlockAfterCloseSocket nextPort = do
471471 unblocked <- newMVar False
472472
473473 -- We should not hear from the server until we unblock him by
474− -- responding to the CloseSocket request (in this case, we
474+ -- responding to the CloseSocket request (in this case, we
475475 -- respond by sending a ConnectionRequest)
476476 forkTry $ do
477477 recvInt32 sock :: IO Int32
@@ -490,7 +490,7 @@ testBlockAfterCloseSocket nextPort = do
490490
491491-- | Test what happens when a remote endpoint sends a connection request to our
492492-- transport for an endpoint it already has a connection to
493−testUnnecessaryConnect :: IO N.ServiceName -> Int -> IO ()
493+testUnnecessaryConnect :: IO N.ServiceName -> Int -> IO ()
494494testUnnecessaryConnect nextPort numThreads = do
495495 clientDone <- newEmptyMVar
496496 serverAddr <- newEmptyMVar
@@ -501,22 +501,22 @@ testUnnecessaryConnect nextPort numThreads = do
501501 putMVar serverAddr (address endpoint)
502502
503503 forkTry $ do
504− -- We pick an address < 127.0.0.1 so that this is not rejected purely because of the "crossed" check
504+ -- We pick an address < 127.0.0.1 so that this is not rejected purely because of the "crossed" check
505505 let ourAddress = EndPointAddress "126.0.0.1"
506506
507507 -- We should only get a single 'Accepted' reply
508508 gotAccepted <- newEmptyMVar
509509 dones <- replicateM numThreads $ do
510− done <- newEmptyMVar
510+ done <- newEmptyMVar
511511 forkTry $ do
512512 -- It is possible that the remote endpoint just rejects the request by closing the socket
513513 -- immediately (depending on far the remote endpoint got with the initialization)
514− response <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing
514+ response <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing
515515 case response of
516− Right (_, ConnectionRequestAccepted) ->
516+ Right (_, ConnectionRequestAccepted) ->
517517 -- We don't close this socket because we want to keep this connection open
518518 putMVar gotAccepted ()
519− -- We might get either Invalid or Crossed (the transport does not
519+ -- We might get either Invalid or Crossed (the transport does not
520520 -- maintain enough history to be able to tell)
521521 Right (sock, ConnectionRequestInvalid) ->
522522 N.sClose sock
@@ -536,7 +536,7 @@ testUnnecessaryConnect nextPort numThreads = do
536536testMany :: IO N.ServiceName -> IO ()
537537testMany nextPort = do
538538 Right masterTransport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
539− Right masterEndPoint <- newEndPoint masterTransport
539+ Right masterEndPoint <- newEndPoint masterTransport
540540
541541 replicateM_ 10 $ do
542542 mTransport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters
@@ -544,7 +544,7 @@ testMany nextPort = do
544544 Left ex -> do
545545 putStrLn $ "IOException: " ++ show ex ++ "; errno = " ++ show (ioe_errno ex)
546546 case (ioe_errno ex) of
547− Just no | Errno no == eADDRNOTAVAIL -> putStrLn "(ADDRNOTAVAIL)"
547+ Just no | Errno no == eADDRNOTAVAIL -> putStrLn "(ADDRNOTAVAIL)"
548548 _ -> return ()
549549 throwIO ex
550550 Right transport ->
@@ -561,7 +561,7 @@ testBreakTransport nextPort = do
561561
562562 killThread (transportThread internals) -- Uh oh
563563
564− ErrorEvent (TransportError EventTransportFailed _) <- receive endpoint
564+ ErrorEvent (TransportError EventTransportFailed _) <- receive endpoint
565565
566566 return ()
567567
@@ -580,16 +580,16 @@ testReconnect nextPort = do
580580 endpointCreated <- newEmptyMVar
581581
582582 -- Server
583− forkTry $ do
583+ forkTry $ do
584584 -- Wait for the client to do its first attempt
585− readMVar firstAttempt
585+ readMVar firstAttempt
586586
587− counter <- newMVar (0 :: Int)
587+ counter <- newMVar (0 :: Int)
588588
589589 forkServer "127.0.0.1" serverPort 5 True throwIO $ \sock -> do
590− -- Accept the connection
590+ -- Accept the connection
591591 Right 0 <- tryIO $ (recvInt32 sock :: IO Int)
592− Right _ <- tryIO $ recvWithLength sock
592+ Right _ <- tryIO $ recvWithLength sock
593593 Right () <- tryIO $ sendMany sock [encodeInt32 ConnectionRequestAccepted]
594594
595595 -- The first time we close the socket before accepting the logical connection
@@ -604,10 +604,10 @@ testReconnect nextPort = do
604604 when (count > 1) $ do
605605 -- Client sends a message
606606 Right connId' <- tryIO $ (recvInt32 sock :: IO LightweightConnectionId)
607− True <- return $ connId == connId'
607+ True <- return $ connId == connId'
608608 Right ["ping"] <- tryIO $ recvWithLength sock
609609 putMVar serverDone ()
610−
610+
611611 Right () <- tryIO $ N.sClose sock
612612 return ()
613613
@@ -626,17 +626,17 @@ testReconnect nextPort = do
626626 -- The second attempt will fail because the server closes the socket before we can request a connection
627627 takeMVar endpointCreated
628628 -- This might time out or not, depending on whether the server closes the
629− -- socket before or after we can send the RequestConnectionId request
630− resultConnect <- timeout 500000 $ connect endpoint theirAddr ReliableOrdered defaultConnectHints
629+ -- socket before or after we can send the RequestConnectionId request
630+ resultConnect <- timeout 500000 $ connect endpoint theirAddr ReliableOrdered defaultConnectHints
631631 case resultConnect of
632632 Nothing -> return ()
633633 Just (Left (TransportError ConnectFailed _)) -> return ()
634634 Just (Left err) -> throwIO err
635− Just (Right _) -> throwIO $ userError "testConnect: unexpected connect success"
635+ Just (Right _) -> throwIO $ userError "testConnect: unexpected connect success"
636636
637637 -- The third attempt succeeds
638638 Right conn1 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
639−
639+
640640 -- But a send will fail because the server has closed the connection again
641641 threadDelay 100000
642642 Left (TransportError SendFailed _) <- send conn1 ["ping"]
@@ -675,12 +675,12 @@ testUnidirectionalError nextPort = do
675675
676676 CreatedNewConnection <- toEnum <$> (recvInt32 sock :: IO Int)
677677 connId <- recvInt32 sock :: IO LightweightConnectionId
678−
678+
679679 connId' <- recvInt32 sock :: IO LightweightConnectionId
680680 True <- return $ connId == connId'
681681 ["ping"] <- recvWithLength sock
682682 putMVar serverGotPing ()
683−
683+
684684 -- Client
685685 forkTry $ do
686686 Right (transport, internals) <- nextPort >>= \port -> createTransportExposeInternals "127.0.0.1" port defaultTCPParameters
@@ -693,12 +693,12 @@ testUnidirectionalError nextPort = do
693693 takeMVar serverGotPing
694694
695695 -- Close the *outgoing* part of the socket only
696− sock <- socketBetween internals (address endpoint) theirAddr
696+ sock <- socketBetween internals (address endpoint) theirAddr
697697 N.shutdown sock N.ShutdownSend
698698
699699 -- At this point we cannot notice the problem yet so we shouldn't receive an event yet
700700 Nothing <- timeout 500000 $ receive endpoint
701−
701+
702702 -- But when we send we find the error
703703 Left (TransportError SendFailed _) <- send conn1 ["ping"]
704704 ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint
@@ -709,7 +709,7 @@ testUnidirectionalError nextPort = do
709709 takeMVar serverGotPing
710710
711711 -- Again, close the outgoing part of the socket
712− sock' <- socketBetween internals (address endpoint) theirAddr
712+ sock' <- socketBetween internals (address endpoint) theirAddr
713713 N.shutdown sock' N.ShutdownSend
714714
715715 -- We now find the error when we attempt to close the connection
@@ -720,10 +720,10 @@ testUnidirectionalError nextPort = do
720720 send conn3 ["ping"]
721721 takeMVar serverGotPing
722722
723− -- We repeat once more.
724− sock'' <- socketBetween internals (address endpoint) theirAddr
723+ -- We repeat once more.
724+ sock'' <- socketBetween internals (address endpoint) theirAddr
725725 N.shutdown sock'' N.ShutdownSend
726−
726+
727727 -- Now we notice the problem when we try to connect
728728 Nothing <- timeout 500000 $ receive endpoint
729729 Left (TransportError ConnectFailed _) <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
@@ -754,7 +754,7 @@ testInvalidCloseConnection nextPort = do
754754 -- connection
755755 ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint
756756
757− putMVar serverDone ()
757+ putMVar serverDone ()
758758
759759 -- Client
760760 forkTry $ do
@@ -766,7 +766,7 @@ testInvalidCloseConnection nextPort = do
766766 Right _ <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
767767
768768 -- Get a handle on the TCP connection and manually send an invalid CloseConnection request
769− sock <- socketBetween internals ourAddr theirAddr
769+ sock <- socketBetween internals ourAddr theirAddr
770770 sendMany sock [encodeInt32 CloseConnection, encodeInt32 (12345 :: Int)]
771771
772772 putMVar clientDone ()
@@ -776,23 +776,23 @@ testInvalidCloseConnection nextPort = do
776776main :: IO ()
777777main = do
778778 portMVar <- newEmptyMVar
779− forkTry $ forM_ ([10080 ..] :: [Int]) $ putMVar portMVar . show
780− let nextPort = takeMVar portMVar
781− tcpResult <- tryIO $ runTests
779+ forkTry $ forM_ ([10080 ..] :: [Int]) $ putMVar portMVar . show
780+ let nextPort = takeMVar portMVar
781+ tcpResult <- tryIO $ runTests
782782 [ ("EarlyDisconnect", testEarlyDisconnect nextPort)
783783 , ("EarlyCloseSocket", testEarlyCloseSocket nextPort)
784784 , ("IgnoreCloseSocket", testIgnoreCloseSocket nextPort)
785785 , ("BlockAfterCloseSocket", testBlockAfterCloseSocket nextPort)
786786 , ("UnnecessaryConnect", testUnnecessaryConnect nextPort 10)
787787 , ("InvalidAddress", testInvalidAddress nextPort)
788− , ("InvalidConnect", testInvalidConnect nextPort)
788+ , ("InvalidConnect", testInvalidConnect nextPort)
789789 , ("Many", testMany nextPort)
790790 , ("BreakTransport", testBreakTransport nextPort)
791791 , ("Reconnect", testReconnect nextPort)
792792 , ("UnidirectionalError", testUnidirectionalError nextPort)
793793 , ("InvalidCloseConnection", testInvalidCloseConnection nextPort)
794794 ]
795− -- Run the generic tests even if the TCP specific tests failed..
795+ -- Run the generic tests even if the TCP specific tests failed..
796796 testTransport (either (Left . show) (Right) <$> nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters)
797797 -- ..but if the generic tests pass, still fail if the specific tests did not
798798 case tcpResult of
network-transport-tests/src/Network/Transport/Tests.hs+113−113
@@ -1,7 +1,7 @@
11{-# LANGUAGE RebindableSyntax #-}
22module Network.Transport.Tests where
33
4−import Prelude hiding
4+import Prelude hiding
55 ( (>>=)
66 , return
77 , fail
@@ -16,7 +16,7 @@ import Control.Exception (evaluate, throw, throwIO, bracket)
1616import Control.Monad (replicateM, replicateM_, when, guard, forM_, unless)
1717import Control.Monad.Error ()
1818import Control.Applicative ((<$>))
19−import Network.Transport
19+import Network.Transport
2020import Network.Transport.Internal (tlog, tryIO, timeoutMaybe)
2121import Network.Transport.Util (spawn)
2222import System.Random (randomIO)
@@ -34,22 +34,22 @@ echoServer :: EndPoint -> IO ()
3434echoServer endpoint = do
3535 go Map.empty
3636 where
37− go :: Map ConnectionId Connection -> IO ()
37+ go :: Map ConnectionId Connection -> IO ()
3838 go cs = do
3939 event <- receive endpoint
4040 case event of
4141 ConnectionOpened cid rel addr -> do
4242 tlog $ "Opened new connection " ++ show cid
4343 Right conn <- connect endpoint addr rel defaultConnectHints
44− go (Map.insert cid conn cs)
44+ go (Map.insert cid conn cs)
4545 Received cid payload -> do
46− send (Map.findWithDefault (error $ "Received: Invalid cid " ++ show cid) cid cs) payload
46+ send (Map.findWithDefault (error $ "Received: Invalid cid " ++ show cid) cid cs) payload
4747 go cs
48− ConnectionClosed cid -> do
48+ ConnectionClosed cid -> do
4949 tlog $ "Close connection " ++ show cid
5050 close (Map.findWithDefault (error $ "ConnectionClosed: Invalid cid " ++ show cid) cid cs)
51− go (Map.delete cid cs)
52− ReceivedMulticast _ _ ->
51+ go (Map.delete cid cs)
52+ ReceivedMulticast _ _ ->
5353 -- Ignore
5454 go cs
5555 ErrorEvent _ ->
@@ -81,49 +81,49 @@ ping endpoint server numPings msg = do
8181
8282 -- Wait for the server to close its connection to us
8383 tlog "Wait for ConnectionClosed message"
84− ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'
84+ ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'
8585
8686 -- Done
8787 tlog "Ping client done"
88−
88+
8989-- | Basic ping test
90−testPingPong :: Transport -> Int -> IO ()
90+testPingPong :: Transport -> Int -> IO ()
9191testPingPong transport numPings = do
9292 tlog "Starting ping pong test"
9393 server <- spawn transport echoServer
9494 result <- newEmptyMVar
9595
96− -- Client
96+ -- Client
9797 forkTry $ do
9898 tlog "Ping client"
9999 Right endpoint <- newEndPoint transport
100100 ping endpoint server numPings "ping"
101− putMVar result ()
102−
101+ putMVar result ()
102+
103103 takeMVar result
104104
105105-- | Test that endpoints don't get confused
106−testEndPoints :: Transport -> Int -> IO ()
106+testEndPoints :: Transport -> Int -> IO ()
107107testEndPoints transport numPings = do
108108 server <- spawn transport echoServer
109109 dones <- replicateM 2 newEmptyMVar
110110
111− forM_ (zip dones ['A'..]) $ \(done, name) -> forkTry $ do
111+ forM_ (zip dones ['A'..]) $ \(done, name) -> forkTry $ do
112112 let name' :: ByteString
113113 name' = pack [name]
114114 Right endpoint <- newEndPoint transport
115115 tlog $ "Ping client " ++ show name' ++ ": " ++ show (address endpoint)
116− ping endpoint server numPings name'
117− putMVar done ()
116+ ping endpoint server numPings name'
117+ putMVar done ()
118118
119119 forM_ dones takeMVar
120120
121121-- Test that connections don't get confused
122−testConnections :: Transport -> Int -> IO ()
122+testConnections :: Transport -> Int -> IO ()
123123testConnections transport numPings = do
124124 server <- spawn transport echoServer
125125 result <- newEmptyMVar
126−
126+
127127 -- Client
128128 forkTry $ do
129129 Right endpoint <- newEndPoint transport
@@ -131,7 +131,7 @@ testConnections transport numPings = do
131131 -- Open two connections to the server
132132 Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
133133 ConnectionOpened serv1 _ _ <- receive endpoint
134−
134+
135135 Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
136136 ConnectionOpened serv2 _ _ <- receive endpoint
137137
@@ -141,17 +141,17 @@ testConnections transport numPings = do
141141 -- One thread to send "pingB" on the second connection
142142 forkTry $ replicateM_ numPings $ send conn2 ["pingB"]
143143
144− -- Verify server responses
145− let verifyResponse 0 = putMVar result ()
146− verifyResponse n = do
144+ -- Verify server responses
145+ let verifyResponse 0 = putMVar result ()
146+ verifyResponse n = do
147147 event <- receive endpoint
148148 case event of
149149 Received cid [payload] -> do
150150 when (cid == serv1 && payload /= "pingA") $ error "Wrong message"
151151 when (cid == serv2 && payload /= "pingB") $ error "Wrong message"
152− verifyResponse (n - 1)
153− _ ->
154− verifyResponse n
152+ verifyResponse (n - 1)
153+ _ ->
154+ verifyResponse n
155155 verifyResponse (2 * numPings)
156156
157157 takeMVar result
@@ -161,7 +161,7 @@ testCloseOneConnection :: Transport -> Int -> IO ()
161161testCloseOneConnection transport numPings = do
162162 server <- spawn transport echoServer
163163 result <- newEmptyMVar
164−
164+
165165 -- Client
166166 forkTry $ do
167167 Right endpoint <- newEndPoint transport
@@ -169,7 +169,7 @@ testCloseOneConnection transport numPings = do
169169 -- Open two connections to the server
170170 Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
171171 ConnectionOpened serv1 _ _ <- receive endpoint
172−
172+
173173 Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
174174 ConnectionOpened serv2 _ _ <- receive endpoint
175175
@@ -177,21 +177,21 @@ testCloseOneConnection transport numPings = do
177177 forkTry $ do
178178 replicateM_ numPings $ send conn1 ["pingA"]
179179 close conn1
180−
180+
181181 -- One thread to send "pingB" on the second connection
182182 forkTry $ replicateM_ (numPings * 2) $ send conn2 ["pingB"]
183183
184− -- Verify server responses
185− let verifyResponse 0 = putMVar result ()
186− verifyResponse n = do
184+ -- Verify server responses
185+ let verifyResponse 0 = putMVar result ()
186+ verifyResponse n = do
187187 event <- receive endpoint
188188 case event of
189189 Received cid [payload] -> do
190190 when (cid == serv1 && payload /= "pingA") $ error "Wrong message"
191191 when (cid == serv2 && payload /= "pingB") $ error "Wrong message"
192− verifyResponse (n - 1)
193− _ ->
194− verifyResponse n
192+ verifyResponse (n - 1)
193+ _ ->
194+ verifyResponse n
195195 verifyResponse (3 * numPings)
196196
197197 takeMVar result
@@ -208,7 +208,7 @@ testCloseOneDirection transport numPings = do
208208
209209 -- A
210210 forkTry $ do
211− tlog "A"
211+ tlog "A"
212212 Right endpoint <- newEndPoint transport
213213 tlog (show (address endpoint))
214214 putMVar addrA (address endpoint)
@@ -218,25 +218,25 @@ testCloseOneDirection transport numPings = do
218218 Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
219219
220220 -- Wait for B to connect to us
221− tlog "Wait for B"
221+ tlog "Wait for B"
222222 ConnectionOpened cid _ _ <- receive endpoint
223223
224224 -- Send pings to B
225225 tlog "Send pings to B"
226− replicateM_ numPings $ send conn ["ping"]
226+ replicateM_ numPings $ send conn ["ping"]
227227
228228 -- Close our connection to B
229229 tlog "Close connection"
230230 close conn
231−
231+
232232 -- Wait for B's pongs
233− tlog "Wait for pongs from B"
233+ tlog "Wait for pongs from B"
234234 replicateM_ numPings $ do Received _ _ <- receive endpoint ; return ()
235235
236236 -- Wait for B to close it's connection to us
237237 tlog "Wait for B to close connection"
238238 ConnectionClosed cid' <- receive endpoint
239− guard (cid == cid')
239+ guard (cid == cid')
240240
241241 -- Done
242242 tlog "Done"
@@ -264,12 +264,12 @@ testCloseOneDirection transport numPings = do
264264 -- Wait for A to close it's connection to us
265265 tlog "Wait for A to close connection"
266266 ConnectionClosed cid' <- receive endpoint
267− guard (cid == cid')
267+ guard (cid == cid')
268268
269269 -- Send pongs to A
270270 tlog "Send pongs to A"
271271 replicateM_ numPings $ send conn ["pong"]
272−
272+
273273 -- Close our connection to A
274274 tlog "Close connection to A"
275275 close conn
@@ -285,10 +285,10 @@ collect :: EndPoint -> Maybe Int -> Maybe Int -> IO [(ConnectionId, [[ByteString
285285collect endPoint maxEvents timeout = go maxEvents Map.empty Map.empty
286286 where
287287 -- TODO: for more serious use of this function we'd need to make these arguments strict
288− go (Just 0) open closed = finish open closed
288+ go (Just 0) open closed = finish open closed
289289 go n open closed = do
290− mEvent <- tryIO . timeoutMaybe timeout (userError "timeout") $ receive endPoint
291− case mEvent of
290+ mEvent <- tryIO . timeoutMaybe timeout (userError "timeout") $ receive endPoint
291+ case mEvent of
292292 Left _ -> finish open closed
293293 Right event -> do
294294 let n' = (\x -> x - 1) <$> n
@@ -307,8 +307,8 @@ collect endPoint maxEvents timeout = go maxEvents Map.empty Map.empty
307307 EndPointClosed ->
308308 fail "Unexpected endpoint closure"
309309
310− finish open closed =
311− if Map.null open
310+ finish open closed =
311+ if Map.null open
312312 then return . Map.toList . Map.map reverse $ closed
313313 else fail $ "Open connections: " ++ show (map fst . Map.toList $ open)
314314
@@ -319,12 +319,12 @@ collect endPoint maxEvents timeout = go maxEvents Map.empty Map.empty
319319-- before receiving the messages on the second connection. What might (and sometimes
320320-- does) happen is that finishes sending all of its messages on the first connection
321321-- (in the TCP transport, the first socket pair) while B is behind on reading _from_
322−-- this connection (socket pair) -- the messages are "in transit" on the network
322+-- this connection (socket pair) -- the messages are "in transit" on the network
323323-- (these tests are done on localhost, so there are in some OS buffer). Then when
324324-- A opens the second connection (socket pair) B will spawn a new thread for this
325325-- connection, and hence might start interleaving messages from the first and second
326−-- connection.
327−--
326+-- connection.
327+--
328328-- This is correct behaviour, however: the transport API guarantees reliability and
329329-- ordering _per connection_, but not _across_ connections.
330330testCloseReopen :: Transport -> Int -> IO ()
@@ -332,7 +332,7 @@ testCloseReopen transport numPings = do
332332 addrB <- newEmptyMVar
333333 doneB <- newEmptyMVar
334334
335− let numRepeats = 2 :: Int
335+ let numRepeats = 2 :: Int
336336
337337 -- A
338338 forkTry $ do
@@ -342,7 +342,7 @@ testCloseReopen transport numPings = do
342342 tlog "A connecting"
343343 -- Connect to B
344344 Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
345−
345+
346346 tlog "A pinging"
347347 -- Say hi
348348 forM_ [1 .. numPings] $ \j -> send conn [pack $ "ping" ++ show i ++ "/" ++ show j]
@@ -372,12 +372,12 @@ testCloseReopen transport numPings = do
372372testParallelConnects :: Transport -> Int -> IO ()
373373testParallelConnects transport numPings = do
374374 server <- spawn transport echoServer
375− done <- newEmptyMVar
375+ done <- newEmptyMVar
376376
377377 Right endpoint <- newEndPoint transport
378378
379379 -- Spawn lots of clients
380− forM_ [1 .. numPings] $ \i -> forkTry $ do
380+ forM_ [1 .. numPings] $ \i -> forkTry $ do
381381 Right conn <- connect endpoint server ReliableOrdered defaultConnectHints
382382 send conn [pack $ "ping" ++ show i]
383383 send conn [pack $ "ping" ++ show i]
@@ -386,7 +386,7 @@ testParallelConnects transport numPings = do
386386 forkTry $ do
387387 eventss <- collect endpoint (Just (numPings * 4)) Nothing
388388 -- Check that no pings got sent to the wrong connection
389− forM_ eventss $ \(_, [[ping1], [ping2]]) ->
389+ forM_ eventss $ \(_, [[ping1], [ping2]]) ->
390390 guard (ping1 == ping2)
391391 putMVar done ()
392392
@@ -405,13 +405,13 @@ testSendAfterClose transport numRepeats = do
405405 replicateM numRepeats $ do
406406 Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
407407 Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
408−
408+
409409 -- Close the second, but leave the first open; then output on the second
410410 -- connection (i.e., on a closed connection while there is still another
411411 -- connection open)
412412 close conn2
413413 Left (TransportError SendClosed _) <- send conn2 ["ping2"]
414−
414+
415415 -- Now close the first connection, and output on it (i.e., output while
416416 -- there are no lightweight connection at all anymore)
417417 close conn1
@@ -425,7 +425,7 @@ testSendAfterClose transport numRepeats = do
425425
426426-- | Test that closing the same connection twice has no effect
427427testCloseTwice :: Transport -> Int -> IO ()
428−testCloseTwice transport numRepeats = do
428+testCloseTwice transport numRepeats = do
429429 server <- spawn transport echoServer
430430 clientDone <- newEmptyMVar
431431
@@ -436,11 +436,11 @@ testCloseTwice transport numRepeats = do
436436 -- We request two lightweight connections
437437 Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints
438438 Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints
439−
439+
440440 -- Close the second one twice
441441 close conn2
442442 close conn2
443−
443+
444444 -- Then send a message on the first and close that twice too
445445 send conn1 ["ping"]
446446 close conn1
@@ -449,11 +449,11 @@ testCloseTwice transport numRepeats = do
449449 ConnectionOpened cid1 _ _ <- receive endpoint
450450 ConnectionOpened cid2 _ _ <- receive endpoint
451451 ConnectionClosed cid2' <- receive endpoint ; True <- return $ cid2' == cid2
452− Received cid1' ["ping"] <- receive endpoint ; True <- return $ cid1' == cid1
452+ Received cid1' ["ping"] <- receive endpoint ; True <- return $ cid1' == cid1
453453 ConnectionClosed cid1'' <- receive endpoint ; True <- return $ cid1'' == cid1
454−
454+
455455 return ()
456−
456+
457457 putMVar clientDone ()
458458
459459 takeMVar clientDone
@@ -471,7 +471,7 @@ testConnectToSelf transport numPings = do
471471
472472 -- One thread to write to the endpoint
473473 forkTry $ do
474− tlog $ "writing"
474+ tlog $ "writing"
475475
476476 tlog $ "Sending ping"
477477 replicateM_ numPings $ send conn ["ping"]
@@ -513,17 +513,17 @@ testConnectToSelfTwice transport numPings = do
513513
514514 -- One thread to write to the endpoint using the first connection
515515 forkTry $ do
516− tlog $ "writing"
516+ tlog $ "writing"
517517
518518 tlog $ "Sending ping"
519519 replicateM_ numPings $ send conn1 ["pingA"]
520520
521521 tlog $ "Closing connection"
522522 close conn1
523−
523+
524524 -- One thread to write to the endpoint using the second connection
525525 forkTry $ do
526− tlog $ "writing"
526+ tlog $ "writing"
527527
528528 tlog $ "Sending ping"
529529 replicateM_ numPings $ send conn2 ["pingB"]
@@ -554,11 +554,11 @@ testCloseSelf newTransport = do
554554 Right conn1 <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints
555555 Right conn2 <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints
556556 Right conn3 <- connect endpoint2 (address endpoint2) ReliableOrdered defaultConnectHints
557−
557+
558558 -- Close the conneciton and try to send
559559 close conn1
560560 Left (TransportError SendClosed _) <- send conn1 ["ping"]
561−
561+
562562 -- Close the first endpoint. We should not be able to use the first
563563 -- connection anymore, or open more self connections, but the self connection
564564 -- to the second endpoint should still be fine
@@ -574,7 +574,7 @@ testCloseSelf newTransport = do
574574
575575 return ()
576576
577−-- | Test various aspects of 'closeEndPoint'
577+-- | Test various aspects of 'closeEndPoint'
578578testCloseEndPoint :: Transport -> Int -> IO ()
579579testCloseEndPoint transport _ = do
580580 serverDone <- newEmptyMVar
@@ -598,7 +598,7 @@ testCloseEndPoint transport _ = do
598598 -- Second test
599599 do
600600 theirAddr <- readMVar clientAddr2
601−
601+
602602 ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr
603603 Received cid' ["ping"] <- receive endpoint ; True <- return $ cid == cid'
604604
@@ -609,7 +609,7 @@ testCloseEndPoint transport _ = do
609609 ErrorEvent (TransportError (EventConnectionLost addr') _) <- receive endpoint ; True <- return $ addr' == theirAddr
610610
611611 Left (TransportError SendFailed _) <- send conn ["pong2"]
612−
612+
613613 return ()
614614
615615 putMVar serverDone ()
@@ -621,7 +621,7 @@ testCloseEndPoint transport _ = do
621621 -- First test: close endpoint with one outgoing but no incoming connections
622622 do
623623 Right endpoint <- newEndPoint transport
624− putMVar clientAddr1 (address endpoint)
624+ putMVar clientAddr1 (address endpoint)
625625
626626 -- Connect to the server, then close the endpoint without disconnecting explicitly
627627 Right _ <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
@@ -632,7 +632,7 @@ testCloseEndPoint transport _ = do
632632 -- Second test: close endpoint with one outgoing and one incoming connection
633633 do
634634 Right endpoint <- newEndPoint transport
635− putMVar clientAddr2 (address endpoint)
635+ putMVar clientAddr2 (address endpoint)
636636
637637 Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints
638638 send conn ["ping"]
@@ -641,7 +641,7 @@ testCloseEndPoint transport _ = do
641641 ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr
642642 Received cid' ["pong"] <- receive endpoint ; True <- return $ cid == cid'
643643
644− -- Close the endpoint
644+ -- Close the endpoint
645645 closeEndPoint endpoint
646646 EndPointClosed <- receive endpoint
647647
@@ -677,13 +677,13 @@ testCloseTransport newTransport = do
677677 Right endpoint <- newEndPoint transport
678678 putMVar serverAddr (address endpoint)
679679
680− -- Client sets up first endpoint
680+ -- Client sets up first endpoint
681681 theirAddr1 <- readMVar clientAddr1
682682 ConnectionOpened cid1 ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr1
683683
684− -- Client sets up second endpoint
684+ -- Client sets up second endpoint
685685 theirAddr2 <- readMVar clientAddr2
686−
686+
687687 ConnectionOpened cid2 ReliableOrdered addr' <- receive endpoint ; True <- return $ addr' == theirAddr2
688688 Received cid2' ["ping"] <- receive endpoint ; True <- return $ cid2' == cid2
689689
@@ -702,7 +702,7 @@ testCloseTransport newTransport = do
702702
703703 -- An attempt to send to the endpoint should now fail
704704 Left (TransportError SendFailed _) <- send conn ["pong2"]
705−
705+
706706 putMVar serverDone ()
707707
708708 -- Client
@@ -712,14 +712,14 @@ testCloseTransport newTransport = do
712712
713713 -- Set up endpoint with one outgoing but no incoming connections
714714 Right endpoint1 <- newEndPoint transport
715− putMVar clientAddr1 (address endpoint1)
715+ putMVar clientAddr1 (address endpoint1)
716716
717717 -- Connect to the server, then close the endpoint without disconnecting explicitly
718718 Right _ <- connect endpoint1 theirAddr ReliableOrdered defaultConnectHints
719719
720720 -- Set up an endpoint with one outgoing and out incoming connection
721721 Right endpoint2 <- newEndPoint transport
722− putMVar clientAddr2 (address endpoint2)
722+ putMVar clientAddr2 (address endpoint2)
723723
724724 Right conn <- connect endpoint2 theirAddr ReliableOrdered defaultConnectHints
725725 send conn ["ping"]
@@ -746,7 +746,7 @@ testCloseTransport newTransport = do
746746 Left (TransportError ConnectFailed _) <- connect endpoint2 theirAddr ReliableOrdered defaultConnectHints
747747
748748 -- And finally, so should an attempt to create a new endpoint
749− Left (TransportError NewEndPointFailed _) <- newEndPoint transport
749+ Left (TransportError NewEndPointFailed _) <- newEndPoint transport
750750
751751 putMVar clientDone ()
752752
@@ -758,7 +758,7 @@ testConnectClosedEndPoint transport = do
758758 serverAddr <- newEmptyMVar
759759 serverClosed <- newEmptyMVar
760760 clientDone <- newEmptyMVar
761−
761+
762762 -- Server
763763 forkTry $ do
764764 Right endpoint <- newEndPoint transport
@@ -770,12 +770,12 @@ testConnectClosedEndPoint transport = do
770770 -- Client
771771 forkTry $ do
772772 Right endpoint <- newEndPoint transport
773− readMVar serverClosed
773+ readMVar serverClosed
774774
775775 Left (TransportError ConnectNotFound _) <- readMVar serverAddr >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints
776776
777777 putMVar clientDone ()
778−
778+
779779 takeMVar clientDone
780780
781781-- | We should receive an exception when doing a 'receive' after we have been
@@ -783,7 +783,7 @@ testConnectClosedEndPoint transport = do
783783testExceptionOnReceive :: IO (Either String Transport) -> IO ()
784784testExceptionOnReceive newTransport = do
785785 Right transport <- newTransport
786−
786+
787787 -- Test one: when we close an endpoint specifically
788788 Right endpoint1 <- newEndPoint transport
789789 closeEndPoint endpoint1
@@ -804,7 +804,7 @@ testSendException newTransport = do
804804 Right transport <- newTransport
805805 Right endpoint1 <- newEndPoint transport
806806 Right endpoint2 <- newEndPoint transport
807−
807+
808808 -- Connect endpoint1 to endpoint2
809809 Right conn <- connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints
810810 ConnectionOpened _ _ _ <- receive endpoint2
@@ -814,7 +814,7 @@ testSendException newTransport = do
814814
815815 -- This will have been as a failure to send by endpoint1, which will
816816 -- therefore have closed the socket. In turn this will have caused endpoint2
817− -- to report that the connection was lost
817+ -- to report that the connection was lost
818818 ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint1
819819 ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint2
820820
@@ -831,27 +831,27 @@ testSendException newTransport = do
831831
832832-- | If threads get killed while executing a 'connect', 'send', or 'close', this
833833-- should not affect other threads.
834−--
834+--
835835-- The intention of this test is to see what happens when a asynchronous
836836-- exception happes _while executing a send_. This is exceedingly difficult to
837837-- guarantee, however. Hence we run a large number of tests and insert random
838838-- thread delays -- and even then it might not happen. Moreover, it will only
839−-- happen when we run on multiple cores.
839+-- happen when we run on multiple cores.
840840testKill :: IO (Either String Transport) -> Int -> IO ()
841841testKill newTransport numThreads = do
842842 Right transport1 <- newTransport
843843 Right transport2 <- newTransport
844844 Right endpoint1 <- newEndPoint transport1
845845 Right endpoint2 <- newEndPoint transport2
846−
847− threads <- replicateM numThreads . forkIO $ do
848− randomThreadDelay 100
846+
847+ threads <- replicateM numThreads . forkIO $ do
848+ randomThreadDelay 100
849849 bracket (connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints)
850− -- Note that we should not insert a randomThreadDelay into the
850+ -- Note that we should not insert a randomThreadDelay into the
851851 -- exception handler itself as this means that the exception handler
852852 -- could be interrupted and we might not close
853853 (\(Right conn) -> close conn)
854− (\(Right conn) -> do randomThreadDelay 100
854+ (\(Right conn) -> do randomThreadDelay 100
855855 Right () <- send conn ["ping"]
856856 randomThreadDelay 100)
857857
@@ -861,26 +861,26 @@ testKill newTransport numThreads = do
861861 forkIO . forM_ threads $ \tid -> do
862862 shouldKill <- randomIO
863863 if shouldKill
864− then randomThreadDelay 600 >> killThread tid
864+ then randomThreadDelay 600 >> killThread tid
865865 else modifyMVar_ numAlive (return . (+ 1))
866866
867867 -- Since it is impossible to predict when the kill exactly happens, we don't
868868 -- know how many connects were opened and how many pings were sent. But we
869869 -- should not have any open connections (if we do, collect will throw an
870870 -- error) and we should have at least the number of pings equal to the number
871− -- of threads we did *not* kill
872− eventss <- collect endpoint2 Nothing (Just 1000000)
871+ -- of threads we did *not* kill
872+ eventss <- collect endpoint2 Nothing (Just 1000000)
873873 let actualPings = sum . map (length . snd) $ eventss
874874 expectedPings <- takeMVar numAlive
875− unless (actualPings >= expectedPings) $
875+ unless (actualPings >= expectedPings) $
876876 throwIO (userError "Missing pings")
877−
877+
878878-- print (actualPings, expectedPings)
879879
880880
881881-- | Set up conditions with a high likelyhood of "crossing" (for transports
882882-- that multiplex lightweight connections across heavyweight connections)
883−testCrossing :: Transport -> Int -> IO ()
883+testCrossing :: Transport -> Int -> IO ()
884884testCrossing transport numRepeats = do
885885 [aAddr, bAddr] <- replicateM 2 newEmptyMVar
886886 [aDone, bDone] <- replicateM 2 newEmptyMVar
@@ -902,10 +902,10 @@ testCrossing transport numRepeats = do
902902 -- Because we are creating lots of connections, it's possible that
903903 -- connect times out (for instance, in the TCP transport,
904904 -- Network.Socket.connect may time out). We shouldn't regard this as an
905− -- error in the Transport, though.
905+ -- error in the Transport, though.
906906 connectResult <- connect endpoint theirAddress ReliableOrdered hints
907907 case connectResult of
908− Right conn -> close conn
908+ Right conn -> close conn
909909 Left (TransportError ConnectTimeout _) -> putMVar aTimeout ()
910910 Left (TransportError ConnectFailed _) -> readMVar bTimeout
911911 Left err -> throwIO . userError $ "testCrossed: " ++ show err
@@ -916,23 +916,23 @@ testCrossing transport numRepeats = do
916916 Right endpoint <- newEndPoint transport
917917 putMVar bAddr (address endpoint)
918918 theirAddress <- readMVar aAddr
919−
919+
920920 replicateM_ numRepeats $ do
921921 takeMVar bGo >> yield
922922 connectResult <- connect endpoint theirAddress ReliableOrdered hints
923923 case connectResult of
924− Right conn -> close conn
925− Left (TransportError ConnectTimeout _) -> putMVar bTimeout ()
924+ Right conn -> close conn
925+ Left (TransportError ConnectTimeout _) -> putMVar bTimeout ()
926926 Left (TransportError ConnectFailed _) -> readMVar aTimeout
927927 Left err -> throwIO . userError $ "testCrossed: " ++ show err
928928 putMVar bDone ()
929−
929+
930930 -- Driver
931931 forM_ [1 .. numRepeats] $ \_i -> do
932932 -- putStrLn $ "Round " ++ show _i
933933 tryTakeMVar aTimeout
934934 tryTakeMVar bTimeout
935− b <- randomIO
935+ b <- randomIO
936936 if b then do putMVar aGo () ; putMVar bGo ()
937937 else do putMVar bGo () ; putMVar aGo ()
938938 yield
@@ -954,14 +954,14 @@ testTransport newTransport = do
954954 , ("SendAfterClose", testSendAfterClose transport 100)
955955 , ("Crossing", testCrossing transport 10)
956956 , ("CloseTwice", testCloseTwice transport 100)
957− , ("ConnectToSelf", testConnectToSelf transport numPings)
957+ , ("ConnectToSelf", testConnectToSelf transport numPings)
958958 , ("ConnectToSelfTwice", testConnectToSelfTwice transport numPings)
959959 , ("CloseSelf", testCloseSelf newTransport)
960− , ("CloseEndPoint", testCloseEndPoint transport numPings)
960+ , ("CloseEndPoint", testCloseEndPoint transport numPings)
961961 , ("CloseTransport", testCloseTransport newTransport)
962962 , ("ConnectClosedEndPoint", testConnectClosedEndPoint transport)
963963 , ("ExceptionOnReceive", testExceptionOnReceive newTransport)
964− , ("SendException", testSendException newTransport)
964+ , ("SendException", testSendException newTransport)
965965 , ("Kill", testKill newTransport 1000)
966966 ]
967967 where
network-transport-tests/src/Network/Transport/Tests/Auxiliary.hs+14−14
@@ -30,7 +30,7 @@ import Network.Transport
3030import Network.Transport.Tests.Traced (Traceable(..), traceShow)
3131
3232-- | Like fork, but throw exceptions in the child thread to the parent
33−forkTry :: IO () -> IO ThreadId
33+forkTry :: IO () -> IO ThreadId
3434forkTry p = do
3535 tid <- myThreadId
3636 forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
@@ -40,17 +40,17 @@ trySome :: IO a -> IO (Either SomeException a)
4040trySome = try
4141
4242-- | Run the given test, catching timeouts and exceptions
43−runTest :: String -> IO () -> IO Bool
43+runTest :: String -> IO () -> IO Bool
4444runTest description test = do
4545 putStr $ "Running " ++ show description ++ ": "
4646 hFlush stdout
4747 done <- try . timeout 60000000 $ test -- 60 seconds
4848 case done of
49− Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")"
49+ Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")"
5050 Right Nothing -> failed $ "(timeout)"
51− Right (Just ()) -> ok
51+ Right (Just ()) -> ok
5252 where
53− failed :: String -> IO Bool
53+ failed :: String -> IO Bool
5454 failed err = do
5555 setSGR [SetColor Foreground Vivid Red]
5656 putStr "failed "
@@ -58,43 +58,43 @@ runTest description test = do
5858 putStrLn err
5959 return False
6060
61− ok :: IO Bool
61+ ok :: IO Bool
6262 ok = do
6363 setSGR [SetColor Foreground Vivid Green]
6464 putStrLn "ok"
6565 setSGR [Reset]
6666 return True
6767
68−-- | Run a bunch of tests and throw an exception if any fails
68+-- | Run a bunch of tests and throw an exception if any fails
6969runTests :: [(String, IO ())] -> IO ()
7070runTests tests = do
7171 success <- foldr (liftM2 (&&) . uncurry runTest) (return True) $ tests
7272 unless success $ fail "Some tests failed"
7373
74−-- | Random thread delay between 0 and the specified max
74+-- | Random thread delay between 0 and the specified max
7575randomThreadDelay :: Int -> IO ()
7676randomThreadDelay maxDelay = do
7777 delay <- randomIO :: IO Int
78− threadDelay (delay `mod` maxDelay)
78+ threadDelay (delay `mod` maxDelay)
7979
8080--------------------------------------------------------------------------------
81−-- traceShow instances --
81+-- traceShow instances --
8282--------------------------------------------------------------------------------
8383
8484instance Traceable EndPoint where
8585 trace = const Nothing
8686
8787instance Traceable Transport where
88− trace = const Nothing
88+ trace = const Nothing
8989
9090instance Traceable Connection where
91− trace = const Nothing
91+ trace = const Nothing
9292
9393instance Traceable Event where
94− trace = traceShow
94+ trace = traceShow
9595
9696instance Show err => Traceable (TransportError err) where
97− trace = traceShow
97+ trace = traceShow
9898
9999instance Traceable EndPointAddress where
100100 trace = traceShow . endPointAddressToByteString
network-transport-tests/src/Network/Transport/Tests/Multicast.hs+15−15
@@ -10,10 +10,10 @@ import Network.Transport.Tests.Auxiliary (runTests)
1010
1111-- | Node for the "No confusion" test
1212noConfusionNode :: Transport -- ^ Transport
13− -> [MVar MulticastAddress] -- ^ my group : groups to subscribe to
13+ -> [MVar MulticastAddress] -- ^ my group : groups to subscribe to
1414 -> [MVar ()] -- ^ I'm ready : others ready
1515 -> Int -- ^ number of pings
16− -> [ByteString] -- ^ my message : messages from subscribed groups (same order as 'groups to subscribe to')
16+ -> [ByteString] -- ^ my message : messages from subscribed groups (same order as 'groups to subscribe to')
1717 -> MVar () -- ^ I'm done
1818 -> IO ()
1919noConfusionNode transport groups ready numPings msgs done = do
@@ -25,8 +25,8 @@ noConfusionNode transport groups ready numPings msgs done = do
2525 putMVar (head groups) (multicastAddress myGroup)
2626
2727 -- Subscribe to the given multicast groups
28− addrs <- mapM readMVar (tail groups)
29− forM_ addrs $ \addr -> do Right group <- resolveMulticastGroup endpoint addr
28+ addrs <- mapM readMVar (tail groups)
29+ forM_ addrs $ \addr -> do Right group <- resolveMulticastGroup endpoint addr
3030 multicastSubscribe group
3131
3232 -- Indicate that we're ready and wait for everybody else to be ready
@@ -42,31 +42,31 @@ noConfusionNode transport groups ready numPings msgs done = do
4242 case event of
4343 ReceivedMulticast addr [msg] ->
4444 let mix = addr `elemIndex` addrs in
45− case mix of
45+ case mix of
4646 Nothing -> error "Message from unexpected source"
4747 Just ix -> when (msgs !! (ix + 1) /= msg) $ error "Unexpected message"
4848 _ ->
4949 error "Unexpected event"
5050
5151 -- Success
52− putMVar done ()
52+ putMVar done ()
5353
5454-- | Test that distinct multicast groups are not confused
55−testNoConfusion :: Transport -> Int -> IO ()
55+testNoConfusion :: Transport -> Int -> IO ()
5656testNoConfusion transport numPings = do
5757 [group1, group2, group3] <- replicateM 3 newEmptyMVar
5858 [readyA, readyB, readyC] <- replicateM 3 newEmptyMVar
5959 [doneA, doneB, doneC] <- replicateM 3 newEmptyMVar
6060 let [msgA, msgB, msgC] = ["A says hi", "B says hi", "C says hi"]
6161
62− forkIO $ noConfusionNode transport [group1, group1, group2] [readyA, readyB, readyC] numPings [msgA, msgA, msgB] doneA
63− forkIO $ noConfusionNode transport [group2, group1, group3] [readyB, readyC, readyA] numPings [msgB, msgA, msgC] doneB
64− forkIO $ noConfusionNode transport [group3, group2, group3] [readyC, readyA, readyB] numPings [msgC, msgB, msgC] doneC
65−
66− mapM_ takeMVar [doneA, doneB, doneC]
62+ forkIO $ noConfusionNode transport [group1, group1, group2] [readyA, readyB, readyC] numPings [msgA, msgA, msgB] doneA
63+ forkIO $ noConfusionNode transport [group2, group1, group3] [readyB, readyC, readyA] numPings [msgB, msgA, msgC] doneB
64+ forkIO $ noConfusionNode transport [group3, group2, group3] [readyC, readyA, readyB] numPings [msgC, msgB, msgC] doneC
65+
66+ mapM_ takeMVar [doneA, doneB, doneC]
6767
6868-- | Test multicast
69−testMulticast :: Transport -> IO ()
70−testMulticast transport =
71− runTests
69+testMulticast :: Transport -> IO ()
70+testMulticast transport =
71+ runTests
7272 [ ("NoConfusion", testNoConfusion transport 10000) ]
network-transport-tests/src/Network/Transport/Tests/Traced.hs+31−31
@@ -1,7 +1,7 @@
1−-- | Add tracing to the IO monad (see examples).
2−--
1+-- | Add tracing to the IO monad (see examples).
2+--
33-- [Usage]
4−--
4+--
55-- > {-# LANGUAGE RebindableSyntax #-}
66-- > import Prelude hiding (catch, (>>=), (>>), return, fail)
77-- > import Traced
@@ -15,7 +15,7 @@
1515-- > Right y <- return (Left 2 :: Either Int Int)
1616-- > return (x + y)
1717--
18−-- outputs
18+-- outputs
1919--
2020-- > Hello world
2121-- > *** Exception: user error (Pattern match failure in do expression at Traced.hs:187:3-9)
@@ -31,7 +31,7 @@
3131-- > test2 = do
3232-- > Left x <- return (Left 1 :: Either Int Int)
3333-- > True <- return (x == 3)
34−-- > return x
34+-- > return x
3535--
3636-- The advantage of this idiom is that it gives you line number information when the guard fails:
3737--
@@ -39,7 +39,7 @@
3939-- > *** Exception: user error (Pattern match failure in do expression at Traced.hs:193:3-6)
4040-- > Trace:
4141-- > 0 Left 1
42−module Network.Transport.Tests.Traced
42+module Network.Transport.Tests.Traced
4343 ( MonadS(..)
4444 , return
4545 , (>>=)
@@ -51,7 +51,7 @@ module Network.Transport.Tests.Traced
5151 , traceShow
5252 ) where
5353
54−import Prelude hiding
54+import Prelude hiding
5555 ( (>>=)
5656 , return
5757 , fail
@@ -76,12 +76,12 @@ import Control.Concurrent.MVar (MVar)
7676
7777-- | Like 'Monad' but bind is only defined for 'Trace'able instances
7878class MonadS m where
79− returnS :: a -> m a
79+ returnS :: a -> m a
8080 bindS :: Traceable a => m a -> (a -> m b) -> m b
8181 failS :: String -> m a
8282 seqS :: m a -> m b -> m b
8383
84−-- | Redefinition of 'Prelude.>>='
84+-- | Redefinition of 'Prelude.>>='
8585(>>=) :: (MonadS m, Traceable a) => m a -> (a -> m b) -> m b
8686(>>=) = bindS
8787
@@ -95,7 +95,7 @@ return = returnS
9595
9696-- | Redefinition of 'Prelude.fail'
9797fail :: MonadS m => String -> m a
98−fail = failS
98+fail = failS
9999
100100--------------------------------------------------------------------------------
101101-- Trace typeclass (for adding elements to a trace --
@@ -106,17 +106,17 @@ data Showable = forall a. Show a => Showable a
106106instance Show Showable where
107107 show (Showable x) = show x
108108
109−mapShowable :: (forall a. Show a => a -> Showable) -> Showable -> Showable
110−mapShowable f (Showable x) = f x
109+mapShowable :: (forall a. Show a => a -> Showable) -> Showable -> Showable
110+mapShowable f (Showable x) = f x
111111
112112traceShow :: Show a => a -> Maybe Showable
113−traceShow = Just . Showable
113+traceShow = Just . Showable
114114
115115class Traceable a where
116− trace :: a -> Maybe Showable
116+ trace :: a -> Maybe Showable
117117
118118instance (Traceable a, Traceable b) => Traceable (Either a b) where
119− trace (Left x) = (mapShowable $ Showable . (Left :: forall c. c -> Either c ())) <$> trace x
119+ trace (Left x) = (mapShowable $ Showable . (Left :: forall c. c -> Either c ())) <$> trace x
120120 trace (Right y) = (mapShowable $ Showable . (Right :: forall c. c -> Either () c)) <$> trace y
121121
122122instance (Traceable a, Traceable b) => Traceable (a, b) where
@@ -128,7 +128,7 @@ instance (Traceable a, Traceable b) => Traceable (a, b) where
128128
129129instance (Traceable a, Traceable b, Traceable c) => Traceable (a, b, c) where
130130 trace (x, y, z) = case (trace x, trace y, trace z) of
131− (Nothing, Nothing, Nothing) -> Nothing
131+ (Nothing, Nothing, Nothing) -> Nothing
132132 (Just t1, Nothing, Nothing) -> traceShow t1
133133 (Nothing, Just t2, Nothing) -> traceShow t2
134134 (Just t1, Just t2, Nothing) -> traceShow (t1, t2)
@@ -139,40 +139,40 @@ instance (Traceable a, Traceable b, Traceable c) => Traceable (a, b, c) where
139139
140140instance Traceable a => Traceable (Maybe a) where
141141 trace Nothing = traceShow (Nothing :: Maybe ())
142− trace (Just x) = mapShowable (Showable . Just) <$> trace x
142+ trace (Just x) = mapShowable (Showable . Just) <$> trace x
143143
144144instance Traceable a => Traceable [a] where
145− trace = traceShow . catMaybes . map trace
145+ trace = traceShow . catMaybes . map trace
146146
147147instance Traceable () where
148− trace = const Nothing
148+ trace = const Nothing
149149
150150instance Traceable Int where
151− trace = traceShow
151+ trace = traceShow
152152
153153instance Traceable Int32 where
154− trace = traceShow
154+ trace = traceShow
155155
156156instance Traceable Int64 where
157− trace = traceShow
157+ trace = traceShow
158158
159159instance Traceable Word32 where
160− trace = traceShow
160+ trace = traceShow
161161
162162instance Traceable Word64 where
163− trace = traceShow
163+ trace = traceShow
164164
165165instance Traceable Bool where
166− trace = const Nothing
166+ trace = const Nothing
167167
168168instance Traceable ByteString where
169− trace = traceShow
169+ trace = traceShow
170170
171171instance Traceable (MVar a) where
172− trace = const Nothing
172+ trace = const Nothing
173173
174174instance Traceable [Char] where
175− trace = traceShow
175+ trace = traceShow
176176
177177instance Traceable IOException where
178178 trace = traceShow
@@ -186,7 +186,7 @@ data TracedException = TracedException [String] SomeException
186186
187187instance Exception TracedException
188188
189−-- | Add tracing to 'IO' (see examples)
189+-- | Add tracing to 'IO' (see examples)
190190instance MonadS IO where
191191 returnS = Prelude.return
192192 bindS = \x f -> x Prelude.>>= \a -> catches (f a) (traceHandlers a)
@@ -194,7 +194,7 @@ instance MonadS IO where
194194 seqS = (Prelude.>>)
195195
196196instance Show TracedException where
197− show (TracedException ts ex) =
197+ show (TracedException ts ex) =
198198 show ex ++ "\nTrace:\n" ++ unlines (map (\(i, t) -> show i ++ "\t" ++ t) (zip ([0..] :: [Int]) (take 10 . reverse $ ts)))
199199
200200traceHandlers :: Traceable a => a -> [Handler b]
@@ -204,7 +204,7 @@ traceHandlers a = case trace a of
204204 , Handler $ \ex -> throwIO $ TracedException [show t] (ex :: SomeException)
205205 ]
206206
207−-- | Definition of 'ifThenElse' for use with RebindableSyntax
207+-- | Definition of 'ifThenElse' for use with RebindableSyntax
208208ifThenElse :: Bool -> a -> a -> a
209209ifThenElse True x _ = x
210210ifThenElse False _ y = y
network-transport/src/Network/Transport.hs+36−36
@@ -1,5 +1,5 @@
1−-- | Network Transport
2−module Network.Transport
1+-- | Network Transport
2+module Network.Transport
33 ( -- * Types
44 Transport(..)
55 , EndPoint(..)
@@ -41,8 +41,8 @@ import Data.Word (Word64)
4141data Transport = Transport {
4242 -- | Create a new end point (heavyweight operation)
4343 newEndPoint :: IO (Either (TransportError NewEndPointErrorCode) EndPoint)
44− -- | Shutdown the transport completely
45− , closeTransport :: IO ()
44+ -- | Shutdown the transport completely
45+ , closeTransport :: IO ()
4646 }
4747
4848-- | Network endpoint.
@@ -50,8 +50,8 @@ data EndPoint = EndPoint {
5050 -- | Endpoints have a single shared receive queue.
5151 receive :: IO Event
5252 -- | EndPointAddress of the endpoint.
53− , address :: EndPointAddress
54− -- | Create a new lightweight connection.
53+ , address :: EndPointAddress
54+ -- | Create a new lightweight connection.
5555 --
5656 -- 'connect' should be as asynchronous as possible; for instance, in
5757 -- Transport implementations based on some heavy-weight underlying network
@@ -64,12 +64,12 @@ data EndPoint = EndPoint {
6464 , resolveMulticastGroup :: MulticastAddress -> IO (Either (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
6565 -- | Close the endpoint
6666 , closeEndPoint :: IO ()
67− }
67+ }
6868
6969-- | Lightweight connection to an endpoint.
7070data Connection = Connection {
7171 -- | Send a message on this connection.
72− --
72+ --
7373 -- 'send' provides vectored I/O, and allows multiple data segments to be
7474 -- sent using a single call (cf. 'Network.Socket.ByteString.sendMany').
7575 -- Note that this segment structure is entirely unrelated to the segment
@@ -80,7 +80,7 @@ data Connection = Connection {
8080 }
8181
8282-- | Event on an endpoint.
83−data Event =
83+data Event =
8484 -- | Received a message
8585 Received {-# UNPACK #-} !ConnectionId [ByteString]
8686 -- | Connection closed
@@ -88,33 +88,33 @@ data Event =
8888 -- | Connection opened
8989 --
9090 -- 'ConnectionId's need not be allocated contiguously.
91− | ConnectionOpened {-# UNPACK #-} !ConnectionId Reliability EndPointAddress
91+ | ConnectionOpened {-# UNPACK #-} !ConnectionId Reliability EndPointAddress
9292 -- | Received multicast
9393 | ReceivedMulticast MulticastAddress [ByteString]
9494 -- | The endpoint got closed (manually, by a call to closeEndPoint or closeTransport)
9595 | EndPointClosed
96− -- | An error occurred
97− | ErrorEvent (TransportError EventErrorCode)
96+ -- | An error occurred
97+ | ErrorEvent (TransportError EventErrorCode)
9898 deriving (Show, Eq)
9999
100100-- | Connection data ConnectHintsIDs enable receivers to distinguish one connection from another.
101−type ConnectionId = Word64
101+type ConnectionId = Word64
102102
103103-- | Reliability guarantees of a connection.
104−data Reliability =
105− ReliableOrdered
106− | ReliableUnordered
104+data Reliability =
105+ ReliableOrdered
106+ | ReliableUnordered
107107 | Unreliable
108108 deriving (Show, Eq)
109109
110110-- | Multicast group.
111111data MulticastGroup = MulticastGroup {
112− -- | EndPointAddress of the multicast group.
112+ -- | EndPointAddress of the multicast group.
113113 multicastAddress :: MulticastAddress
114114 -- | Delete the multicast group completely.
115115 , deleteMulticastGroup :: IO ()
116116 -- | Maximum message size that we can send to this group.
117− , maxMsgSize :: Maybe Int
117+ , maxMsgSize :: Maybe Int
118118 -- | Send a message to the group.
119119 , multicastSend :: [ByteString] -> IO ()
120120 -- | Subscribe to the given multicast group (to start receiving messages from the group).
@@ -172,13 +172,13 @@ defaultConnectHints = ConnectHints {
172172--------------------------------------------------------------------------------
173173
174174-- | Errors returned by Network.Transport API functions consist of an error
175−-- code and a human readable description of the problem
175+-- code and a human readable description of the problem
176176data TransportError error = TransportError error String
177177 deriving (Show, Typeable)
178178
179179-- | Although the functions in the transport API never throw TransportErrors
180180-- (but return them explicitly), application code may want to turn these into
181−-- exceptions.
181+-- exceptions.
182182instance (Typeable err, Show err) => Exception (TransportError err)
183183
184184-- | When comparing errors we ignore the human-readable strings
@@ -190,19 +190,19 @@ data NewEndPointErrorCode =
190190 -- | Not enough resources
191191 NewEndPointInsufficientResources
192192 -- | Failed for some other reason
193− | NewEndPointFailed
193+ | NewEndPointFailed
194194 deriving (Show, Typeable, Eq)
195195
196−-- | Connection failure
197−data ConnectErrorCode =
198− -- | Could not resolve the address
196+-- | Connection failure
197+data ConnectErrorCode =
198+ -- | Could not resolve the address
199199 ConnectNotFound
200200 -- | Insufficient resources (for instance, no more sockets available)
201− | ConnectInsufficientResources
201+ | ConnectInsufficientResources
202202 -- | Timeout
203203 | ConnectTimeout
204204 -- | Failed for other reasons (including syntax error)
205− | ConnectFailed
205+ | ConnectFailed
206206 deriving (Show, Typeable, Eq)
207207
208208-- | Failure during the creation of a new multicast group
@@ -221,7 +221,7 @@ data ResolveMulticastGroupErrorCode =
221221 ResolveMulticastGroupNotFound
222222 -- | Failed for some other reason (including syntax error)
223223 | ResolveMulticastGroupFailed
224− -- | Not all transport implementations support multicast
224+ -- | Not all transport implementations support multicast
225225 | ResolveMulticastGroupUnsupported
226226 deriving (Show, Typeable, Eq)
227227
@@ -230,12 +230,12 @@ data SendErrorCode =
230230 -- | Connection was closed
231231 SendClosed
232232 -- | Send failed for some other reason
233− | SendFailed
233+ | SendFailed
234234 deriving (Show, Typeable, Eq)
235235
236236-- | Error codes used when reporting errors to endpoints (through receive)
237−data EventErrorCode =
238− -- | Failure of the entire endpoint
237+data EventErrorCode =
238+ -- | Failure of the entire endpoint
239239 EventEndPointFailed
240240 -- | Transport-wide fatal error
241241 | EventTransportFailed
@@ -247,27 +247,27 @@ data EventErrorCode =
247247 -- both directions, must now be considered to have failed; they fail as a
248248 -- "bundle" of connections, with only a single "bundle" of connections per
249249 -- endpoint at any point in time.
250− --
250+ --
251251 -- That is, suppose there are multiple connections in either direction
252252 -- between endpoints A and B, and A receives a notification that it has
253253 -- lost contact with B. Then A must not be able to send any further
254− -- messages to B on existing connections.
254+ -- messages to B on existing connections.
255255 --
256256 -- Although B may not realize /immediately/ that its connection to A has
257257 -- been broken, messages sent by B on existing connections should not be
258258 -- delivered, and B must eventually get an EventConnectionLost message,
259− -- too.
259+ -- too.
260260 --
261261 -- Moreover, this event must be posted before A has successfully
262262 -- reconnected (in other words, if B notices a reconnection attempt from A,
263263 -- it must post the EventConnectionLost before acknowledging the connection
264264 -- from A) so that B will not receive events about new connections or
265− -- incoming messages from A without realizing that it got disconnected.
266− --
265+ -- incoming messages from A without realizing that it got disconnected.
266+ --
267267 -- If B attempts to establish another connection to A before it realized
268268 -- that it got disconnected from A then it's okay for this connection
269269 -- attempt to fail, and the EventConnectionLost to be posted at that point,
270270 -- or for the EventConnectionLost to be posted and for the new connection
271271 -- to be considered the first connection of the "new bundle".
272− | EventConnectionLost EndPointAddress
272+ | EventConnectionLost EndPointAddress
273273 deriving (Show, Typeable, Eq)
network-transport/src/Network/Transport/Internal.hs+26−26
@@ -1,5 +1,5 @@
11-- | Internal functions
2−module Network.Transport.Internal
2+module Network.Transport.Internal
33 ( -- * Encoders/decoders
44 encodeInt32
55 , decodeInt32
@@ -28,13 +28,13 @@ import Foreign.C (CInt(..), CShort(..))
2828import Foreign.ForeignPtr (withForeignPtr)
2929import Data.ByteString (ByteString)
3030import qualified Data.ByteString as BS (length)
31−import qualified Data.ByteString.Internal as BSI
31+import qualified Data.ByteString.Internal as BSI
3232 ( unsafeCreate
3333 , toForeignPtr
3434 , inlinePerformIO
3535 )
3636import Control.Monad.IO.Class (MonadIO, liftIO)
37−import Control.Exception
37+import Control.Exception
3838 ( IOException
3939 , SomeException
4040 , AsyncException
@@ -56,36 +56,36 @@ foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt
5656foreign import ccall unsafe "htons" htons :: CShort -> CShort
5757foreign import ccall unsafe "ntohs" ntohs :: CShort -> CShort
5858
59−-- | Serialize 32-bit to network byte order
59+-- | Serialize 32-bit to network byte order
6060encodeInt32 :: Enum a => a -> ByteString
61−encodeInt32 i32 =
61+encodeInt32 i32 =
6262 BSI.unsafeCreate 4 $ \p ->
6363 pokeByteOff p 0 (htonl . fromIntegral . fromEnum $ i32)
6464
65−-- | Deserialize 32-bit from network byte order
65+-- | Deserialize 32-bit from network byte order
6666-- Throws an IO exception if this is not a valid integer.
67−decodeInt32 :: Num a => ByteString -> a
68−decodeInt32 bs
69− | BS.length bs /= 4 = throw $ userError "decodeInt32: Invalid length"
70− | otherwise = BSI.inlinePerformIO $ do
71− let (fp, offset, _) = BSI.toForeignPtr bs
67+decodeInt32 :: Num a => ByteString -> a
68+decodeInt32 bs
69+ | BS.length bs /= 4 = throw $ userError "decodeInt32: Invalid length"
70+ | otherwise = BSI.inlinePerformIO $ do
71+ let (fp, offset, _) = BSI.toForeignPtr bs
7272 withForeignPtr fp $ \p -> do
73− w32 <- peekByteOff p offset
73+ w32 <- peekByteOff p offset
7474 return (fromIntegral . ntohl $ w32)
7575
76−-- | Serialize 16-bit to network byte order
77−encodeInt16 :: Enum a => a -> ByteString
78−encodeInt16 i16 =
76+-- | Serialize 16-bit to network byte order
77+encodeInt16 :: Enum a => a -> ByteString
78+encodeInt16 i16 =
7979 BSI.unsafeCreate 2 $ \p ->
8080 pokeByteOff p 0 (htons . fromIntegral . fromEnum $ i16)
8181
82−-- | Deserialize 16-bit from network byte order
82+-- | Deserialize 16-bit from network byte order
8383-- Throws an IO exception if this is not a valid integer
8484decodeInt16 :: Num a => ByteString -> a
85−decodeInt16 bs
86− | BS.length bs /= 2 = throw $ userError "decodeInt16: Invalid length"
85+decodeInt16 bs
86+ | BS.length bs /= 2 = throw $ userError "decodeInt16: Invalid length"
8787 | otherwise = BSI.inlinePerformIO $ do
88− let (fp, offset, _) = BSI.toForeignPtr bs
88+ let (fp, offset, _) = BSI.toForeignPtr bs
8989 withForeignPtr fp $ \p -> do
9090 w16 <- peekByteOff p offset
9191 return (fromIntegral . ntohs $ w16)
@@ -120,17 +120,17 @@ forkIOWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
120120forkIOWithUnmask io = forkIO (io unsafeUnmask)
121121
122122-- | Safe version of 'toEnum'
123−tryToEnum :: (Enum a, Bounded a) => Int -> Maybe a
123+tryToEnum :: (Enum a, Bounded a) => Int -> Maybe a
124124tryToEnum = go minBound maxBound
125125 where
126126 go :: Enum b => b -> b -> Int -> Maybe b
127− go lo hi n = if fromEnum lo <= n && n <= fromEnum hi then Just (toEnum n) else Nothing
127+ go lo hi n = if fromEnum lo <= n && n <= fromEnum hi then Just (toEnum n) else Nothing
128128
129129-- | If the timeout value is not Nothing, wrap the given computation with a
130130-- timeout and it if times out throw the specified exception. Identity
131131-- otherwise.
132132timeoutMaybe :: Exception e => Maybe Int -> e -> IO a -> IO a
133−timeoutMaybe Nothing _ f = f
133+timeoutMaybe Nothing _ f = f
134134timeoutMaybe (Just n) e f = do
135135 ma <- timeout n f
136136 case ma of
@@ -138,19 +138,19 @@ timeoutMaybe (Just n) e f = do
138138 Just a -> return a
139139
140140-- | @asyncWhenCancelled g f@ runs f in a separate thread and waits for it
141−-- to complete. If f throws an exception we catch it and rethrow it in the
141+-- to complete. If f throws an exception we catch it and rethrow it in the
142142-- current thread. If the current thread is interrupted before f completes,
143143-- we run the specified clean up handler (if f throws an exception we assume
144144-- that no cleanup is necessary).
145145asyncWhenCancelled :: forall a. (a -> IO ()) -> IO a -> IO a
146146asyncWhenCancelled g f = mask_ $ do
147147 mvar <- newEmptyMVar
148− forkIO $ try f >>= putMVar mvar
148+ forkIO $ try f >>= putMVar mvar
149149 -- takeMVar is interruptible (even inside a mask_)
150150 catch (takeMVar mvar) (exceptionHandler mvar) >>= either throwIO return
151151 where
152− exceptionHandler :: MVar (Either SomeException a)
153− -> AsyncException
152+ exceptionHandler :: MVar (Either SomeException a)
153+ -> AsyncException
154154 -> IO (Either SomeException a)
155155 exceptionHandler mvar ex = do
156156 forkIO $ takeMVar mvar >>= either (const $ return ()) g
network-transport/src/Network/Transport/Util.hs+5−5
@@ -1,9 +1,9 @@
1−-- | Utility functions
2−--
1+-- | Utility functions
2+--
33-- Note: this module is bound to change even more than the rest of the API :)
44module Network.Transport.Util (spawn) where
55
6−import Network.Transport
6+import Network.Transport
77 ( Transport
88 , EndPoint(..)
99 , EndPointAddress
@@ -14,9 +14,9 @@ import Control.Concurrent (forkIO)
1414import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
1515
1616-- | Fork a new thread, create a new end point on that thread, and run the specified IO operation on that thread.
17−--
17+--
1818-- Returns the address of the new end point.
19−spawn :: Transport -> (EndPoint -> IO ()) -> IO EndPointAddress
19+spawn :: Transport -> (EndPoint -> IO ()) -> IO EndPointAddress
2020spawn transport proc = do
2121 addrMVar <- newEmptyMVar
2222 forkIO $ do
network-transport/tests/chat/ChatClient.hs+13−13
@@ -12,7 +12,7 @@ import qualified Data.Map as Map (fromList, elems, insert, member, empty, size,
1212chatClient :: MVar () -> EndPoint -> EndPointAddress -> IO ()
1313chatClient done endpoint serverAddr = do
1414 connect endpoint serverAddr ReliableOrdered
15− cOut <- getPeers >>= connectToPeers
15+ cOut <- getPeers >>= connectToPeers
1616 cIn <- newMVar Map.empty
1717
1818 -- Listen for incoming messages
@@ -20,11 +20,11 @@ chatClient done endpoint serverAddr = do
2020 event <- receive endpoint
2121 case event of
2222 Received _ msg ->
23− putStrLn . BSC.unpack . BS.concat $ msg
23+ putStrLn . BSC.unpack . BS.concat $ msg
2424 ConnectionOpened cid _ addr -> do
2525 modifyMVar_ cIn $ return . Map.insert cid addr
2626 didAdd <- modifyMVar cOut $ \conns ->
27− if not (Map.member addr conns)
27+ if not (Map.member addr conns)
2828 then do
2929 Right conn <- connect endpoint addr ReliableOrdered
3030 return (Map.insert addr conn conns, True)
@@ -43,24 +43,24 @@ chatClient done endpoint serverAddr = do
4343
4444{-
4545 chatState <- newMVar (Map.fromList peerConns)
46−
46+
4747 -- Thread to listen to incoming messages
4848 forkIO . forever $ do
49− event <- receive endpoint
49+ event <- receive endpoint
5050 case event of
5151 ConnectionOpened _ _ (EndPointAddress addr) -> do
52− modifyMVar_ chatState $ \peers ->
52+ modifyMVar_ chatState $ \peers ->
5353 if not (Map.member addr peers)
5454 then do
55− Right conn <- connect endpoint (EndPointAddress addr) ReliableOrdered
55+ Right conn <- connect endpoint (EndPointAddress addr) ReliableOrdered
5656 return (Map.insert addr conn peers)
5757 else
5858 return peers
5959 Received _ msg ->
60− putStrLn . BSC.unpack . BS.concat $ msg
60+ putStrLn . BSC.unpack . BS.concat $ msg
6161 ConnectionClosed _ ->
6262 return ()
63−
63+
6464-}
6565 -- Thread to interact with the user
6666 showNumPeers cOut
@@ -74,7 +74,7 @@ chatClient done endpoint serverAddr = do
7474
7575 where
7676 getPeers :: IO [EndPointAddress]
77− getPeers = do
77+ getPeers = do
7878 ConnectionOpened _ _ _ <- receive endpoint
7979 Received _ msg <- receive endpoint
8080 ConnectionClosed _ <- receive endpoint
@@ -86,11 +86,11 @@ chatClient done endpoint serverAddr = do
8686 Right conn <- connect endpoint addr ReliableOrdered
8787 return (addr, conn)
8888 newMVar (Map.fromList conns)
89−
89+
9090 showNumPeers :: MVar (Map EndPointAddress Connection) -> IO ()
91− showNumPeers cOut =
91+ showNumPeers cOut =
9292 readMVar cOut >>= \conns -> putStrLn $ "# " ++ show (Map.size conns) ++ " peers"
93−
93+
9494
9595
9696
network-transport/tests/chat/ChatServer.hs+1−1
@@ -23,6 +23,6 @@ main = do
2323 Right conn <- connect endpoint addr ReliableOrdered
2424 send conn [BSC.pack . show . IntMap.elems $ clients]
2525 close conn
26− modify $ IntMap.insert cid (endPointAddressToByteString addr)
26+ modify $ IntMap.insert cid (endPointAddressToByteString addr)
2727 ConnectionClosed cid ->
2828 modify $ IntMap.delete cid
network-transport/tests/sumeuler/SumEulerMaster.hs+4−4
@@ -11,7 +11,7 @@ import Control.Monad.IO.Class (liftIO)
1111
1212master :: MVar () -> EndPoint -> [String] -> IO ()
1313master done endpoint workers = do
14− conns <- forM workers $ \worker -> do
14+ conns <- forM workers $ \worker -> do
1515 Right conn <- connect endpoint (EndPointAddress $ BSC.pack worker) ReliableOrdered
1616 return conn
1717 -- Send out requests
@@ -24,10 +24,10 @@ master done endpoint workers = do
2424 case event of
2525 Received _ msg ->
2626 tell [read . BSC.unpack . BS.concat $ msg]
27− _ ->
27+ _ ->
2828 return ()
2929 putStrLn $ "Replies: " ++ show (replies :: [Int])
30− putMVar done ()
30+ putMVar done ()
3131
3232main :: IO ()
3333main = do
@@ -41,4 +41,4 @@ main = do
4141 forkIO $ master masterDone endpoint workers
4242
4343 takeMVar masterDone
44−
44+
network-transport/tests/sumeuler/SumEulerWorker.hs+4−4
@@ -20,15 +20,15 @@ sumEuler :: Int -> Int
2020sumEuler = sum . (map euler) . mkList
2121
2222worker :: String -> MVar () -> EndPoint -> IO ()
23−worker id done endpoint = do
24− ConnectionOpened _ _ theirAddr <- receive endpoint
23+worker id done endpoint = do
24+ ConnectionOpened _ _ theirAddr <- receive endpoint
2525 Right replyChan <- connect endpoint theirAddr ReliableOrdered
2626 go replyChan
2727 where
2828 go replyChan = do
2929 event <- receive endpoint
3030 case event of
31− ConnectionClosed _ -> do
31+ ConnectionClosed _ -> do
3232 close replyChan
3333 putMVar done ()
3434 Received _ msg -> do
@@ -39,7 +39,7 @@ worker id done endpoint = do
3939
4040main :: IO ()
4141main = do
42− (id:host:port:_) <- getArgs
42+ (id:host:port:_) <- getArgs
4343 Right transport <- createTransport host port
4444 Right endpoint <- newEndPoint transport
4545 workerDone <- newEmptyMVar
rank1dynamic/src/Data/Rank1Dynamic.hs+21−21
@@ -5,42 +5,42 @@
55-- These examples correspond to the 'Data.Rank1Typeable.isInstanceOf' examples
66-- in "Data.Rank1Typeable".
77--
8−-- > > do f <- fromDynamic (toDynamic (even :: Int -> Bool)) ; return $ (f :: Int -> Int) 0
8+-- > > do f <- fromDynamic (toDynamic (even :: Int -> Bool)) ; return $ (f :: Int -> Int) 0
99-- > Left "Cannot unify Int and Bool"
10−-- >
10+-- >
1111-- > > do f <- fromDynamic (toDynamic (const 1 :: ANY -> Int)) ; return $ (f :: Int -> Int) 0
1212-- > Right 1
13−-- >
13+-- >
1414-- > > do f <- fromDynamic (toDynamic (unsafeCoerce :: ANY1 -> ANY2)) ; return $ (f :: Int -> Int) 0
1515-- > Right 0
16−-- >
16+-- >
1717-- > > do f <- fromDynamic (toDynamic (id :: ANY -> ANY)) ; return $ (f :: Int -> Bool) 0
1818-- > Left "Cannot unify Bool and Int"
19−-- >
19+-- >
2020-- > > do f <- fromDynamic (toDynamic (undefined :: ANY)) ; return $ (f :: Int -> Int) 0
2121-- > Right *** Exception: Prelude.undefined
22−-- >
22+-- >
2323-- > > do f <- fromDynamic (toDynamic (id :: ANY -> ANY)) ; return $ (f :: Int)
2424-- > Left "Cannot unify Int and ->"
2525--
2626-- [Examples of dynApply]
27−--
27+--
2828-- These examples correspond to the 'Data.Rank1Typeable.funResultTy' examples
2929-- in "Data.Rank1Typeable".
3030--
3131-- > > do app <- toDynamic (id :: ANY -> ANY) `dynApply` toDynamic True ; f <- fromDynamic app ; return $ (f :: Bool)
3232-- > Right True
33−-- >
33+-- >
3434-- > > do app <- toDynamic (const :: ANY -> ANY1 -> ANY) `dynApply` toDynamic True ; f <- fromDynamic app ; return $ (f :: Int -> Bool) 0
3535-- > Right True
36−-- >
36+-- >
3737-- > > do app <- toDynamic (($ True) :: (Bool -> ANY) -> ANY) `dynApply` toDynamic (id :: ANY -> ANY) ; f <- fromDynamic app ; return (f :: Bool)
3838-- > Right True
39−-- >
39+-- >
4040-- > > app <- toDynamic (const :: ANY -> ANY1 -> ANY) `dynApply` toDynamic (id :: ANY -> ANY) ; f <- fromDynamic app ; return $ (f :: Int -> Bool -> Bool) 0 True
4141-- > Right True
42−-- >
43−-- > > do app <- toDynamic ((\f -> f . f) :: (ANY -> ANY) -> ANY -> ANY) `dynApply` toDynamic (even :: Int -> Bool) ; f <- fromDynamic app ; return (f :: ())
42+-- >
43+-- > > do app <- toDynamic ((\f -> f . f) :: (ANY -> ANY) -> ANY -> ANY) `dynApply` toDynamic (even :: Int -> Bool) ; f <- fromDynamic app ; return (f :: ())
4444-- > Left "Cannot unify Int and Bool"
4545--
4646-- [Using toDynamic]
@@ -48,30 +48,30 @@
4848-- When using polymorphic values you need to give an explicit type annotation:
4949--
5050-- > > toDynamic id
51−-- >
51+-- >
5252-- > <interactive>:46:1:
5353-- > Ambiguous type variable `a0' in the constraint:
5454-- > (Typeable a0) arising from a use of `toDynamic'
5555-- > Probable fix: add a type signature that fixes these type variable(s)
5656-- > In the expression: toDynamic id
5757-- > In an equation for `it': it = toDynamic id
58−--
58+--
5959-- versus
6060--
6161-- > > toDynamic (id :: ANY -> ANY)
6262-- > <<ANY -> ANY>>
63−--
63+--
6464-- Note that these type annotation are checked by ghc like any other:
6565--
6666-- > > toDynamic (id :: ANY -> ANY1)
67−-- >
67+-- >
6868-- > <interactive>:45:12:
6969-- > Couldn't match expected type `V1' with actual type `V0'
7070-- > Expected type: ANY -> ANY1
7171-- > Actual type: ANY -> ANY
7272-- > In the first argument of `toDynamic', namely `(id :: ANY -> ANY1)'
7373-- > In the expression: toDynamic (id :: ANY -> ANY1)
74−module Data.Rank1Dynamic
74+module Data.Rank1Dynamic
7575 ( Dynamic
7676 , toDynamic
7777 , fromDynamic
@@ -81,7 +81,7 @@ module Data.Rank1Dynamic
8181 ) where
8282
8383import qualified GHC.Prim as GHC (Any)
84−import Data.Rank1Typeable
84+import Data.Rank1Typeable
8585 ( Typeable
8686 , TypeRep
8787 , typeOf
@@ -95,16 +95,16 @@ import Unsafe.Coerce (unsafeCoerce)
9595data Dynamic = Dynamic TypeRep GHC.Any
9696
9797instance Show Dynamic where
98− showsPrec _ (Dynamic t _) = showString "<<" . shows t . showString ">>"
98+ showsPrec _ (Dynamic t _) = showString "<<" . shows t . showString ">>"
9999
100−-- | Introduce a dynamic value
100+-- | Introduce a dynamic value
101101toDynamic :: Typeable a => a -> Dynamic
102102toDynamic x = Dynamic (typeOf x) (unsafeCoerce x)
103103
104104-- | Eliminate a dynamic value
105105fromDynamic :: Typeable a => Dynamic -> Either TypeError a
106106fromDynamic (Dynamic t v) =
107− case unsafeCoerce v of
107+ case unsafeCoerce v of
108108 r -> case typeOf r `isInstanceOf` t of
109109 Left err -> Left err
110110 Right () -> Right r
rank1dynamic/src/Data/Rank1Typeable.hs+51−51
@@ -1,7 +1,7 @@
11-- | Runtime type representation of terms with support for rank-1 polymorphic
22-- types with type variables of kind *.
33--
4−-- The essence of this module is that we use the standard 'Typeable'
4+-- The essence of this module is that we use the standard 'Typeable'
55-- representation of "Data.Typeable" but we introduce a special (empty) data
66-- type 'TypVar' which represents type variables. 'TypVar' is indexed by an
77-- arbitrary other data type, giving you an unbounded number of type variables;
@@ -12,23 +12,23 @@
1212-- > -- We CANNOT use a term of type 'Int -> Bool' as 'Int -> Int'
1313-- > > typeOf (undefined :: Int -> Int) `isInstanceOf` typeOf (undefined :: Int -> Bool)
1414-- > Left "Cannot unify Int and Bool"
15−-- >
15+-- >
1616-- > -- We CAN use a term of type 'forall a. a -> Int' as 'Int -> Int'
1717-- > > typeOf (undefined :: Int -> Int) `isInstanceOf` typeOf (undefined :: ANY -> Int)
1818-- > Right ()
19−-- >
19+-- >
2020-- > -- We CAN use a term of type 'forall a b. a -> b' as 'forall a. a -> a'
2121-- > > typeOf (undefined :: ANY -> ANY) `isInstanceOf` typeOf (undefined :: ANY -> ANY1)
2222-- > Right ()
23−-- >
23+-- >
2424-- > -- We CANNOT use a term of type 'forall a. a -> a' as 'forall a b. a -> b'
2525-- > > typeOf (undefined :: ANY -> ANY1) `isInstanceOf` typeOf (undefined :: ANY -> ANY)
2626-- > Left "Cannot unify Succ and Zero"
27−-- >
27+-- >
2828-- > -- We CAN use a term of type 'forall a. a' as 'forall a. a -> a'
2929-- > > typeOf (undefined :: ANY -> ANY) `isInstanceOf` typeOf (undefined :: ANY)
3030-- > Right ()
31−-- >
31+-- >
3232-- > -- We CANNOT use a term of type 'forall a. a -> a' as 'forall a. a'
3333-- > > typeOf (undefined :: ANY) `isInstanceOf` typeOf (undefined :: ANY -> ANY)
3434-- > Left "Cannot unify Skolem and ->"
@@ -37,14 +37,14 @@
3737--
3838-- [Examples of funResultTy]
3939--
40−-- > -- Apply fn of type (forall a. a -> a) to arg of type Bool gives Bool
40+-- > -- Apply fn of type (forall a. a -> a) to arg of type Bool gives Bool
4141-- > > funResultTy (typeOf (undefined :: ANY -> ANY)) (typeOf (undefined :: Bool))
4242-- > Right Bool
43−-- >
43+-- >
4444-- > -- Apply fn of type (forall a b. a -> b -> a) to arg of type Bool gives forall a. a -> Bool
4545-- > > funResultTy (typeOf (undefined :: ANY -> ANY1 -> ANY)) (typeOf (undefined :: Bool))
4646-- > Right (ANY -> Bool) -- forall a. a -> Bool
47−-- >
47+-- >
4848-- > -- Apply fn of type (forall a. (Bool -> a) -> a) to argument of type (forall a. a -> a) gives Bool
4949-- > > funResultTy (typeOf (undefined :: (Bool -> ANY) -> ANY)) (typeOf (undefined :: ANY -> ANY))
5050-- > Right Bool
@@ -56,14 +56,14 @@
5656-- > -- Cannot apply function of type (forall a. (a -> a) -> a -> a) to arg of type (Int -> Bool)
5757-- > > funResultTy (typeOf (undefined :: (ANY -> ANY) -> (ANY -> ANY))) (typeOf (undefined :: Int -> Bool))
5858-- > Left "Cannot unify Int and Bool"
59−module Data.Rank1Typeable
60− ( -- * Basic types
59+module Data.Rank1Typeable
60+ ( -- * Basic types
6161 TypeRep
6262 , typeOf
6363 , splitTyConApp
6464 , mkTyConApp
6565 , underlyingTypeRep
66− -- * Operations on type representations
66+ -- * Operations on type representations
6767 , isInstanceOf
6868 , funResultTy
6969 , TypeError
@@ -105,7 +105,7 @@ import Data.Typeable (Typeable, mkTyCon3)
105105import Data.Typeable.Internal (listTc, funTc, TyCon(TyCon), tyConName)
106106import Data.Binary (Binary(get, put))
107107import GHC.Fingerprint.Type (Fingerprint(..))
108−import qualified Data.Typeable as Typeable
108+import qualified Data.Typeable as Typeable
109109 ( TypeRep
110110 , typeOf
111111 , splitTyConApp
@@ -117,15 +117,15 @@ import qualified Data.Typeable as Typeable
117117--------------------------------------------------------------------------------
118118
119119-- | Dynamic type representation with support for rank-1 types
120−newtype TypeRep = TypeRep {
120+newtype TypeRep = TypeRep {
121121 -- | Return the underlying standard ("Data.Typeable") type representation
122− underlyingTypeRep :: Typeable.TypeRep
122+ underlyingTypeRep :: Typeable.TypeRep
123123 }
124124
125125-- | Compare two type representations
126126--
127127-- For base >= 4.6 this compares fingerprints, but older versions of base
128−-- have a bug in the fingerprint construction
128+-- have a bug in the fingerprint construction
129129-- (<http://hackage.haskell.org/trac/ghc/ticket/5962>)
130130instance Eq TypeRep where
131131#if ! MIN_VERSION_base(4,6,0)
@@ -138,7 +138,7 @@ instance Eq TypeRep where
138138-- Binary instance for 'TypeRep', avoiding orphan instances
139139instance Binary TypeRep where
140140 put (splitTyConApp -> (TyCon (Fingerprint hi lo) package modul name, ts)) = do
141− put hi
141+ put hi
142142 put lo
143143 put package
144144 put modul
@@ -164,16 +164,16 @@ typeOf = TypeRep . Typeable.typeOf
164164-- | Split a type representation into the application of
165165-- a type constructor and its argument
166166splitTyConApp :: TypeRep -> (TyCon, [TypeRep])
167−splitTyConApp t =
167+splitTyConApp t =
168168 let (c, ts) = Typeable.splitTyConApp (underlyingTypeRep t)
169169 in (c, map TypeRep ts)
170170
171171-- | Inverse of 'splitTyConApp'
172172mkTyConApp :: TyCon -> [TypeRep] -> TypeRep
173−mkTyConApp c ts
173+mkTyConApp c ts
174174 = TypeRep (Typeable.mkTyConApp c (map underlyingTypeRep ts))
175175
176−isTypVar :: TypeRep -> Maybe Var
176+isTypVar :: TypeRep -> Maybe Var
177177isTypVar (splitTyConApp -> (c, [t])) | c == typVar = Just t
178178isTypVar _ = Nothing
179179
@@ -190,7 +190,7 @@ skolem = let (c, _) = splitTyConApp (typeOf (undefined :: Skolem V0)) in c
190190-- Type variables --
191191--------------------------------------------------------------------------------
192192
193−data TypVar a deriving Typeable
193+data TypVar a deriving Typeable
194194data Skolem a deriving Typeable
195195data Zero deriving Typeable
196196data Succ a deriving Typeable
@@ -206,7 +206,7 @@ type V7 = Succ V6
206206type V8 = Succ V7
207207type V9 = Succ V8
208208
209−type ANY = TypVar V0
209+type ANY = TypVar V0
210210type ANY1 = TypVar V1
211211type ANY2 = TypVar V2
212212type ANY3 = TypVar V3
@@ -224,17 +224,17 @@ type ANY9 = TypVar V9
224224-- | If 'isInstanceOf' fails it returns a type error
225225type TypeError = String
226226
227−-- | @t1 `isInstanceOf` t2@ checks if @t1@ is an instance of @t2@
228−isInstanceOf :: TypeRep -> TypeRep -> Either TypeError ()
227+-- | @t1 `isInstanceOf` t2@ checks if @t1@ is an instance of @t2@
228+isInstanceOf :: TypeRep -> TypeRep -> Either TypeError ()
229229isInstanceOf t1 t2 = void (unify (skolemize t1) t2)
230230
231231-- | @funResultTy t1 t2@ is the type of the result when applying a function
232232-- of type @t1@ to an argument of type @t2@
233−funResultTy :: TypeRep -> TypeRep -> Either TypeError TypeRep
234−funResultTy (splitTyConApp -> (fc, [farg, fres])) x | fc == funTc = do
233+funResultTy :: TypeRep -> TypeRep -> Either TypeError TypeRep
234+funResultTy (splitTyConApp -> (fc, [farg, fres])) x | fc == funTc = do
235235 s <- unify (alphaRename "f" farg) (alphaRename "x" x)
236236 return (normalize (subst s (alphaRename "f" fres)))
237−funResultTy f _ =
237+funResultTy f _ =
238238 Left $ show f ++ " is not a function"
239239
240240--------------------------------------------------------------------------------
@@ -251,7 +251,7 @@ tvars :: TypeRep -> [Var]
251251tvars (isTypVar -> Just x) = [x]
252252tvars (splitTyConApp -> (_, ts)) = concatMap tvars ts
253253
254−normalize :: TypeRep -> TypeRep
254+normalize :: TypeRep -> TypeRep
255255normalize t = subst (zip (tvars t) anys) t
256256 where
257257 anys :: [TypeRep]
@@ -261,7 +261,7 @@ normalize t = subst (zip (tvars t) anys) t
261261 succ = mkTyConApp succTyCon . (:[])
262262
263263 zero :: TypeRep
264− zero = mkTyConApp zeroTyCon []
264+ zero = mkTyConApp zeroTyCon []
265265
266266mkTyCon :: String -> TyCon
267267mkTyCon = mkTyCon3 "rank1typeable" "Data.Rank1Typeable"
@@ -281,38 +281,38 @@ type Equation = (TypeRep, TypeRep)
281281type Var = TypeRep
282282
283283skolemize :: TypeRep -> TypeRep
284−skolemize (isTypVar -> Just x) = mkTyConApp skolem [x]
284+skolemize (isTypVar -> Just x) = mkTyConApp skolem [x]
285285skolemize (splitTyConApp -> (c, ts)) = mkTyConApp c (map skolemize ts)
286286
287287occurs :: Var -> TypeRep -> Bool
288−occurs x (isTypVar -> Just x') = x == x'
288+occurs x (isTypVar -> Just x') = x == x'
289289occurs x (splitTyConApp -> (_, ts)) = any (occurs x) ts
290290
291291subst :: Substitution -> TypeRep -> TypeRep
292292subst s (isTypVar -> Just x) = fromMaybe (mkTypVar x) (lookup x s)
293293subst s (splitTyConApp -> (c, ts)) = mkTyConApp c (map (subst s) ts)
294294
295−unify :: TypeRep
296− -> TypeRep
297− -> Either TypeError Substitution
295+unify :: TypeRep
296+ -> TypeRep
297+ -> Either TypeError Substitution
298298unify = \t1 t2 -> go [] [(t1, t2)]
299299 where
300− go :: Substitution
301− -> [Equation]
302− -> Either TypeError Substitution
303− go acc [] =
300+ go :: Substitution
301+ -> [Equation]
302+ -> Either TypeError Substitution
303+ go acc [] =
304304 return acc
305305 go acc ((t1, t2) : eqs) | t1 == t2 = -- Note: equality check is fast
306306 go acc eqs
307307 go acc ((isTypVar -> Just x, t) : eqs) =
308− if x `occurs` t
308+ if x `occurs` t
309309 then Left "Occurs check"
310− else go ((x, t) : map (second $ subst [(x, t)]) acc)
310+ else go ((x, t) : map (second $ subst [(x, t)]) acc)
311311 (map (subst [(x, t)] *** subst [(x, t)]) eqs)
312312 go acc ((t, isTypVar -> Just x) : eqs) =
313313 go acc ((mkTypVar x, t) : eqs)
314− go acc ((splitTyConApp -> (c1, ts1), splitTyConApp -> (c2, ts2)) : eqs) =
315− if c1 /= c2
314+ go acc ((splitTyConApp -> (c1, ts1), splitTyConApp -> (c2, ts2)) : eqs) =
315+ if c1 /= c2
316316 then Left $ "Cannot unify " ++ show c1 ++ " and " ++ show c2
317317 else go acc (zip ts1 ts2 ++ eqs)
318318
@@ -324,14 +324,14 @@ instance Show TypeRep where
324324 showsPrec p (splitTyConApp -> (tycon, tys)) =
325325 case tys of
326326 [] -> showsPrec p tycon
327− [anyIdx -> Just i] | tycon == typVar -> showString "ANY" . showIdx i
328− [x] | tycon == listTc ->
327+ [anyIdx -> Just i] | tycon == typVar -> showString "ANY" . showIdx i
328+ [x] | tycon == listTc ->
329329 showChar '[' . shows x . showChar ']'
330− [a,r] | tycon == funTc ->
331− showParen (p > 8) $ showsPrec 9 a
332− . showString " -> "
330+ [a,r] | tycon == funTc ->
331+ showParen (p > 8) $ showsPrec 9 a
332+ . showString " -> "
333333 . showsPrec 8 r
334− xs | isTupleTyCon tycon ->
334+ xs | isTupleTyCon tycon ->
335335 showTuple xs
336336 _ ->
337337 showParen (p > 9) $ showsPrec p tycon
@@ -344,16 +344,16 @@ instance Show TypeRep where
344344showArgs :: Show a => [a] -> ShowS
345345showArgs [] = id
346346showArgs [a] = showsPrec 10 a
347−showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as
347+showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as
348348
349−anyIdx :: TypeRep -> Maybe Int
349+anyIdx :: TypeRep -> Maybe Int
350350anyIdx (splitTyConApp -> (c, [])) | c == zeroTyCon = Just 0
351351anyIdx (splitTyConApp -> (c, [t])) | c == succTyCon = (+1) <$> anyIdx t
352352anyIdx _ = Nothing
353353
354354showTuple :: [TypeRep] -> ShowS
355355showTuple args = showChar '('
356− . foldr (.) id ( intersperse (showChar ',')
356+ . foldr (.) id ( intersperse (showChar ',')
357357 $ map (showsPrec 10) args
358358 )
359359 . showChar ')'