master...e97fb5c · distributed-process

distributed-process/distributed-process.cabal+6−6

since splitsnapshots

unifiedsplit

@@ -37,7 +37,6 @@ Library

37 transformers >= 0.2 && < 0.4,

38 mtl >= 2.0 && < 2.2,

39 data-accessor >= 0.2 && < 0.3,

40− bytestring >= 0.9 && < 0.11,

41 containers >= 0.4 && < 0.6,

40 containers >= 0.4 && < 0.6,

42 old-locale >= 1.0 && < 1.1,

41 old-locale >= 1.0 && < 1.1,

43 time >= 1.2 && < 1.5,

42 time >= 1.2 && < 1.5,

@@ -46,7 +45,8 @@ Library

46 ghc-prim >= 0.2 && < 0.4,

45 ghc-prim >= 0.2 && < 0.4,

47 distributed-static >= 0.1 && < 0.2,

46 distributed-static >= 0.1 && < 0.2,

48 rank1dynamic >= 0.1 && < 0.2,

47 rank1dynamic >= 0.1 && < 0.2,

49− syb >= 0.3 && < 0.4

48+ syb >= 0.3 && < 0.4,

49+ not-bytestring

50 Exposed-modules: Control.Distributed.Process,

51 Control.Distributed.Process.Serializable,

52 Control.Distributed.Process.Closure,

@@ -82,7 +82,6 @@ Test-Suite TestCH

82 transformers >= 0.2 && < 0.4,

83 mtl >= 2.0 && < 2.2,

84 data-accessor >= 0.2 && < 0.3,

85− bytestring >= 0.9 && < 0.11,

86 containers >= 0.4 && < 0.6,

85 containers >= 0.4 && < 0.6,

87 old-locale >= 1.0 && < 1.1,

86 old-locale >= 1.0 && < 1.1,

88 time >= 1.2 && < 1.5,

87 time >= 1.2 && < 1.5,

@@ -91,7 +90,8 @@ Test-Suite TestCH

91 ghc-prim >= 0.2 && < 0.4,

90 ghc-prim >= 0.2 && < 0.4,

92 ansi-terminal >= 0.5 && < 0.6,

91 ansi-terminal >= 0.5 && < 0.6,

93 distributed-static >= 0.1 && < 0.2,

92 distributed-static >= 0.1 && < 0.2,

94− rank1dynamic >= 0.1 && < 0.2

93+ rank1dynamic >= 0.1 && < 0.2,

94+ not-bytestring

95 Extensions: RankNTypes,

96 ScopedTypeVariables,

97 FlexibleInstances,

@@ -115,7 +115,6 @@ Test-Suite TestClosure

115 transformers >= 0.2 && < 0.4,

116 mtl >= 2.0 && < 2.2,

117 data-accessor >= 0.2 && < 0.3,

118− bytestring >= 0.9 && < 0.11,

119 containers >= 0.4 && < 0.6,

118 containers >= 0.4 && < 0.6,

120 old-locale >= 1.0 && < 1.1,

119 old-locale >= 1.0 && < 1.1,

121 time >= 1.2 && < 1.5,

120 time >= 1.2 && < 1.5,

@@ -125,7 +124,8 @@ Test-Suite TestClosure

125 ansi-terminal >= 0.5 && < 0.6,

124 ansi-terminal >= 0.5 && < 0.6,

126 distributed-static >= 0.1 && < 0.2,

125 distributed-static >= 0.1 && < 0.2,

127 rank1dynamic >= 0.1 && < 0.2,

126 rank1dynamic >= 0.1 && < 0.2,

128− syb >= 0.3 && < 0.4

127+ syb >= 0.3 && < 0.4,

128+ not-bytestring

129 Other-modules: TestAuxiliary

130 Extensions: RankNTypes,

131 ScopedTypeVariables,

distributed-process/src/Control/Distributed/Process.hs+24−7

@@ -98,6 +98,10 @@ module Control.Distributed.Process

98 -- * Local versions of 'spawn'

99 , spawnLocal

100 , spawnChannelLocal

101+ -- * Reconnecting

102+ , reconnect

103+ , reconnectNode

104+ , reconnectPort

101 ) where

105 ) where

102

106

103#if ! MIN_VERSION_base(4,6,0)

107#if ! MIN_VERSION_base(4,6,0)

@@ -206,6 +210,10 @@ import Control.Distributed.Process.Internal.Primitives

206 -- Auxiliary API

210 -- Auxiliary API

207 , expectTimeout

211 , expectTimeout

208 , spawnAsync

212 , spawnAsync

213+ -- Reconnecting

214+ , reconnect

215+ , reconnectNode

216+ , reconnectPort

209 )

217 )

210import Control.Distributed.Process.Serializable (Serializable)

218import Control.Distributed.Process.Serializable (Serializable)

211import Control.Distributed.Process.Node (forkProcess)

219import Control.Distributed.Process.Node (forkProcess)

@@ -294,14 +302,14 @@ spawn nid proc = do

294 `seqCP` proc

302 `seqCP` proc

295 mPid <- receiveWait

303 mPid <- receiveWait

296 [ matchIf (\(DidSpawn ref _) -> ref == sRef)

304 [ matchIf (\(DidSpawn ref _) -> ref == sRef)

297− (\(DidSpawn _ pid) -> return $ Just pid)

305+ (\(DidSpawn _ pid) -> return $ Right pid)

298 , matchIf (\(NodeMonitorNotification ref _ _) -> ref == mRef)

306 , matchIf (\(NodeMonitorNotification ref _ _) -> ref == mRef)

299− (\_ -> return Nothing)

307+ (\(NodeMonitorNotification _ _ err) -> return $ Left err)

300 ]

308 ]

301 unmonitor mRef

309 unmonitor mRef

302 case mPid of

310 case mPid of

303− Nothing -> fail "spawn: remote node failed"

311+ Left err -> fail $ "spawn: remote node failed: " ++ show err

304− Just pid -> send pid () >> return pid

312+ Right pid -> send pid () >> return pid

305

313

306-- | Spawn a process and link to it

314-- | Spawn a process and link to it

307--

315--

@@ -333,7 +341,7 @@ spawnMonitor nid proc = do

333call :: Serializable a => Static (SerializableDict a) -> NodeId -> Closure (Process a) -> Process a

341call :: Serializable a => Static (SerializableDict a) -> NodeId -> Closure (Process a) -> Process a

334call dict nid proc = do

342call dict nid proc = do

335 us <- getSelfPid

343 us <- getSelfPid

336− (_, mRef) <- spawnMonitor nid (proc `bindCP` cpSend dict us)

344+ (pid, mRef) <- spawnMonitor nid (proc `bindCP` cpSend dict us)

337 -- We are guaranteed to receive the reply before the monitor notification

345 -- We are guaranteed to receive the reply before the monitor notification

338 -- (if a reply is sent at all)

346 -- (if a reply is sent at all)

339 -- NOTE: This might not be true if we switch to unreliable delivery.

347 -- NOTE: This might not be true if we switch to unreliable delivery.

@@ -343,8 +351,17 @@ call dict nid proc = do

343 (\(ProcessMonitorNotification _ _ reason) -> return (Left reason))

351 (\(ProcessMonitorNotification _ _ reason) -> return (Left reason))

344 ]

352 ]

345 case mResult of

353 case mResult of

354+ Right a -> do

355+ -- Wait for the monitor message so that we the mailbox doesn't grow

356+ receiveWait

357+ [ matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)

358+ (\(ProcessMonitorNotification {}) -> return ())

359+ ]

360+ -- Clean up connection to pid

361+ reconnect pid

346− Right a -> unmonitor mRef >> return a

362+ return a

363+ Left err ->

347− Left err -> fail $ "call: remote process died: " ++ show err

364+ fail $ "call: remote process died: " ++ show err

348

365

349-- | Spawn a child process, have the child link to the parent and the parent

366-- | Spawn a child process, have the child link to the parent and the parent

350-- monitor the child

367-- monitor the child

distributed-process/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs+2−2

@@ -23,8 +23,8 @@ module Control.Distributed.Process.Internal.Closure.BuiltIn

23 , cpNewChan

24 ) where

25

26−import Data.ByteString.Lazy (ByteString)

26+import Data.NotByteString.Lazy (ByteString)

27−import Data.Binary (decode, encode)

27+import Data.NotByteString.Lazy.Binary (decode, encode)

28import Data.Rank1Typeable (Typeable, ANY, ANY1, ANY2, ANY3, ANY4)

29import Data.Rank1Dynamic (toDynamic)

30import Control.Distributed.Static

distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs+1−1

@@ -39,7 +39,7 @@ import Language.Haskell.TH

39 , funD

40 , sigD

41 )

42−import Data.Binary (encode)

42+import Data.NotByteString.Lazy.Binary (encode)

43import Data.Generics (everywhereM, mkM, gmapM)

44import Data.Rank1Dynamic (toDynamic)

45import Data.Rank1Typeable

distributed-process/src/Control/Distributed/Process/Internal/Node.hs+18−5

@@ -3,12 +3,14 @@ module Control.Distributed.Process.Internal.Node

3 sendPayload

4 , sendBinary

5 , sendMessage

6+ , reconnect

6 ) where

7 ) where

7

8

8import Data.Accessor ((^.), (^=))

9import Data.Accessor ((^.), (^=))

9−import Data.Binary (Binary, encode)

10+import Data.Binary (Binary)

11+import Data.NotByteString.Lazy.Binary (encode)

10−import qualified Data.ByteString.Lazy as BSL (toChunks)

12+import qualified Data.NotByteString.Lazy as BSL (toChunks)

11−import qualified Data.ByteString as BSS (ByteString)

13+import qualified Data.NotByteString as BSS (ByteString)

12import Control.Distributed.Process.Internal.StrictMVar (withMVar, modifyMVar_)

14import Control.Distributed.Process.Internal.StrictMVar (withMVar, modifyMVar_)

13import Control.Concurrent.Chan (writeChan)

15import Control.Concurrent.Chan (writeChan)

14import Control.Monad (unless)

16import Control.Monad (unless)

@@ -18,6 +20,7 @@ import qualified Network.Transport as NT

18 , defaultConnectHints

20 , defaultConnectHints

19 , connect

21 , connect

20 , Reliability(ReliableOrdered)

22 , Reliability(ReliableOrdered)

23+ , close

21 )

24 )

22import Control.Distributed.Process.Internal.Types

25import Control.Distributed.Process.Internal.Types

23 ( LocalNode(localState, localEndPoint, localCtrlChan)

26 ( LocalNode(localState, localEndPoint, localCtrlChan)

@@ -44,8 +47,8 @@ sendPayload node from to payload = do

44 Just conn -> do

47 Just conn -> do

45 didSend <- NT.send conn payload

48 didSend <- NT.send conn payload

46 case didSend of

49 case didSend of

47− Left _ -> return False

50+ Left _err -> return False

48− Right _ -> return True

51+ Right () -> return True

49 Nothing -> return False

52 Nothing -> return False

50 unless didSend $

53 unless didSend $

51 writeChan (localCtrlChan node) NCMsg

54 writeChan (localCtrlChan node) NCMsg

@@ -89,3 +92,13 @@ connBetween node from to = do

89 Nothing -> setupConnBetween node from to

92 Nothing -> setupConnBetween node from to

90 where

93 where

91 nodeState = localState node

94 nodeState = localState node

95+

96+reconnect :: LocalNode -> Identifier -> Identifier -> IO ()

97+reconnect node from to =

98+ modifyMVar_ (localState node) $ \st ->

99+ case st ^. localConnectionBetween from to of

100+ Nothing ->

101+ return st

102+ Just conn -> do

103+ NT.close conn

104+ return (localConnectionBetween from to ^= Nothing $ st)

distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+43−1

@@ -59,13 +59,17 @@ module Control.Distributed.Process.Internal.Primitives

59 , unlinkPort

60 , monitorNode

61 , monitorPort

62+ -- * Reconnecting

63+ , reconnect

64+ , reconnectNode

65+ , reconnectPort

62 ) where

66 ) where

63

67

64#if ! MIN_VERSION_base(4,6,0)

68#if ! MIN_VERSION_base(4,6,0)

65import Prelude hiding (catch)

69import Prelude hiding (catch)

66#endif

70#endif

67

71

68−import Data.Binary (decode)

72+import Data.NotByteString.Lazy.Binary (decode)

69import Data.Time.Clock (getCurrentTime)

73import Data.Time.Clock (getCurrentTime)

70import Data.Time.Format (formatTime)

74import Data.Time.Format (formatTime)

71import System.Locale (defaultTimeLocale)

75import System.Locale (defaultTimeLocale)

@@ -506,6 +510,44 @@ unClosure closure = do

506 Left err -> fail $ "Could not resolve closure: " ++ err

510 Left err -> fail $ "Could not resolve closure: " ++ err

507 Right x -> return x

511 Right x -> return x

508

512

513+--------------------------------------------------------------------------------

514+-- Reconnecting --

515+--------------------------------------------------------------------------------

516+

517+-- | Cloud Haskell provides the illusion of connection-less, reliable, ordered

518+-- message passing. However, when network connections get disrupted this

519+-- illusion cannot always be maintained. Once a network connection breaks (even

520+-- temporarily) no further communication on that connection will be possible.

521+-- For example, if process A sends a message to process B, and A is then

522+-- notified (by monitor notification) that it got disconnected from B, A will

523+-- not be able to send any further messages to B, /unless/ A explicitly

524+-- indicates that it is acceptable to attempt to reconnect to B using the

525+-- Cloud Haskell 'reconnect' primitive.

526+--

527+-- Importantly, when A calls 'reconnect' it acknowledges that some messages to

528+-- B might have been lost. For instance, if A sends messages m1 and m2 to B,

529+-- then receives a monitor notification that its connection to B has been lost,

530+-- calls 'reconnect' and then sends m3, it is possible that B will receive m1

531+-- and m3 but not m2.

532+--

533+-- Note that 'reconnect' does not mean /reconnect now/ but rather /it is okay

534+-- to attempt to reconnect on the next send/. In particular, if no further

535+-- communication attempts are made to B then A can use reconnect to clean up

536+-- its connection to B.

537+reconnect :: ProcessId -> Process ()

538+reconnect =

539+ sendCtrlMsg Nothing . Reconnect . ProcessIdentifier

540+

541+-- | Reconnect to a node. See 'reconnect' for more information.

542+reconnectNode :: NodeId -> Process ()

543+reconnectNode =

544+ sendCtrlMsg Nothing . Reconnect . NodeIdentifier

545+

546+-- | Reconnect to a sendport. See 'reconnect' for more information.

547+reconnectPort :: SendPort a -> Process ()

548+reconnectPort =

549+ sendCtrlMsg Nothing . Reconnect . SendPortIdentifier . sendPortId

550+

509--------------------------------------------------------------------------------

551--------------------------------------------------------------------------------

510-- Auxiliary functions --

552-- Auxiliary functions --

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

553--------------------------------------------------------------------------------

distributed-process/src/Control/Distributed/Process/Internal/Types.hs+14−14

@@ -64,9 +64,10 @@ module Control.Distributed.Process.Internal.Types

64import Data.Map (Map)

65import Data.Int (Int32)

66import Data.Typeable (Typeable)

67−import Data.Binary (Binary(put, get), putWord8, getWord8, encode)

67+import Data.Binary (Binary(put, get), putWord8, getWord8)

68+import Data.NotByteString.Lazy.Binary (encode)

68−import qualified Data.ByteString as BSS (ByteString, concat)

69+import qualified Data.NotByteString as BSS (ByteString, concat)

69−import qualified Data.ByteString.Lazy as BSL

70+import qualified Data.NotByteString.Lazy as BSL

70 ( ByteString

71 ( ByteString

71 , toChunks

72 , toChunks

72 , splitAt

73 , splitAt

@@ -104,12 +105,8 @@ import Control.Distributed.Static (RemoteTable, Closure)

104--------------------------------------------------------------------------------

105--------------------------------------------------------------------------------

105

106

106-- | Node identifier

107-- | Node identifier

107−data NodeId = NodeId { nodeAddress :: !(NT.EndPointAddress) }

108+newtype NodeId = NodeId { nodeAddress :: NT.EndPointAddress }

108− deriving (Eq, Ord)

109+ deriving (Eq, Ord, Binary)

109−

110−instance Binary NodeId where

111− put (NodeId nid) = put nid

112− get = NodeId <$> get

113

110

114instance Show NodeId where

111instance Show NodeId where

115 show (NodeId addr) = "nid://" ++ show addr

112 show (NodeId addr) = "nid://" ++ show addr

@@ -117,8 +114,8 @@ instance Show NodeId where

117-- | A local process ID consists of a seed which distinguishes processes from

114-- | A local process ID consists of a seed which distinguishes processes from

118-- different instances of the same local node and a counter

115-- different instances of the same local node and a counter

119data LocalProcessId = LocalProcessId

116data LocalProcessId = LocalProcessId

120− { lpidUnique :: !Int32

117+ { lpidUnique :: {-# UNPACK #-} !Int32

121− , lpidCounter :: !Int32

118+ , lpidCounter :: {-# UNPACK #-} !Int32

122 }

119 }

123 deriving (Eq, Ord, Typeable, Show)

120 deriving (Eq, Ord, Typeable, Show)

124

121

@@ -127,7 +124,7 @@ data ProcessId = ProcessId

127 { -- | The ID of the node the process is running on

124 { -- | The ID of the node the process is running on

128 processNodeId :: !NodeId

125 processNodeId :: !NodeId

129 -- | Node-local identifier for the process

126 -- | Node-local identifier for the process

130− , processLocalId :: !LocalProcessId

127+ , processLocalId :: {-# UNPACK #-} !LocalProcessId

131 }

128 }

132 deriving (Eq, Ord, Typeable)

129 deriving (Eq, Ord, Typeable)

133

130

@@ -218,9 +215,9 @@ type LocalSendPortId = Int32

218-- to create a SendPort.

215-- to create a SendPort.

219data SendPortId = SendPortId {

216data SendPortId = SendPortId {

220 -- | The ID of the process that will receive messages sent on this port

217 -- | The ID of the process that will receive messages sent on this port

221− sendPortProcessId :: !ProcessId

218+ sendPortProcessId :: {-# UNPACK #-} !ProcessId

222 -- | Process-local ID of the channel

219 -- | Process-local ID of the channel

223− , sendPortLocalId :: !LocalSendPortId

220+ , sendPortLocalId :: {-# UNPACK #-} !LocalSendPortId

224 }

221 }

225 deriving (Eq, Ord)

222 deriving (Eq, Ord)

226

223

@@ -388,6 +385,7 @@ data ProcessSignal =

388 | WhereIs String

385 | WhereIs String

389 | Register String (Maybe ProcessId) -- Nothing to unregister

386 | Register String (Maybe ProcessId) -- Nothing to unregister

390 | NamedSend String Message

387 | NamedSend String Message

388+ | Reconnect Identifier

391 deriving Show

389 deriving Show

392

390

393--------------------------------------------------------------------------------

391--------------------------------------------------------------------------------

@@ -432,6 +430,7 @@ instance Binary ProcessSignal where

432 put (WhereIs label) = putWord8 6 >> put label

430 put (WhereIs label) = putWord8 6 >> put label

433 put (Register label pid) = putWord8 7 >> put label >> put pid

431 put (Register label pid) = putWord8 7 >> put label >> put pid

434 put (NamedSend label msg) = putWord8 8 >> put label >> put (messageToPayload msg)

432 put (NamedSend label msg) = putWord8 8 >> put label >> put (messageToPayload msg)

433+ put (Reconnect dest) = putWord8 9 >> put dest

435 get = do

434 get = do

436 header <- getWord8

435 header <- getWord8

437 case header of

436 case header of

@@ -444,6 +443,7 @@ instance Binary ProcessSignal where

444 6 -> WhereIs <$> get

443 6 -> WhereIs <$> get

445 7 -> Register <$> get <*> get

444 7 -> Register <$> get <*> get

446 8 -> NamedSend <$> get <*> (payloadToMessage <$> get)

445 8 -> NamedSend <$> get <*> (payloadToMessage <$> get)

446+ 9 -> Reconnect <$> get

447 _ -> fail "ProcessSignal.get: invalid"

448

449instance Binary DiedReason where

distributed-process/src/Control/Distributed/Process/Node.hs+50−25

@@ -14,8 +14,8 @@ import Prelude hiding (catch)

14#endif

15

16import System.IO (fixIO, hPutStrLn, stderr)

17−import qualified Data.ByteString.Lazy as BSL (fromChunks)

17+import qualified Data.NotByteString.Lazy as BSL (fromChunks)

18−import Data.Binary (decode)

18+import Data.NotByteString.Lazy.Binary (decode)

19import Data.Map (Map)

20import qualified Data.Map as Map

21 ( empty

@@ -25,16 +25,16 @@ import qualified Data.Map as Map

25 , toList

26 , partitionWithKey

27 , filterWithKey

28+ , elems

28 )

29 )

29−import qualified Data.List as List (delete, (\\))

30import Data.Set (Set)

31−import qualified Data.Set as Set (empty, insert, delete, member, (\\), fromList)

31+import qualified Data.Set as Set (empty, insert, delete, member, filter)

32import Data.Foldable (forM_)

33import Data.Maybe (isJust)

34import Data.Typeable (Typeable)

35import Control.Category ((>>>))

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

37−import Control.Monad (void, when, forever)

37+import Control.Monad (void, when)

38import Control.Monad.IO.Class (MonadIO, liftIO)

39import Control.Monad.State.Strict (MonadState, StateT, evalStateT, gets)

40import qualified Control.Monad.State.Strict as StateT (get, put)

@@ -65,6 +65,8 @@ import qualified Network.Transport as NT

65 , address

66 , closeEndPoint

67 , ConnectionId

68+ , Connection

69+ , close

68 )

70 )

69import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))

71import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))

70import qualified Data.Accessor.Container as DAC (mapDefault, mapMaybe)

72import qualified Data.Accessor.Container as DAC (mapDefault, mapMaybe)

@@ -89,6 +91,7 @@ import Control.Distributed.Process.Internal.Types

89 , localPidCounter

91 , localPidCounter

90 , localPidUnique

92 , localPidUnique

91 , localProcessWithId

93 , localProcessWithId

94+ , localConnections

92 , MonitorRef(..)

95 , MonitorRef(..)

93 , ProcessMonitorNotification(..)

96 , ProcessMonitorNotification(..)

94 , NodeMonitorNotification(..)

97 , NodeMonitorNotification(..)

@@ -119,6 +122,7 @@ import Control.Distributed.Process.Internal.Node

119 ( sendBinary

122 ( sendBinary

120 , sendMessage

123 , sendMessage

121 , sendPayload

124 , sendPayload

125+ , reconnect

122 )

126 )

123import Control.Distributed.Process.Internal.Primitives (expect, register, finally)

127import Control.Distributed.Process.Internal.Primitives (expect, register, finally)

124import qualified Control.Distributed.Process.Internal.Closure.BuiltIn as BuiltIn (remoteTable)

128import qualified Control.Distributed.Process.Internal.Closure.BuiltIn as BuiltIn (remoteTable)

@@ -162,11 +166,17 @@ createBareLocalNode endPoint rtable = do

162 void . forkIO $ handleIncomingMessages node

166 void . forkIO $ handleIncomingMessages node

163 return node

167 return node

164

168

169+-- Like 'Control.Monad.forever' but sans space leak

170+{-# INLINE forever' #-}

171+forever' :: Monad m => m a -> m b

172+-- forever' a = let a' = a >> a' in a'

173+forever' a = a >> forever' a

174+

165-- | Start and register the service processes on a node

175-- | Start and register the service processes on a node

166-- (for now, this is only the logger)

176-- (for now, this is only the logger)

167startServiceProcesses :: LocalNode -> IO ()

177startServiceProcesses :: LocalNode -> IO ()

168startServiceProcesses node = do

178startServiceProcesses node = do

169− logger <- forkProcess node . forever $ do

179+ logger <- forkProcess node . forever' $ do

170 (time, pid, string) <- expect :: Process (String, ProcessId, String)

180 (time, pid, string) <- expect :: Process (String, ProcessId, String)

171 liftIO . hPutStrLn stderr $ time ++ " " ++ show pid ++ ": " ++ string

181 liftIO . hPutStrLn stderr $ time ++ " " ++ show pid ++ ": " ++ string

172 runProcess node $ register "logger" logger

182 runProcess node $ register "logger" logger

@@ -212,8 +222,13 @@ forkProcess node proc = modifyMVar (localState node) $ \st -> do

212 (runLocalProcess lproc proc >> return DiedNormal)

222 (runLocalProcess lproc proc >> return DiedNormal)

213 (return . DiedException . (show :: SomeException -> String))

223 (return . DiedException . (show :: SomeException -> String))

214 -- [Unified: Table 4, rules termination and exiting]

224 -- [Unified: Table 4, rules termination and exiting]

215− modifyMVar_ (localState node) $

225+ modifyMVar_ (localState node) $ \st -> do

226+ let pid' = ProcessIdentifier pid

227+ let (affected, unaffected) = Map.partitionWithKey (\(fr, _to) !_v -> impliesDeathOf pid' fr) (st ^. localConnections)

228+ mapM_ NT.close (Map.elems affected)

216− return . (localProcessWithId lpid ^= Nothing)

229+ return $ (localProcessWithId lpid ^= Nothing)

230+ . (localConnections ^= unaffected)

231+ $ st

217 writeChan (localCtrlChan node) NCMsg

232 writeChan (localCtrlChan node) NCMsg

218 { ctrlMsgSender = ProcessIdentifier pid

233 { ctrlMsgSender = ProcessIdentifier pid

219 , ctrlMsgSignal = Died (ProcessIdentifier pid) reason

234 , ctrlMsgSignal = Died (ProcessIdentifier pid) reason

@@ -237,25 +252,25 @@ forkProcess node proc = modifyMVar (localState node) $ \st -> do

237 )

252 )

238

253

239handleIncomingMessages :: LocalNode -> IO ()

254handleIncomingMessages :: LocalNode -> IO ()

240−handleIncomingMessages node = go [] Map.empty Map.empty Set.empty

255+handleIncomingMessages node = go Set.empty Map.empty Map.empty Set.empty

241 where

256 where

242− go :: [NT.ConnectionId] -- ^ Connections whose purpose we don't yet know

257+ go :: Set NT.ConnectionId -- ^ Connections whose purpose we don't yet know

243 -> Map NT.ConnectionId LocalProcess -- ^ Connections to local processes

258 -> Map NT.ConnectionId LocalProcess -- ^ Connections to local processes

244 -> Map NT.ConnectionId TypedChannel -- ^ Connections to typed channels

259 -> Map NT.ConnectionId TypedChannel -- ^ Connections to typed channels

245 -> Set NT.ConnectionId -- ^ Connections to our controller

260 -> Set NT.ConnectionId -- ^ Connections to our controller

246 -> IO ()

261 -> IO ()

247− go uninitConns procs chans ctrls = do

262+ go !uninitConns !procs !chans !ctrls = do

248 event <- NT.receive endpoint

263 event <- NT.receive endpoint

249 case event of

264 case event of

250 NT.ConnectionOpened cid _rel _theirAddr ->

265 NT.ConnectionOpened cid _rel _theirAddr ->

251 -- TODO: Check if _rel is ReliableOrdered, and if not, treat as

266 -- TODO: Check if _rel is ReliableOrdered, and if not, treat as

252 -- (**) below.

267 -- (**) below.

253− go (cid : uninitConns) procs chans ctrls

268+ go (Set.insert cid uninitConns) procs chans ctrls

254 NT.Received cid payload ->

269 NT.Received cid payload ->

255 case ( Map.lookup cid procs

270 case ( Map.lookup cid procs

256 , Map.lookup cid chans

271 , Map.lookup cid chans

257 , cid `Set.member` ctrls

272 , cid `Set.member` ctrls

258− , cid `elem` uninitConns

273+ , cid `Set.member` uninitConns

259 ) of

274 ) of

260 (Just proc, _, _, _) -> do

275 (Just proc, _, _, _) -> do

261 let msg = payloadToMessage payload

276 let msg = payloadToMessage payload

@@ -275,7 +290,7 @@ handleIncomingMessages node = go [] Map.empty Map.empty Set.empty

275 mProc <- withMVar state $ return . (^. localProcessWithId lpid)

290 mProc <- withMVar state $ return . (^. localProcessWithId lpid)

276 case mProc of

291 case mProc of

277 Just proc ->

292 Just proc ->

278− go (List.delete cid uninitConns)

293+ go (Set.delete cid uninitConns)

279 (Map.insert cid proc procs)

294 (Map.insert cid proc procs)

280 chans

295 chans

281 ctrls

296 ctrls

@@ -287,7 +302,7 @@ handleIncomingMessages node = go [] Map.empty Map.empty Set.empty

287 -- remote node as having died, and we should close

302 -- remote node as having died, and we should close

288 -- incoming connections (this requires a Transport layer

303 -- incoming connections (this requires a Transport layer

289 -- extension). (**)

304 -- extension). (**)

290− go (List.delete cid uninitConns) procs chans ctrls

305+ go (Set.delete cid uninitConns) procs chans ctrls

291 SendPortIdentifier chId -> do

306 SendPortIdentifier chId -> do

292 let lcid = sendPortLocalId chId

307 let lcid = sendPortLocalId chId

293 lpid = processLocalId (sendPortProcessId chId)

308 lpid = processLocalId (sendPortProcessId chId)

@@ -297,20 +312,20 @@ handleIncomingMessages node = go [] Map.empty Map.empty Set.empty

297 mChannel <- withMVar (processState proc) $ return . (^. typedChannelWithId lcid)

312 mChannel <- withMVar (processState proc) $ return . (^. typedChannelWithId lcid)

298 case mChannel of

313 case mChannel of

299 Just channel ->

314 Just channel ->

300− go (List.delete cid uninitConns)

315+ go (Set.delete cid uninitConns)

301 procs

316 procs

302 (Map.insert cid channel chans)

317 (Map.insert cid channel chans)

303 ctrls

318 ctrls

304 Nothing ->

319 Nothing ->

305 -- Unknown typed channel

320 -- Unknown typed channel

306 -- TODO (**) above

321 -- TODO (**) above

307− go (List.delete cid uninitConns) procs chans ctrls

322+ go (Set.delete cid uninitConns) procs chans ctrls

308 Nothing ->

323 Nothing ->

309 -- Unknown process

324 -- Unknown process

310 -- TODO (**) above

325 -- TODO (**) above

311− go (List.delete cid uninitConns) procs chans ctrls

326+ go (Set.delete cid uninitConns) procs chans ctrls

312 NodeIdentifier _ ->

327 NodeIdentifier _ ->

313− go (List.delete cid uninitConns)

328+ go (Set.delete cid uninitConns)

314 procs

329 procs

315 chans

330 chans

316 (Set.insert cid ctrls)

331 (Set.insert cid ctrls)

@@ -319,7 +334,7 @@ handleIncomingMessages node = go [] Map.empty Map.empty Set.empty

319 -- TODO (**) above

334 -- TODO (**) above

320 go uninitConns procs chans ctrls

335 go uninitConns procs chans ctrls

321 NT.ConnectionClosed cid ->

336 NT.ConnectionClosed cid ->

322− go (List.delete cid uninitConns)

337+ go (Set.delete cid uninitConns)

323 (Map.delete cid procs)

338 (Map.delete cid procs)

324 (Map.delete cid chans)

339 (Map.delete cid chans)

325 (Set.delete cid ctrls)

340 (Set.delete cid ctrls)

@@ -330,10 +345,11 @@ handleIncomingMessages node = go [] Map.empty Map.empty Set.empty

330 { ctrlMsgSender = nid

345 { ctrlMsgSender = nid

331 , ctrlMsgSignal = Died nid DiedDisconnect

346 , ctrlMsgSignal = Died nid DiedDisconnect

332 }

347 }

348+ let notRemoved k = k `notElem` cids

333− go (uninitConns List.\\ cids)

349+ go (Set.filter notRemoved uninitConns)

334− (Map.filterWithKey (\k _ -> k `notElem` cids) procs)

350+ (Map.filterWithKey (const . notRemoved) procs)

335− (Map.filterWithKey (\k _ -> k `notElem` cids) chans)

351+ (Map.filterWithKey (const . notRemoved) chans)

336− (ctrls Set.\\ Set.fromList cids)

352+ (Set.filter notRemoved ctrls)

337 NT.ErrorEvent (NT.TransportError (NT.EventConnectionLost Nothing _) _) ->

353 NT.ErrorEvent (NT.TransportError (NT.EventConnectionLost Nothing _) _) ->

338 -- TODO: We should treat an asymetrical connection loss (incoming

354 -- TODO: We should treat an asymetrical connection loss (incoming

339 -- connection broken, but outgoing connection still potentially ok)

355 -- connection broken, but outgoing connection still potentially ok)

@@ -392,7 +408,7 @@ initNCState = NCState { _links = Map.empty

392nodeController :: NC ()

408nodeController :: NC ()

393nodeController = do

409nodeController = do

394 node <- ask

410 node <- ask

395− forever $ do

411+ forever' $ do

396 msg <- liftIO $ readChan (localCtrlChan node)

412 msg <- liftIO $ readChan (localCtrlChan node)

397

413

398 -- [Unified: Table 7, rule nc_forward]

414 -- [Unified: Table 7, rule nc_forward]

@@ -424,6 +440,8 @@ nodeController = do

424 ncEffectWhereIs from label

440 ncEffectWhereIs from label

425 NCMsg from (NamedSend label msg') ->

441 NCMsg from (NamedSend label msg') ->

426 ncEffectNamedSend from label msg'

442 ncEffectNamedSend from label msg'

443+ NCMsg from (Reconnect to) ->

444+ ncEffectReconnect from to

427 unexpected ->

445 unexpected ->

428 error $ "nodeController: unexpected message " ++ show unexpected

446 error $ "nodeController: unexpected message " ++ show unexpected

429

447

@@ -547,6 +565,12 @@ ncEffectNamedSend from label msg = do

547 (ProcessIdentifier pid)

565 (ProcessIdentifier pid)

548 (messageToPayload msg)

566 (messageToPayload msg)

549

567

568+-- Reconnecting

569+ncEffectReconnect :: Identifier -> Identifier -> NC ()

570+ncEffectReconnect from to = do

571+ node <- ask

572+ liftIO $ reconnect node from to

573+

550--------------------------------------------------------------------------------

574--------------------------------------------------------------------------------

551-- Auxiliary --

575-- Auxiliary --

552--------------------------------------------------------------------------------

576--------------------------------------------------------------------------------

@@ -592,6 +616,7 @@ destNid (Spawn _ _) = Nothing

592destNid (Register _ _) = Nothing

616destNid (Register _ _) = Nothing

593destNid (WhereIs _) = Nothing

617destNid (WhereIs _) = Nothing

594destNid (NamedSend _ _) = Nothing

618destNid (NamedSend _ _) = Nothing

619+destNid (Reconnect _) = Nothing

595-- We don't need to forward 'Died' signals; if monitoring/linking is setup,

620-- We don't need to forward 'Died' signals; if monitoring/linking is setup,

596-- then when a local process dies the monitoring/linking machinery will take

621-- then when a local process dies the monitoring/linking machinery will take

597-- care of notifying remote nodes

622-- care of notifying remote nodes

distributed-process/src/Control/Distributed/Process/Serializable.hs+6−6

@@ -15,12 +15,12 @@ import Data.Typeable.Internal (TypeRep(TypeRep))

15import Numeric (showHex)

16import Control.Exception (throw)

17import GHC.Fingerprint.Type (Fingerprint(..))

18−import Data.ByteString (ByteString)

18+import Data.NotByteString (ByteString)

19−import qualified Data.ByteString as BS

19+import qualified Data.NotByteString as BS

20−import qualified Data.ByteString.Internal as BSI ( unsafeCreate

20+import qualified Data.NotByteString.Internal as BSI ( unsafeCreate

21− , inlinePerformIO

21+ , inlinePerformIO

22− , toForeignPtr

22+ , toForeignPtr

23− )

23+ )

24import Foreign.Storable (pokeByteOff, peekByteOff, sizeOf)

25import Foreign.ForeignPtr (withForeignPtr)

26

distributed-static/distributed-static.cabal+2−2

@@ -29,8 +29,8 @@ Library

29 Build-Depends: base >= 4 && < 5,

30 rank1dynamic >= 0.1 && < 0.2,

31 containers >= 0.4 && < 0.6,

32− bytestring >= 0.9 && < 0.11,

33− binary >= 0.5 && < 0.6

32+ binary >= 0.5 && < 0.6,

33+ not-bytestring

34 HS-Source-Dirs: src

35 Extensions: DeriveDataTypeable,

36 ScopedTypeVariables

distributed-static/src/Control/Distributed/Static.hs+2−3

@@ -228,10 +228,9 @@ import Data.Binary

228 , Get

229 , putWord8

230 , getWord8

231− , encode

232− , decode

233 )

231 )

232+import Data.NotByteString.Lazy.Binary (decode, encode)

234−import Data.ByteString.Lazy (ByteString, empty)

233+import Data.NotByteString.Lazy (ByteString, empty)

235import Data.Map (Map)

234import Data.Map (Map)

236import qualified Data.Map as Map (lookup, empty, insert)

235import qualified Data.Map as Map (lookup, empty, insert)

237import Control.Applicative ((<$>), (<*>))

236import Control.Applicative ((<$>), (<*>))

network-transport-tcp/network-transport-tcp.cabal+5−3

@@ -25,8 +25,9 @@ Library

25 network-transport >= 0.2 && < 0.3,

26 data-accessor >= 0.2 && < 0.3,

27 containers >= 0.4 && < 0.6,

28+ network >= 2.3 && < 2.4,

28 bytestring >= 0.9 && < 0.11,

29 bytestring >= 0.9 && < 0.11,

29− network >= 2.3 && < 2.4

30+ not-bytestring

30 Exposed-modules: Network.Transport.TCP,

31 Exposed-modules: Network.Transport.TCP,

31 Network.Transport.TCP.Internal

32 Network.Transport.TCP.Internal

32 Extensions: CPP

33 Extensions: CPP

@@ -40,11 +41,12 @@ Test-Suite TestTCP

40 network-transport >= 0.2 && < 0.3,

41 network-transport >= 0.2 && < 0.3,

41 data-accessor >= 0.2 && < 0.3,

42 data-accessor >= 0.2 && < 0.3,

42 containers >= 0.4 && < 0.6,

43 containers >= 0.4 && < 0.6,

43− bytestring >= 0.9 && < 0.11,

44 network >= 2.3 && < 2.4,

45 random >= 1.0 && < 1.1,

46 ansi-terminal >= 0.5 && < 0.6,

47− mtl >= 2.0 && < 2.2

47+ mtl >= 2.0 && < 2.2,

48+ bytestring >= 0.9 && < 0.11,

49+ not-bytestring

48 Other-modules: TestAuxiliary,

50 Other-modules: TestAuxiliary,

49 TestTransport,

51 TestTransport,

50 Traced

52 Traced

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

@@ -66,7 +66,7 @@ import qualified Network.Socket as N ( HostName

66 , sOMAXCONN

67 , AddrInfo

68 )

69−import Network.Socket.ByteString (sendMany)

69+import Data.NotByteString.NBS (sendMany)

70import Control.Concurrent (forkIO, ThreadId, killThread, myThreadId)

71import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)

72import Control.Concurrent.MVar ( MVar

@@ -95,9 +95,9 @@ import Control.Exception ( IOException

95 , fromException

96 )

97import Data.IORef (IORef, newIORef, writeIORef, readIORef)

98−import Data.ByteString (ByteString)

98+import Data.NotByteString (ByteString)

99−import qualified Data.ByteString as BS (concat)

99+import qualified Data.NotByteString as BS (concat)

100−import qualified Data.ByteString.Char8 as BSC (pack, unpack, split)

100+import qualified Data.NotByteString.Char8 as BSC (pack, unpack, split)

101import Data.Int (Int32)

102import Data.IntMap (IntMap)

103import qualified Data.IntMap as IntMap (empty)

@@ -1155,7 +1155,7 @@ setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints = do

1155 { remoteSocket = sock

1156 , _remoteOutgoing = 0

1157 , _remoteIncoming = IntSet.empty

1158− , sendOn = sendMany sock

1158+ , sendOn = sendMany sock

1159 , _pendingCtrlRequests = IntMap.empty

1160 , _nextCtrlRequestId = 0

1161 }

network-transport-tcp/src/Network/Transport/TCP/Internal.hs+3−3

@@ -28,13 +28,13 @@ import qualified Network.Socket as N ( HostName

28 , accept

29 , sClose

30 )

31−import qualified Network.Socket.ByteString as NBS (recv)

31+import qualified Data.NotByteString.NBS as NBS (recv)

32import Control.Concurrent (ThreadId)

33import Control.Monad (forever, when)

34import Control.Exception (SomeException, catch, bracketOnError, throwIO, mask_)

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

36−import Data.ByteString (ByteString)

36+import Data.NotByteString (ByteString)

37−import qualified Data.ByteString as BS (length, concat, null)

37+import qualified Data.NotByteString as BS (length, concat, null)

38import Data.Int (Int32)

39

40-- | Start a server at the specified address.

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

@@ -66,8 +66,8 @@ Source-Repository head

66Library

67 Build-Depends: base >= 4.3 && < 5,

68 binary >= 0.5 && < 0.6,

69− bytestring >= 0.9 && < 0.11,

70− transformers >= 0.2 && < 0.4

69+ transformers >= 0.2 && < 0.4,

70+ not-bytestring

71 Exposed-Modules: Network.Transport,

72 Network.Transport.Util

73 Network.Transport.Internal

network-transport/src/Network/Transport.hs+2−2

@@ -22,8 +22,8 @@ module Network.Transport ( -- * Types

22 , EventErrorCode(..)

23 ) where

24

25−import Data.ByteString (ByteString)

25+import Data.NotByteString (ByteString)

26−import qualified Data.ByteString.Char8 as BSC (unpack)

26+import qualified Data.NotByteString.Char8 as BSC (unpack)

27import Control.Exception (Exception)

28import Data.Typeable (Typeable)

29import Data.Binary (Binary)

network-transport/src/Network/Transport/Internal.hs+5−5

@@ -25,11 +25,11 @@ import Prelude hiding (catch)

25import Foreign.Storable (pokeByteOff, peekByteOff)

26import Foreign.C (CInt(..), CShort(..))

27import Foreign.ForeignPtr (withForeignPtr)

28−import Data.ByteString (ByteString)

28+import Data.NotByteString (ByteString)

29−import qualified Data.ByteString as BS (length)

29+import qualified Data.NotByteString as BS (length)

30−import qualified Data.ByteString.Internal as BSI ( unsafeCreate

30+import qualified Data.NotByteString.Internal as BSI ( unsafeCreate

31− , toForeignPtr

31+ , toForeignPtr

32− , inlinePerformIO)

32+ , inlinePerformIO)

33import Control.Monad.IO.Class (MonadIO, liftIO)

34import Control.Exception ( IOException

35 , SomeException

not-bytestring/LICENSEnew file+30

@@ -0,0 +1,30 @@

2+

4+

5+Redistribution and use in source and binary forms, with or without

6+modification, are permitted provided that the following conditions are met:

7+

8+ * Redistributions of source code must retain the above copyright

9+ notice, this list of conditions and the following disclaimer.

10+

11+ * Redistributions in binary form must reproduce the above

12+ copyright notice, this list of conditions and the following

13+ disclaimer in the documentation and/or other materials provided

14+ with the distribution.

15+

16+ * Neither the name of Edsko de Vries nor the names of other

17+ contributors may be used to endorse or promote products derived

18+ from this software without specific prior written permission.

19+

20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

not-bytestring/Setup.hsnew file+2

@@ -0,0 +1,2 @@

1+import Distribution.Simple

2+main = defaultMain

not-bytestring/not-bytestring.cabalnew file+34

@@ -0,0 +1,34 @@

1+-- Initial not-bytestring.cabal generated by cabal init. For further

2+-- documentation, see http://haskell.org/cabal/users-guide/

3+

4+name: not-bytestring

5+version: 0.1.0.0

6+synopsis: Not bytestring

7+-- description:

8+homepage: http://github.com/haskell-distribute/distributed-process

9+license: BSD3

10+license-file: LICENSE

11+author: Edsko de Vries

12+maintainer: edsko@well-typed.com

13+-- copyright:

14+category: Data

15+build-type: Simple

16+cabal-version: >=1.8

17+

18+library

19+ exposed-modules: Data.NotByteString

20+ Data.NotByteString.Internal

21+ Data.NotByteString.Char8

22+ Data.NotByteString.Lazy

23+ Data.NotByteString.Lazy.Char8

24+ Data.NotByteString.NBS

25+ Data.NotByteString.Lazy.Binary

26+ build-depends: base ==4.5.*,

27+ bytestring >= 0.9 && < 0.11,

28+ binary >= 0.5 && < 0.6,

29+ network >= 2.3 && < 2.4

30+ hs-source-dirs: src

31+ ghc-options: -Wall

32+ extensions: GeneralizedNewtypeDeriving,

33+ DeriveDataTypeable,

34+ BangPatterns

not-bytestring/src/Data/NotByteString.hsnew file+85

@@ -0,0 +1,85 @@

1+module Data.NotByteString

2+ ( ByteString(Nil, Cons)

3+ , fromString

4+ , toString

5+ , fromByteString

6+ , toByteString

7+ , length

8+ , concat

9+ , null

10+ , empty

11+ , splitAt

12+ , foldr

13+ , foldl'

14+ , (++)

15+ ) where

16+

17+import Prelude hiding (length, null, concat, splitAt, foldr, (++), reverse)

18+import qualified Prelude (length, null, splitAt, foldr)

19+import Data.Binary (Binary(get, put))

20+import Data.Typeable (Typeable)

21+import qualified Data.ByteString as BS (ByteString)

22+import qualified Data.ByteString.Char8 as BSC (pack, foldr)

23+import Control.Applicative ((<$>))

24+

25+data ByteString = Nil | Cons {-# UNPACK #-} !Char !ByteString

26+ deriving (Typeable, Eq, Ord)

27+

28+instance Show ByteString where

29+ show = toString

30+

31+instance Binary ByteString where

32+ get = fromByteString <$> get

33+ put = put . toByteString

34+

35+foldl' :: (a -> Char -> a) -> a -> ByteString -> a

36+foldl' f = go

37+ where

38+ go !acc Nil = acc

39+ go !acc (Cons c cs) = go (acc `f` c) cs

40+

41+foldr :: (Char -> a -> a) -> a -> ByteString -> a

42+foldr f e = go

43+ where

44+ go Nil = e

45+ go (Cons c cs) = c `f` go cs

46+

47+toString :: ByteString -> String

48+toString = foldr (:) []

49+

50+fromString :: String -> ByteString

51+fromString = Prelude.foldr Cons Nil

52+

53+fromByteString :: BS.ByteString -> ByteString

54+fromByteString = BSC.foldr Cons Nil

55+

56+toByteString :: ByteString -> BS.ByteString

57+toByteString = BSC.pack . toString

58+

59+length :: ByteString -> Int

60+length = foldl' (\l _ -> l + 1) 0

61+

62+(++) :: ByteString -> ByteString -> ByteString

63+xs ++ ys = foldr Cons ys xs

64+

65+concat :: [ByteString] -> ByteString

66+concat = Prelude.foldr (++) empty

67+

68+null :: ByteString -> Bool

69+null = foldr (\_ _ -> False) True

70+

71+empty :: ByteString

72+empty = Nil

73+

74+reverse :: ByteString -> ByteString

75+reverse = go Nil

76+ where

77+ go acc Nil = acc

78+ go acc (Cons c cs) = go (Cons c acc) cs

79+

80+splitAt :: Int -> ByteString -> (ByteString, ByteString)

81+splitAt = go Nil

82+ where

83+ go acc 0 cs = (reverse acc, cs)

84+ go acc _ Nil = (reverse acc, Nil)

85+ go acc n (Cons c cs) = go (Cons c acc) (n - 1) cs

not-bytestring/src/Data/NotByteString/Char8.hsnew file+24

@@ -0,0 +1,24 @@

1+module Data.NotByteString.Char8

2+ ( pack

3+ , unpack

4+ , split

5+ ) where

6+

7+import Data.NotByteString

8+ ( ByteString

9+ , fromString

10+ , toString

11+ , fromByteString

12+ , toByteString

13+ )

14+import qualified Data.ByteString.Char8 as BSC (split)

15+

16+pack :: String -> ByteString

17+pack = fromString

18+

19+unpack :: ByteString -> String

20+unpack = toString

21+

22+-- TODO: Avoid roundtrip

23+split :: Char -> ByteString -> [ByteString]

24+split c = map fromByteString . BSC.split c . toByteString

not-bytestring/src/Data/NotByteString/Internal.hsnew file+24

@@ -0,0 +1,24 @@

1+module Data.NotByteString.Internal

2+ ( unsafeCreate

3+ , toForeignPtr

4+ , inlinePerformIO

5+ ) where

6+

7+import Data.NotByteString (ByteString, fromByteString, toByteString)

8+import Foreign.Ptr (Ptr)

9+import Foreign.ForeignPtr (ForeignPtr)

10+import Data.Word (Word8)

11+import qualified Data.ByteString.Internal as BSI

12+ ( unsafeCreate

13+ , toForeignPtr

14+ , inlinePerformIO

15+ )

16+

17+unsafeCreate :: Int -> (Ptr Word8 -> IO ()) -> ByteString

18+unsafeCreate i f = fromByteString $ BSI.unsafeCreate i f

19+

20+toForeignPtr :: ByteString -> (ForeignPtr Word8, Int, Int)

21+toForeignPtr = BSI.toForeignPtr . toByteString

22+

23+inlinePerformIO :: IO a -> a

24+inlinePerformIO = BSI.inlinePerformIO

not-bytestring/src/Data/NotByteString/Lazy.hsnew file+101

@@ -0,0 +1,101 @@

1+module Data.NotByteString.Lazy

2+ ( ByteString(Nil, Cons)

3+ , fromString

4+ , toString

5+ , fromByteString

6+ , toByteString

7+ , length

8+ , concat

9+ , null

10+ , empty

11+ , splitAt

12+ , foldr

13+ , foldl'

14+ , (++)

15+ , toChunks

16+ , fromChunks

17+ ) where

18+

19+import Prelude hiding (length, null, concat, splitAt, foldr, (++), reverse)

20+import qualified Prelude (length, null, splitAt, foldr)

21+import Data.Binary (Binary(get, put))

22+import Data.Typeable (Typeable)

23+import qualified Data.ByteString.Lazy as BSL (ByteString)

24+import qualified Data.ByteString.Lazy.Char8 as BSLC (pack, foldr)

25+import qualified Data.NotByteString as Strict (ByteString(Nil, Cons), foldr)

26+import Control.Applicative ((<$>))

27+

28+data ByteString = Nil | Cons {-# UNPACK #-} !Char ByteString

29+ deriving (Typeable, Eq, Ord)

30+

31+instance Show ByteString where

32+ show = toString

33+

34+instance Binary ByteString where

35+ get = fromByteString <$> get

36+ put = put . toByteString

37+

38+foldl' :: (a -> Char -> a) -> a -> ByteString -> a

39+foldl' f = go

40+ where

41+ go !acc Nil = acc

42+ go !acc (Cons c cs) = go (acc `f` c) cs

43+

44+foldr :: (Char -> a -> a) -> a -> ByteString -> a

45+foldr f e = go

46+ where

47+ go Nil = e

48+ go (Cons c cs) = c `f` go cs

49+

50+toString :: ByteString -> String

51+toString = foldr (:) []

52+

53+fromString :: String -> ByteString

54+fromString = Prelude.foldr Cons Nil

55+

56+fromByteString :: BSL.ByteString -> ByteString

57+fromByteString = BSLC.foldr Cons Nil

58+

59+toByteString :: ByteString -> BSL.ByteString

60+toByteString = BSLC.pack . toString

61+

62+length :: ByteString -> Int

63+length = foldl' (\l _ -> l + 1) 0

64+

65+(++) :: ByteString -> ByteString -> ByteString

66+xs ++ ys = foldr Cons ys xs

67+

68+concat :: [ByteString] -> ByteString

69+concat = Prelude.foldr (++) empty

70+

71+null :: ByteString -> Bool

72+null = foldr (\_ _ -> False) True

73+

74+empty :: ByteString

75+empty = Nil

76+

77+reverse :: ByteString -> ByteString

78+reverse = go Nil

79+ where

80+ go acc Nil = acc

81+ go acc (Cons c cs) = go (Cons c acc) cs

82+

83+splitAt :: Int -> ByteString -> (ByteString, ByteString)

84+splitAt = go Nil

85+ where

86+ go acc 0 cs = (reverse acc, cs)

87+ go acc _ Nil = (reverse acc, Nil)

88+ go acc n (Cons c cs) = go (Cons c acc) (n - 1) cs

89+

90+toStrict :: ByteString -> Strict.ByteString

91+toStrict = foldr Strict.Cons Strict.Nil

92+

93+fromStrict :: Strict.ByteString -> ByteString

94+fromStrict = Strict.foldr Cons Nil

95+

96+-- | This does not preserve laziness

97+toChunks :: ByteString -> [Strict.ByteString]

98+toChunks = return . toStrict

99+

100+fromChunks :: [Strict.ByteString] -> ByteString

101+fromChunks = concat . map fromStrict

not-bytestring/src/Data/NotByteString/Lazy/Binary.hsnew file+14

@@ -0,0 +1,14 @@

1+module Data.NotByteString.Lazy.Binary

2+ ( encode

3+ , decode

4+ ) where

5+

6+import Data.NotByteString.Lazy (ByteString, fromByteString, toByteString)

7+import Data.Binary (Binary)

8+import qualified Data.Binary as Binary (encode, decode)

9+

10+encode :: Binary a => a -> ByteString

11+encode = fromByteString . Binary.encode

12+

13+decode :: Binary a => ByteString -> a

14+decode = Binary.decode . toByteString

not-bytestring/src/Data/NotByteString/Lazy/Char8.hsnew file+24

@@ -0,0 +1,24 @@

1+module Data.NotByteString.Lazy.Char8

2+ ( pack

3+ , unpack

4+ , split

5+ ) where

6+

7+import Data.NotByteString.Lazy

8+ ( ByteString

9+ , fromString

10+ , toString

11+ , fromByteString

12+ , toByteString

13+ )

14+import qualified Data.ByteString.Lazy.Char8 as BSC (split)

15+

16+pack :: String -> ByteString

17+pack = fromString

18+

19+unpack :: ByteString -> String

20+unpack = toString

21+

22+-- TODO: Avoid roundtrip

23+split :: Char -> ByteString -> [ByteString]

24+split c = map fromByteString . BSC.split c . toByteString

not-bytestring/src/Data/NotByteString/NBS.hsnew file+15

@@ -0,0 +1,15 @@

1+module Data.NotByteString.NBS

2+ ( recv

3+ , sendMany

4+ ) where

5+

6+import Control.Applicative ((<$>))

7+import Data.NotByteString (ByteString, fromByteString, toByteString)

8+import Network.Socket (Socket)

9+import qualified Network.Socket.ByteString as NSB (recv, sendMany)

10+

11+recv :: Socket -> Int -> IO ByteString

12+recv sock n = fromByteString <$> NSB.recv sock n

13+

14+sendMany :: Socket -> [ByteString] -> IO ()

15+sendMany sock = NSB.sendMany sock . map toByteString