{-# LANGUAGE RecursiveDo #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
-- |
-- Module: Network.Transport.InMemory.Internal
--
-- Internal part of the implementation. This module is for internal use
-- or advanced debuging. There are no guarantees about stability of this
-- module.
module Network.Transport.InMemory.Internal
  ( createTransportExposeInternals
    -- * Internal structures
  , TransportInternals(..)
  , TransportState(..)
  , ValidTransportState(..)
  , LocalEndPoint(..)
  , LocalEndPointState(..)
  , ValidLocalEndPointState(..)
  , LocalConnection(..)
  , LocalConnectionState(..)
    -- * Low level functionality
  , apiNewEndPoint
  , apiCloseEndPoint
  , apiBreakConnection
  , apiConnect
  , apiSend
  , apiClose
  ) where

import Network.Transport
import Network.Transport.Internal ( mapIOException )
import Control.Category ((>>>))
import Control.Concurrent.STM
import Control.Exception (handle, throw)
import Data.Map (Map)
import Data.Maybe (fromJust)
import Data.Monoid
import Data.Foldable
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BSC (pack)
import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))
import qualified Data.Accessor.Container as DAC (mapMaybe)
import Data.Typeable (Typeable)
import Prelude hiding (foldr)

data TransportState
  = TransportValid {-# UNPACK #-} !ValidTransportState
  | TransportClosed

data ValidTransportState = ValidTransportState
  { ValidTransportState -> Map EndPointAddress LocalEndPoint
_localEndPoints :: !(Map EndPointAddress LocalEndPoint)
  , ValidTransportState -> Int
_nextLocalEndPointId :: !Int
  }

data LocalEndPoint = LocalEndPoint
  { LocalEndPoint -> EndPointAddress
localEndPointAddress :: !EndPointAddress
  , LocalEndPoint -> TChan Event
localEndPointChannel :: !(TChan Event)
  , LocalEndPoint -> TVar LocalEndPointState
localEndPointState   :: !(TVar LocalEndPointState)
  }

data LocalEndPointState
  = LocalEndPointValid {-# UNPACK #-} !ValidLocalEndPointState
  | LocalEndPointClosed

data ValidLocalEndPointState = ValidLocalEndPointState
  { ValidLocalEndPointState -> ConnectionId
_nextConnectionId :: !ConnectionId
  , ValidLocalEndPointState
-> Map (EndPointAddress, ConnectionId) LocalConnection
_connections :: !(Map (EndPointAddress,ConnectionId) LocalConnection)
  , ValidLocalEndPointState
-> Map MulticastAddress (TVar (Set EndPointAddress))
_multigroups :: Map MulticastAddress (TVar (Set EndPointAddress))
  }

data LocalConnection = LocalConnection
  { LocalConnection -> ConnectionId
localConnectionId :: !ConnectionId
  , LocalConnection -> EndPointAddress
localConnectionLocalAddress :: !EndPointAddress
  , LocalConnection -> EndPointAddress
localConnectionRemoteAddress :: !EndPointAddress
  , LocalConnection -> TVar LocalConnectionState
localConnectionState :: !(TVar LocalConnectionState)
  }

data LocalConnectionState
  = LocalConnectionValid
  | LocalConnectionClosed
  | LocalConnectionFailed

newtype TransportInternals = TransportInternals (TVar TransportState)

-- | Create a new Transport exposing internal state.
--
-- Useful for testing and/or debugging purposes.
-- Should not be used in production. No guarantee as to the stability of the internals API.
createTransportExposeInternals :: IO (Transport, TransportInternals)
createTransportExposeInternals :: IO (Transport, TransportInternals)
createTransportExposeInternals = do
  TVar TransportState
state <- TransportState -> IO (TVar TransportState)
forall a. a -> IO (TVar a)
newTVarIO (TransportState -> IO (TVar TransportState))
-> TransportState -> IO (TVar TransportState)
forall a b. (a -> b) -> a -> b
$ ValidTransportState -> TransportState
TransportValid (ValidTransportState -> TransportState)
-> ValidTransportState -> TransportState
forall a b. (a -> b) -> a -> b
$ ValidTransportState
    { _localEndPoints :: Map EndPointAddress LocalEndPoint
_localEndPoints = Map EndPointAddress LocalEndPoint
forall k a. Map k a
Map.empty
    , _nextLocalEndPointId :: Int
_nextLocalEndPointId = Int
0
    }
  (Transport, TransportInternals)
-> IO (Transport, TransportInternals)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Transport
    { newEndPoint :: IO (Either (TransportError NewEndPointErrorCode) EndPoint)
newEndPoint    = TVar TransportState
-> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
apiNewEndPoint TVar TransportState
state
    , closeTransport :: IO ()
closeTransport = do
        -- transactions are splitted into smaller ones intentionally
        TransportState
old <- STM TransportState -> IO TransportState
forall a. STM a -> IO a
atomically (STM TransportState -> IO TransportState)
-> STM TransportState -> IO TransportState
forall a b. (a -> b) -> a -> b
$ TVar TransportState -> TransportState -> STM TransportState
forall a. TVar a -> a -> STM a
swapTVar TVar TransportState
state TransportState
TransportClosed
        case TransportState
old of
          TransportState
TransportClosed -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          TransportValid ValidTransportState
tvst -> do
            Map EndPointAddress LocalEndPoint
-> (LocalEndPoint -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ValidTransportState
tvst ValidTransportState
-> T ValidTransportState (Map EndPointAddress LocalEndPoint)
-> Map EndPointAddress LocalEndPoint
forall r a. r -> T r a -> a
^. T ValidTransportState (Map EndPointAddress LocalEndPoint)
localEndPoints) ((LocalEndPoint -> IO ()) -> IO ())
-> (LocalEndPoint -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LocalEndPoint
l -> do
              Map (EndPointAddress, ConnectionId) LocalConnection
cons <- STM (Map (EndPointAddress, ConnectionId) LocalConnection)
-> IO (Map (EndPointAddress, ConnectionId) LocalConnection)
forall a. STM a -> IO a
atomically (STM (Map (EndPointAddress, ConnectionId) LocalConnection)
 -> IO (Map (EndPointAddress, ConnectionId) LocalConnection))
-> STM (Map (EndPointAddress, ConnectionId) LocalConnection)
-> IO (Map (EndPointAddress, ConnectionId) LocalConnection)
forall a b. (a -> b) -> a -> b
$ LocalEndPoint
-> (ValidLocalEndPointState
    -> STM (Map (EndPointAddress, ConnectionId) LocalConnection))
-> STM (Map (EndPointAddress, ConnectionId) LocalConnection)
forall m.
Monoid m =>
LocalEndPoint -> (ValidLocalEndPointState -> STM m) -> STM m
whenValidLocalEndPointState LocalEndPoint
l ((ValidLocalEndPointState
  -> STM (Map (EndPointAddress, ConnectionId) LocalConnection))
 -> STM (Map (EndPointAddress, ConnectionId) LocalConnection))
-> (ValidLocalEndPointState
    -> STM (Map (EndPointAddress, ConnectionId) LocalConnection))
-> STM (Map (EndPointAddress, ConnectionId) LocalConnection)
forall a b. (a -> b) -> a -> b
$ \ValidLocalEndPointState
lvst -> do
                TChan Event -> Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan (LocalEndPoint -> TChan Event
localEndPointChannel LocalEndPoint
l) Event
EndPointClosed
                TVar LocalEndPointState -> LocalEndPointState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar  (LocalEndPoint -> TVar LocalEndPointState
localEndPointState LocalEndPoint
l) LocalEndPointState
LocalEndPointClosed
                Map (EndPointAddress, ConnectionId) LocalConnection
-> STM (Map (EndPointAddress, ConnectionId) LocalConnection)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidLocalEndPointState
lvst ValidLocalEndPointState
-> T ValidLocalEndPointState
     (Map (EndPointAddress, ConnectionId) LocalConnection)
-> Map (EndPointAddress, ConnectionId) LocalConnection
forall r a. r -> T r a -> a
^. T ValidLocalEndPointState
  (Map (EndPointAddress, ConnectionId) LocalConnection)
connections)
              Map (EndPointAddress, ConnectionId) LocalConnection
-> (LocalConnection -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Map (EndPointAddress, ConnectionId) LocalConnection
cons ((LocalConnection -> IO ()) -> IO ())
-> (LocalConnection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LocalConnection
con -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
                TVar LocalConnectionState -> LocalConnectionState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (LocalConnection -> TVar LocalConnectionState
localConnectionState LocalConnection
con) LocalConnectionState
LocalConnectionClosed
    }, TVar TransportState -> TransportInternals
TransportInternals TVar TransportState
state)


-- | Create a new end point.
apiNewEndPoint :: TVar TransportState
               -> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
apiNewEndPoint :: TVar TransportState
-> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
apiNewEndPoint TVar TransportState
state = (TransportError NewEndPointErrorCode
 -> IO (Either (TransportError NewEndPointErrorCode) EndPoint))
-> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
-> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (Either (TransportError NewEndPointErrorCode) EndPoint
-> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (TransportError NewEndPointErrorCode) EndPoint
 -> IO (Either (TransportError NewEndPointErrorCode) EndPoint))
-> (TransportError NewEndPointErrorCode
    -> Either (TransportError NewEndPointErrorCode) EndPoint)
-> TransportError NewEndPointErrorCode
-> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransportError NewEndPointErrorCode
-> Either (TransportError NewEndPointErrorCode) EndPoint
forall a b. a -> Either a b
Left) (IO (Either (TransportError NewEndPointErrorCode) EndPoint)
 -> IO (Either (TransportError NewEndPointErrorCode) EndPoint))
-> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
-> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
forall a b. (a -> b) -> a -> b
$ STM (Either (TransportError NewEndPointErrorCode) EndPoint)
-> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
forall a. STM a -> IO a
atomically (STM (Either (TransportError NewEndPointErrorCode) EndPoint)
 -> IO (Either (TransportError NewEndPointErrorCode) EndPoint))
-> STM (Either (TransportError NewEndPointErrorCode) EndPoint)
-> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
forall a b. (a -> b) -> a -> b
$ do
  TChan Event
chan <- STM (TChan Event)
forall a. STM (TChan a)
newTChan
  (LocalEndPoint
lep,EndPointAddress
addr) <- TVar TransportState
-> NewEndPointErrorCode
-> (ValidTransportState -> STM (LocalEndPoint, EndPointAddress))
-> STM (LocalEndPoint, EndPointAddress)
forall e a.
(Typeable e, Show e) =>
TVar TransportState -> e -> (ValidTransportState -> STM a) -> STM a
withValidTransportState TVar TransportState
state NewEndPointErrorCode
NewEndPointFailed ((ValidTransportState -> STM (LocalEndPoint, EndPointAddress))
 -> STM (LocalEndPoint, EndPointAddress))
-> (ValidTransportState -> STM (LocalEndPoint, EndPointAddress))
-> STM (LocalEndPoint, EndPointAddress)
forall a b. (a -> b) -> a -> b
$ \ValidTransportState
vst -> do
    TVar LocalEndPointState
lepState <- LocalEndPointState -> STM (TVar LocalEndPointState)
forall a. a -> STM (TVar a)
newTVar (LocalEndPointState -> STM (TVar LocalEndPointState))
-> LocalEndPointState -> STM (TVar LocalEndPointState)
forall a b. (a -> b) -> a -> b
$ ValidLocalEndPointState -> LocalEndPointState
LocalEndPointValid (ValidLocalEndPointState -> LocalEndPointState)
-> ValidLocalEndPointState -> LocalEndPointState
forall a b. (a -> b) -> a -> b
$ ValidLocalEndPointState
      { _nextConnectionId :: ConnectionId
_nextConnectionId = ConnectionId
1
      , _connections :: Map (EndPointAddress, ConnectionId) LocalConnection
_connections = Map (EndPointAddress, ConnectionId) LocalConnection
forall k a. Map k a
Map.empty
      , _multigroups :: Map MulticastAddress (TVar (Set EndPointAddress))
_multigroups = Map MulticastAddress (TVar (Set EndPointAddress))
forall k a. Map k a
Map.empty
      }
    let r :: ValidTransportState
r = Accessor ValidTransportState Int
nextLocalEndPointId Accessor ValidTransportState Int
-> (Int -> Int) -> ValidTransportState -> ValidTransportState
forall r a. T r a -> (a -> a) -> r -> r
^: (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (ValidTransportState -> ValidTransportState)
-> ValidTransportState -> ValidTransportState
forall a b. (a -> b) -> a -> b
$ ValidTransportState
vst
        addr :: EndPointAddress
addr = ByteString -> EndPointAddress
EndPointAddress (ByteString -> EndPointAddress)
-> (Int -> ByteString) -> Int -> EndPointAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BSC.pack (String -> ByteString) -> (Int -> String) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> EndPointAddress) -> Int -> EndPointAddress
forall a b. (a -> b) -> a -> b
$ ValidTransportState
r ValidTransportState -> Accessor ValidTransportState Int -> Int
forall r a. r -> T r a -> a
^. Accessor ValidTransportState Int
nextLocalEndPointId
        lep :: LocalEndPoint
lep = LocalEndPoint
          { localEndPointAddress :: EndPointAddress
localEndPointAddress = EndPointAddress
addr
          , localEndPointChannel :: TChan Event
localEndPointChannel = TChan Event
chan
          , localEndPointState :: TVar LocalEndPointState
localEndPointState = TVar LocalEndPointState
lepState
          }
    TVar TransportState -> TransportState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar TransportState
state (ValidTransportState -> TransportState
TransportValid (ValidTransportState -> TransportState)
-> ValidTransportState -> TransportState
forall a b. (a -> b) -> a -> b
$ EndPointAddress
-> Accessor ValidTransportState (Maybe LocalEndPoint)
localEndPointAt EndPointAddress
addr Accessor ValidTransportState (Maybe LocalEndPoint)
-> Maybe LocalEndPoint
-> ValidTransportState
-> ValidTransportState
forall r a. T r a -> a -> r -> r
^= LocalEndPoint -> Maybe LocalEndPoint
forall a. a -> Maybe a
Just LocalEndPoint
lep (ValidTransportState -> ValidTransportState)
-> ValidTransportState -> ValidTransportState
forall a b. (a -> b) -> a -> b
$ ValidTransportState
r)
    (LocalEndPoint, EndPointAddress)
-> STM (LocalEndPoint, EndPointAddress)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalEndPoint
lep, EndPointAddress
addr)
  Either (TransportError NewEndPointErrorCode) EndPoint
-> STM (Either (TransportError NewEndPointErrorCode) EndPoint)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (TransportError NewEndPointErrorCode) EndPoint
 -> STM (Either (TransportError NewEndPointErrorCode) EndPoint))
-> Either (TransportError NewEndPointErrorCode) EndPoint
-> STM (Either (TransportError NewEndPointErrorCode) EndPoint)
forall a b. (a -> b) -> a -> b
$ EndPoint -> Either (TransportError NewEndPointErrorCode) EndPoint
forall a b. b -> Either a b
Right (EndPoint -> Either (TransportError NewEndPointErrorCode) EndPoint)
-> EndPoint
-> Either (TransportError NewEndPointErrorCode) EndPoint
forall a b. (a -> b) -> a -> b
$ EndPoint
    { receive :: IO Event
receive       = STM Event -> IO Event
forall a. STM a -> IO a
atomically (STM Event -> IO Event) -> STM Event -> IO Event
forall a b. (a -> b) -> a -> b
$ do
        Maybe Event
result <- TChan Event -> STM (Maybe Event)
forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan Event
chan
        case Maybe Event
result of
          Maybe Event
Nothing -> do LocalEndPointState
st <- TVar LocalEndPointState -> STM LocalEndPointState
forall a. TVar a -> STM a
readTVar (LocalEndPoint -> TVar LocalEndPointState
localEndPointState LocalEndPoint
lep)
                        case LocalEndPointState
st of
                          LocalEndPointState
LocalEndPointClosed ->
                            IOError -> STM Event
forall e a. Exception e => e -> STM a
throwSTM (String -> IOError
userError String
"Channel is closed.")
                          LocalEndPointValid{} -> STM Event
forall a. STM a
retry
          Just Event
x -> Event -> STM Event
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Event
x
    , address :: EndPointAddress
address       = EndPointAddress
addr
    , connect :: EndPointAddress
-> Reliability
-> ConnectHints
-> IO (Either (TransportError ConnectErrorCode) Connection)
connect       = EndPointAddress
-> TVar TransportState
-> EndPointAddress
-> Reliability
-> ConnectHints
-> IO (Either (TransportError ConnectErrorCode) Connection)
apiConnect EndPointAddress
addr TVar TransportState
state
    , closeEndPoint :: IO ()
closeEndPoint = TVar TransportState -> EndPointAddress -> IO ()
apiCloseEndPoint TVar TransportState
state EndPointAddress
addr
    , newMulticastGroup :: IO
  (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
newMulticastGroup     = Either (TransportError NewMulticastGroupErrorCode) MulticastGroup
-> IO
     (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup
 -> IO
      (Either
         (TransportError NewMulticastGroupErrorCode) MulticastGroup))
-> Either
     (TransportError NewMulticastGroupErrorCode) MulticastGroup
-> IO
     (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
forall a b. (a -> b) -> a -> b
$ TransportError NewMulticastGroupErrorCode
-> Either
     (TransportError NewMulticastGroupErrorCode) MulticastGroup
forall a b. a -> Either a b
Left (TransportError NewMulticastGroupErrorCode
 -> Either
      (TransportError NewMulticastGroupErrorCode) MulticastGroup)
-> TransportError NewMulticastGroupErrorCode
-> Either
     (TransportError NewMulticastGroupErrorCode) MulticastGroup
forall a b. (a -> b) -> a -> b
$ TransportError NewMulticastGroupErrorCode
newMulticastGroupError
    , resolveMulticastGroup :: MulticastAddress
-> IO
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
resolveMulticastGroup = Either
  (TransportError ResolveMulticastGroupErrorCode) MulticastGroup
-> IO
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (TransportError ResolveMulticastGroupErrorCode) MulticastGroup
 -> IO
      (Either
         (TransportError ResolveMulticastGroupErrorCode) MulticastGroup))
-> (MulticastAddress
    -> Either
         (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
-> MulticastAddress
-> IO
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransportError ResolveMulticastGroupErrorCode
-> Either
     (TransportError ResolveMulticastGroupErrorCode) MulticastGroup
forall a b. a -> Either a b
Left (TransportError ResolveMulticastGroupErrorCode
 -> Either
      (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
-> (MulticastAddress
    -> TransportError ResolveMulticastGroupErrorCode)
-> MulticastAddress
-> Either
     (TransportError ResolveMulticastGroupErrorCode) MulticastGroup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransportError ResolveMulticastGroupErrorCode
-> MulticastAddress
-> TransportError ResolveMulticastGroupErrorCode
forall a b. a -> b -> a
const TransportError ResolveMulticastGroupErrorCode
resolveMulticastGroupError
    }
  where
    -- see [Multicast] section
    newMulticastGroupError :: TransportError NewMulticastGroupErrorCode
newMulticastGroupError =
      NewMulticastGroupErrorCode
-> String -> TransportError NewMulticastGroupErrorCode
forall error. error -> String -> TransportError error
TransportError NewMulticastGroupErrorCode
NewMulticastGroupUnsupported String
"Multicast not supported"
    resolveMulticastGroupError :: TransportError ResolveMulticastGroupErrorCode
resolveMulticastGroupError =
      ResolveMulticastGroupErrorCode
-> String -> TransportError ResolveMulticastGroupErrorCode
forall error. error -> String -> TransportError error
TransportError ResolveMulticastGroupErrorCode
ResolveMulticastGroupUnsupported String
"Multicast not supported"

apiCloseEndPoint :: TVar TransportState -> EndPointAddress -> IO ()
apiCloseEndPoint :: TVar TransportState -> EndPointAddress -> IO ()
apiCloseEndPoint TVar TransportState
state EndPointAddress
addr = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar TransportState -> (ValidTransportState -> STM ()) -> STM ()
forall m.
Monoid m =>
TVar TransportState -> (ValidTransportState -> STM m) -> STM m
whenValidTransportState TVar TransportState
state ((ValidTransportState -> STM ()) -> STM ())
-> (ValidTransportState -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \ValidTransportState
vst ->
    Maybe LocalEndPoint -> (LocalEndPoint -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ValidTransportState
vst ValidTransportState
-> Accessor ValidTransportState (Maybe LocalEndPoint)
-> Maybe LocalEndPoint
forall r a. r -> T r a -> a
^. EndPointAddress
-> Accessor ValidTransportState (Maybe LocalEndPoint)
localEndPointAt EndPointAddress
addr) ((LocalEndPoint -> STM ()) -> STM ())
-> (LocalEndPoint -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \LocalEndPoint
lep -> do
      LocalEndPointState
old <- TVar LocalEndPointState
-> LocalEndPointState -> STM LocalEndPointState
forall a. TVar a -> a -> STM a
swapTVar (LocalEndPoint -> TVar LocalEndPointState
localEndPointState LocalEndPoint
lep) LocalEndPointState
LocalEndPointClosed
      case LocalEndPointState
old of
        LocalEndPointState
LocalEndPointClosed -> () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        LocalEndPointValid ValidLocalEndPointState
lepvst -> do
          [LocalConnection] -> (LocalConnection -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map (EndPointAddress, ConnectionId) LocalConnection
-> [LocalConnection]
forall k a. Map k a -> [a]
Map.elems (ValidLocalEndPointState
lepvst ValidLocalEndPointState
-> T ValidLocalEndPointState
     (Map (EndPointAddress, ConnectionId) LocalConnection)
-> Map (EndPointAddress, ConnectionId) LocalConnection
forall r a. r -> T r a -> a
^. T ValidLocalEndPointState
  (Map (EndPointAddress, ConnectionId) LocalConnection)
connections)) ((LocalConnection -> STM ()) -> STM ())
-> (LocalConnection -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \LocalConnection
lconn -> do
            LocalConnectionState
st <- TVar LocalConnectionState
-> LocalConnectionState -> STM LocalConnectionState
forall a. TVar a -> a -> STM a
swapTVar (LocalConnection -> TVar LocalConnectionState
localConnectionState LocalConnection
lconn) LocalConnectionState
LocalConnectionClosed
            case LocalConnectionState
st of
              LocalConnectionState
LocalConnectionClosed -> () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              LocalConnectionState
LocalConnectionFailed -> () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              LocalConnectionState
_ -> Maybe LocalEndPoint -> (LocalEndPoint -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ValidTransportState
vst ValidTransportState
-> Accessor ValidTransportState (Maybe LocalEndPoint)
-> Maybe LocalEndPoint
forall r a. r -> T r a -> a
^. EndPointAddress
-> Accessor ValidTransportState (Maybe LocalEndPoint)
localEndPointAt (LocalConnection -> EndPointAddress
localConnectionRemoteAddress LocalConnection
lconn)) ((LocalEndPoint -> STM ()) -> STM ())
-> (LocalEndPoint -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \LocalEndPoint
thep ->
                     LocalEndPoint -> (ValidLocalEndPointState -> STM ()) -> STM ()
forall m.
Monoid m =>
LocalEndPoint -> (ValidLocalEndPointState -> STM m) -> STM m
whenValidLocalEndPointState LocalEndPoint
thep ((ValidLocalEndPointState -> STM ()) -> STM ())
-> (ValidLocalEndPointState -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \ValidLocalEndPointState
_ -> do
                        TChan Event -> Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan (LocalEndPoint -> TChan Event
localEndPointChannel LocalEndPoint
thep)
                                   (ConnectionId -> Event
ConnectionClosed (LocalConnection -> ConnectionId
localConnectionId LocalConnection
lconn))
          TChan Event -> Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan (LocalEndPoint -> TChan Event
localEndPointChannel LocalEndPoint
lep) Event
EndPointClosed
          TVar LocalEndPointState -> LocalEndPointState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar  (LocalEndPoint -> TVar LocalEndPointState
localEndPointState LocalEndPoint
lep)    LocalEndPointState
LocalEndPointClosed
      TVar TransportState -> TransportState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar TransportState
state (ValidTransportState -> TransportState
TransportValid (ValidTransportState -> TransportState)
-> ValidTransportState -> TransportState
forall a b. (a -> b) -> a -> b
$ (T ValidTransportState (Map EndPointAddress LocalEndPoint)
localEndPoints T ValidTransportState (Map EndPointAddress LocalEndPoint)
-> (Map EndPointAddress LocalEndPoint
    -> Map EndPointAddress LocalEndPoint)
-> ValidTransportState
-> ValidTransportState
forall r a. T r a -> (a -> a) -> r -> r
^: EndPointAddress
-> Map EndPointAddress LocalEndPoint
-> Map EndPointAddress LocalEndPoint
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete EndPointAddress
addr) ValidTransportState
vst)

-- | Tear down functions that should be called in case if conncetion fails.
apiBreakConnection :: TVar TransportState
                   -> EndPointAddress
                   -> EndPointAddress
                   -> String
                   -> STM ()
apiBreakConnection :: TVar TransportState
-> EndPointAddress -> EndPointAddress -> String -> STM ()
apiBreakConnection TVar TransportState
state EndPointAddress
us EndPointAddress
them String
msg
  | EndPointAddress
us EndPointAddress -> EndPointAddress -> Bool
forall a. Eq a => a -> a -> Bool
== EndPointAddress
them = () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise  = TVar TransportState -> (ValidTransportState -> STM ()) -> STM ()
forall m.
Monoid m =>
TVar TransportState -> (ValidTransportState -> STM m) -> STM m
whenValidTransportState TVar TransportState
state ((ValidTransportState -> STM ()) -> STM ())
-> (ValidTransportState -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \ValidTransportState
vst -> do
      ValidTransportState -> EndPointAddress -> EndPointAddress -> STM ()
breakOne ValidTransportState
vst EndPointAddress
us EndPointAddress
them STM () -> STM () -> STM ()
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ValidTransportState -> EndPointAddress -> EndPointAddress -> STM ()
breakOne ValidTransportState
vst EndPointAddress
them EndPointAddress
us
  where
    breakOne :: ValidTransportState -> EndPointAddress -> EndPointAddress -> STM ()
breakOne ValidTransportState
vst EndPointAddress
a EndPointAddress
b = do
      Maybe LocalEndPoint -> (LocalEndPoint -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ValidTransportState
vst ValidTransportState
-> Accessor ValidTransportState (Maybe LocalEndPoint)
-> Maybe LocalEndPoint
forall r a. r -> T r a -> a
^. EndPointAddress
-> Accessor ValidTransportState (Maybe LocalEndPoint)
localEndPointAt EndPointAddress
a) ((LocalEndPoint -> STM ()) -> STM ())
-> (LocalEndPoint -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \LocalEndPoint
lep ->
        LocalEndPoint -> (ValidLocalEndPointState -> STM ()) -> STM ()
forall m.
Monoid m =>
LocalEndPoint -> (ValidLocalEndPointState -> STM m) -> STM m
whenValidLocalEndPointState LocalEndPoint
lep ((ValidLocalEndPointState -> STM ()) -> STM ())
-> (ValidLocalEndPointState -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \ValidLocalEndPointState
lepvst -> do
          let (Map (EndPointAddress, ConnectionId) LocalConnection
cl, Map (EndPointAddress, ConnectionId) LocalConnection
other) = ((EndPointAddress, ConnectionId) -> LocalConnection -> Bool)
-> Map (EndPointAddress, ConnectionId) LocalConnection
-> (Map (EndPointAddress, ConnectionId) LocalConnection,
    Map (EndPointAddress, ConnectionId) LocalConnection)
forall k a. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partitionWithKey (\(EndPointAddress
addr,ConnectionId
_) LocalConnection
_ -> EndPointAddress
addr EndPointAddress -> EndPointAddress -> Bool
forall a. Eq a => a -> a -> Bool
== EndPointAddress
b)
                                                 (ValidLocalEndPointState
lepvst ValidLocalEndPointState
-> T ValidLocalEndPointState
     (Map (EndPointAddress, ConnectionId) LocalConnection)
-> Map (EndPointAddress, ConnectionId) LocalConnection
forall r a. r -> T r a -> a
^.T ValidLocalEndPointState
  (Map (EndPointAddress, ConnectionId) LocalConnection)
connections)
          Map (EndPointAddress, ConnectionId) LocalConnection
-> (LocalConnection -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Map (EndPointAddress, ConnectionId) LocalConnection
cl ((LocalConnection -> STM ()) -> STM ())
-> (LocalConnection -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \LocalConnection
c -> TVar LocalConnectionState
-> (LocalConnectionState -> LocalConnectionState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (LocalConnection -> TVar LocalConnectionState
localConnectionState LocalConnection
c)
                                      (\LocalConnectionState
x -> case LocalConnectionState
x of
                                               LocalConnectionState
LocalConnectionValid -> LocalConnectionState
LocalConnectionFailed
                                               LocalConnectionState
_ -> LocalConnectionState
x)
          TChan Event -> Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan (LocalEndPoint -> TChan Event
localEndPointChannel LocalEndPoint
lep)
                     (TransportError EventErrorCode -> Event
ErrorEvent (EventErrorCode -> String -> TransportError EventErrorCode
forall error. error -> String -> TransportError error
TransportError (EndPointAddress -> EventErrorCode
EventConnectionLost EndPointAddress
b) String
msg))
          TVar LocalEndPointState -> LocalEndPointState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (LocalEndPoint -> TVar LocalEndPointState
localEndPointState LocalEndPoint
lep)
                    (ValidLocalEndPointState -> LocalEndPointState
LocalEndPointValid (ValidLocalEndPointState -> LocalEndPointState)
-> ValidLocalEndPointState -> LocalEndPointState
forall a b. (a -> b) -> a -> b
$ (T ValidLocalEndPointState
  (Map (EndPointAddress, ConnectionId) LocalConnection)
connections T ValidLocalEndPointState
  (Map (EndPointAddress, ConnectionId) LocalConnection)
-> Map (EndPointAddress, ConnectionId) LocalConnection
-> ValidLocalEndPointState
-> ValidLocalEndPointState
forall r a. T r a -> a -> r -> r
^= Map (EndPointAddress, ConnectionId) LocalConnection
other) ValidLocalEndPointState
lepvst)


-- | Create a new connection
apiConnect :: EndPointAddress
           -> TVar TransportState
           -> EndPointAddress
           -> Reliability
           -> ConnectHints
           -> IO (Either (TransportError ConnectErrorCode) Connection)
apiConnect :: EndPointAddress
-> TVar TransportState
-> EndPointAddress
-> Reliability
-> ConnectHints
-> IO (Either (TransportError ConnectErrorCode) Connection)
apiConnect EndPointAddress
ourAddress TVar TransportState
state EndPointAddress
theirAddress Reliability
_reliability ConnectHints
_hints = do
    (TransportError ConnectErrorCode
 -> IO (Either (TransportError ConnectErrorCode) Connection))
-> IO (Either (TransportError ConnectErrorCode) Connection)
-> IO (Either (TransportError ConnectErrorCode) Connection)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (Either (TransportError ConnectErrorCode) Connection
-> IO (Either (TransportError ConnectErrorCode) Connection)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (TransportError ConnectErrorCode) Connection
 -> IO (Either (TransportError ConnectErrorCode) Connection))
-> (TransportError ConnectErrorCode
    -> Either (TransportError ConnectErrorCode) Connection)
-> TransportError ConnectErrorCode
-> IO (Either (TransportError ConnectErrorCode) Connection)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransportError ConnectErrorCode
-> Either (TransportError ConnectErrorCode) Connection
forall a b. a -> Either a b
Left) (IO (Either (TransportError ConnectErrorCode) Connection)
 -> IO (Either (TransportError ConnectErrorCode) Connection))
-> IO (Either (TransportError ConnectErrorCode) Connection)
-> IO (Either (TransportError ConnectErrorCode) Connection)
forall a b. (a -> b) -> a -> b
$ (Connection -> Either (TransportError ConnectErrorCode) Connection)
-> IO Connection
-> IO (Either (TransportError ConnectErrorCode) Connection)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Connection -> Either (TransportError ConnectErrorCode) Connection
forall a b. b -> Either a b
Right (IO Connection
 -> IO (Either (TransportError ConnectErrorCode) Connection))
-> IO Connection
-> IO (Either (TransportError ConnectErrorCode) Connection)
forall a b. (a -> b) -> a -> b
$ STM Connection -> IO Connection
forall a. STM a -> IO a
atomically (STM Connection -> IO Connection)
-> STM Connection -> IO Connection
forall a b. (a -> b) -> a -> b
$ do
      (TChan Event
chan, LocalConnection
lconn) <- do
        TVar TransportState
-> ConnectErrorCode
-> (ValidTransportState -> STM (TChan Event, LocalConnection))
-> STM (TChan Event, LocalConnection)
forall e a.
(Typeable e, Show e) =>
TVar TransportState -> e -> (ValidTransportState -> STM a) -> STM a
withValidTransportState TVar TransportState
state ConnectErrorCode
ConnectFailed ((ValidTransportState -> STM (TChan Event, LocalConnection))
 -> STM (TChan Event, LocalConnection))
-> (ValidTransportState -> STM (TChan Event, LocalConnection))
-> STM (TChan Event, LocalConnection)
forall a b. (a -> b) -> a -> b
$ \ValidTransportState
vst -> do
          LocalEndPoint
ourlep <- case ValidTransportState
vst ValidTransportState
-> Accessor ValidTransportState (Maybe LocalEndPoint)
-> Maybe LocalEndPoint
forall r a. r -> T r a -> a
^. EndPointAddress
-> Accessor ValidTransportState (Maybe LocalEndPoint)
localEndPointAt EndPointAddress
ourAddress of
                      Maybe LocalEndPoint
Nothing ->
                        TransportError ConnectErrorCode -> STM LocalEndPoint
forall e a. Exception e => e -> STM a
throwSTM (TransportError ConnectErrorCode -> STM LocalEndPoint)
-> TransportError ConnectErrorCode -> STM LocalEndPoint
forall a b. (a -> b) -> a -> b
$ ConnectErrorCode -> String -> TransportError ConnectErrorCode
forall error. error -> String -> TransportError error
TransportError ConnectErrorCode
ConnectFailed String
"Endpoint closed"
                      Just LocalEndPoint
x  -> LocalEndPoint -> STM LocalEndPoint
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return LocalEndPoint
x
          LocalEndPoint
theirlep <- case ValidTransportState
vst ValidTransportState
-> Accessor ValidTransportState (Maybe LocalEndPoint)
-> Maybe LocalEndPoint
forall r a. r -> T r a -> a
^. EndPointAddress
-> Accessor ValidTransportState (Maybe LocalEndPoint)
localEndPointAt EndPointAddress
theirAddress of
                        Maybe LocalEndPoint
Nothing ->
                          TransportError ConnectErrorCode -> STM LocalEndPoint
forall e a. Exception e => e -> STM a
throwSTM (TransportError ConnectErrorCode -> STM LocalEndPoint)
-> TransportError ConnectErrorCode -> STM LocalEndPoint
forall a b. (a -> b) -> a -> b
$ ConnectErrorCode -> String -> TransportError ConnectErrorCode
forall error. error -> String -> TransportError error
TransportError ConnectErrorCode
ConnectNotFound String
"Endpoint not found"
                        Just LocalEndPoint
x  -> LocalEndPoint -> STM LocalEndPoint
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return LocalEndPoint
x
          ConnectionId
conid <- LocalEndPoint
-> ConnectErrorCode
-> (ValidLocalEndPointState -> STM ConnectionId)
-> STM ConnectionId
forall e a.
(Typeable e, Show e) =>
LocalEndPoint -> e -> (ValidLocalEndPointState -> STM a) -> STM a
withValidLocalEndPointState LocalEndPoint
theirlep ConnectErrorCode
ConnectFailed ((ValidLocalEndPointState -> STM ConnectionId) -> STM ConnectionId)
-> (ValidLocalEndPointState -> STM ConnectionId)
-> STM ConnectionId
forall a b. (a -> b) -> a -> b
$ \ValidLocalEndPointState
lepvst -> do
            let r :: ValidLocalEndPointState
r = Accessor ValidLocalEndPointState ConnectionId
nextConnectionId Accessor ValidLocalEndPointState ConnectionId
-> (ConnectionId -> ConnectionId)
-> ValidLocalEndPointState
-> ValidLocalEndPointState
forall r a. T r a -> (a -> a) -> r -> r
^: (ConnectionId -> ConnectionId -> ConnectionId
forall a. Num a => a -> a -> a
+ ConnectionId
1) (ValidLocalEndPointState -> ValidLocalEndPointState)
-> ValidLocalEndPointState -> ValidLocalEndPointState
forall a b. (a -> b) -> a -> b
$ ValidLocalEndPointState
lepvst
            TVar LocalEndPointState -> LocalEndPointState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (LocalEndPoint -> TVar LocalEndPointState
localEndPointState LocalEndPoint
theirlep) (ValidLocalEndPointState -> LocalEndPointState
LocalEndPointValid ValidLocalEndPointState
r)
            ConnectionId -> STM ConnectionId
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidLocalEndPointState
r ValidLocalEndPointState
-> Accessor ValidLocalEndPointState ConnectionId -> ConnectionId
forall r a. r -> T r a -> a
^. Accessor ValidLocalEndPointState ConnectionId
nextConnectionId)
          LocalEndPoint
-> ConnectErrorCode
-> (ValidLocalEndPointState -> STM (TChan Event, LocalConnection))
-> STM (TChan Event, LocalConnection)
forall e a.
(Typeable e, Show e) =>
LocalEndPoint -> e -> (ValidLocalEndPointState -> STM a) -> STM a
withValidLocalEndPointState LocalEndPoint
ourlep ConnectErrorCode
ConnectFailed ((ValidLocalEndPointState -> STM (TChan Event, LocalConnection))
 -> STM (TChan Event, LocalConnection))
-> (ValidLocalEndPointState -> STM (TChan Event, LocalConnection))
-> STM (TChan Event, LocalConnection)
forall a b. (a -> b) -> a -> b
$ \ValidLocalEndPointState
lepvst -> do
            TVar LocalConnectionState
lconnState <- LocalConnectionState -> STM (TVar LocalConnectionState)
forall a. a -> STM (TVar a)
newTVar LocalConnectionState
LocalConnectionValid
            let lconn :: LocalConnection
lconn = LocalConnection
                           { localConnectionId :: ConnectionId
localConnectionId = ConnectionId
conid
                           , localConnectionLocalAddress :: EndPointAddress
localConnectionLocalAddress = EndPointAddress
ourAddress
                           , localConnectionRemoteAddress :: EndPointAddress
localConnectionRemoteAddress = EndPointAddress
theirAddress
                           , localConnectionState :: TVar LocalConnectionState
localConnectionState = TVar LocalConnectionState
lconnState
                           }
            TVar LocalEndPointState -> LocalEndPointState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (LocalEndPoint -> TVar LocalEndPointState
localEndPointState LocalEndPoint
ourlep)
                      (ValidLocalEndPointState -> LocalEndPointState
LocalEndPointValid (ValidLocalEndPointState -> LocalEndPointState)
-> ValidLocalEndPointState -> LocalEndPointState
forall a b. (a -> b) -> a -> b
$
                         (EndPointAddress, ConnectionId)
-> Accessor ValidLocalEndPointState LocalConnection
connectionAt (EndPointAddress
theirAddress, ConnectionId
conid) Accessor ValidLocalEndPointState LocalConnection
-> LocalConnection
-> ValidLocalEndPointState
-> ValidLocalEndPointState
forall r a. T r a -> a -> r -> r
^= LocalConnection
lconn (ValidLocalEndPointState -> ValidLocalEndPointState)
-> ValidLocalEndPointState -> ValidLocalEndPointState
forall a b. (a -> b) -> a -> b
$ ValidLocalEndPointState
lepvst)
            (TChan Event, LocalConnection)
-> STM (TChan Event, LocalConnection)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalEndPoint -> TChan Event
localEndPointChannel LocalEndPoint
theirlep, LocalConnection
lconn)
      TChan Event -> Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan Event
chan (Event -> STM ()) -> Event -> STM ()
forall a b. (a -> b) -> a -> b
$
        ConnectionId -> Reliability -> EndPointAddress -> Event
ConnectionOpened (LocalConnection -> ConnectionId
localConnectionId LocalConnection
lconn) Reliability
ReliableOrdered EndPointAddress
ourAddress
      Connection -> STM Connection
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Connection -> STM Connection) -> Connection -> STM Connection
forall a b. (a -> b) -> a -> b
$ Connection
        { send :: [ByteString] -> IO (Either (TransportError SendErrorCode) ())
send  = TChan Event
-> TVar TransportState
-> LocalConnection
-> [ByteString]
-> IO (Either (TransportError SendErrorCode) ())
apiSend TChan Event
chan TVar TransportState
state LocalConnection
lconn
        , close :: IO ()
close = TChan Event -> TVar TransportState -> LocalConnection -> IO ()
apiClose TChan Event
chan TVar TransportState
state LocalConnection
lconn
        }

-- | Send a message over a connection
apiSend :: TChan Event
        -> TVar TransportState
        -> LocalConnection
        -> [ByteString]
        -> IO (Either (TransportError SendErrorCode) ())
apiSend :: TChan Event
-> TVar TransportState
-> LocalConnection
-> [ByteString]
-> IO (Either (TransportError SendErrorCode) ())
apiSend TChan Event
chan TVar TransportState
state LocalConnection
lconn [ByteString]
msg = (TransportError SendErrorCode
 -> IO (Either (TransportError SendErrorCode) ()))
-> IO (Either (TransportError SendErrorCode) ())
-> IO (Either (TransportError SendErrorCode) ())
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle TransportError SendErrorCode
-> IO (Either (TransportError SendErrorCode) ())
forall {b}.
TransportError SendErrorCode
-> IO (Either (TransportError SendErrorCode) b)
handleFailure (IO (Either (TransportError SendErrorCode) ())
 -> IO (Either (TransportError SendErrorCode) ()))
-> IO (Either (TransportError SendErrorCode) ())
-> IO (Either (TransportError SendErrorCode) ())
forall a b. (a -> b) -> a -> b
$ (IOError -> TransportError SendErrorCode)
-> IO (Either (TransportError SendErrorCode) ())
-> IO (Either (TransportError SendErrorCode) ())
forall e a. Exception e => (IOError -> e) -> IO a -> IO a
mapIOException IOError -> TransportError SendErrorCode
sendFailed (IO (Either (TransportError SendErrorCode) ())
 -> IO (Either (TransportError SendErrorCode) ()))
-> IO (Either (TransportError SendErrorCode) ())
-> IO (Either (TransportError SendErrorCode) ())
forall a b. (a -> b) -> a -> b
$
    STM (Either (TransportError SendErrorCode) ())
-> IO (Either (TransportError SendErrorCode) ())
forall a. STM a -> IO a
atomically (STM (Either (TransportError SendErrorCode) ())
 -> IO (Either (TransportError SendErrorCode) ()))
-> STM (Either (TransportError SendErrorCode) ())
-> IO (Either (TransportError SendErrorCode) ())
forall a b. (a -> b) -> a -> b
$ do
      LocalConnectionState
connst <- TVar LocalConnectionState -> STM LocalConnectionState
forall a. TVar a -> STM a
readTVar (LocalConnection -> TVar LocalConnectionState
localConnectionState LocalConnection
lconn)
      case LocalConnectionState
connst of
        LocalConnectionState
LocalConnectionValid -> do
          (ByteString -> () -> ()) -> () -> [ByteString] -> ()
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ByteString -> () -> ()
forall a b. a -> b -> b
seq () [ByteString]
msg () -> STM () -> STM ()
forall a b. a -> b -> b
`seq`
            TChan Event -> Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan Event
chan (ConnectionId -> [ByteString] -> Event
Received (LocalConnection -> ConnectionId
localConnectionId LocalConnection
lconn) [ByteString]
msg)
          Either (TransportError SendErrorCode) ()
-> STM (Either (TransportError SendErrorCode) ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (TransportError SendErrorCode) ()
 -> STM (Either (TransportError SendErrorCode) ()))
-> Either (TransportError SendErrorCode) ()
-> STM (Either (TransportError SendErrorCode) ())
forall a b. (a -> b) -> a -> b
$ () -> Either (TransportError SendErrorCode) ()
forall a b. b -> Either a b
Right ()
        LocalConnectionState
LocalConnectionClosed -> do
          -- If the local connection was closed, check why.
          TVar TransportState
-> SendErrorCode
-> (ValidTransportState
    -> STM (Either (TransportError SendErrorCode) ()))
-> STM (Either (TransportError SendErrorCode) ())
forall e a.
(Typeable e, Show e) =>
TVar TransportState -> e -> (ValidTransportState -> STM a) -> STM a
withValidTransportState TVar TransportState
state SendErrorCode
SendFailed ((ValidTransportState
  -> STM (Either (TransportError SendErrorCode) ()))
 -> STM (Either (TransportError SendErrorCode) ()))
-> (ValidTransportState
    -> STM (Either (TransportError SendErrorCode) ()))
-> STM (Either (TransportError SendErrorCode) ())
forall a b. (a -> b) -> a -> b
$ \ValidTransportState
vst -> do
            let addr :: EndPointAddress
addr = LocalConnection -> EndPointAddress
localConnectionLocalAddress LocalConnection
lconn
                mblep :: Maybe LocalEndPoint
mblep = ValidTransportState
vst ValidTransportState
-> Accessor ValidTransportState (Maybe LocalEndPoint)
-> Maybe LocalEndPoint
forall r a. r -> T r a -> a
^. EndPointAddress
-> Accessor ValidTransportState (Maybe LocalEndPoint)
localEndPointAt EndPointAddress
addr
            case Maybe LocalEndPoint
mblep of
              Maybe LocalEndPoint
Nothing -> TransportError SendErrorCode
-> STM (Either (TransportError SendErrorCode) ())
forall e a. Exception e => e -> STM a
throwSTM (TransportError SendErrorCode
 -> STM (Either (TransportError SendErrorCode) ()))
-> TransportError SendErrorCode
-> STM (Either (TransportError SendErrorCode) ())
forall a b. (a -> b) -> a -> b
$ SendErrorCode -> String -> TransportError SendErrorCode
forall error. error -> String -> TransportError error
TransportError SendErrorCode
SendFailed String
"Endpoint closed"
              Just LocalEndPoint
lep -> do
                LocalEndPointState
lepst <- TVar LocalEndPointState -> STM LocalEndPointState
forall a. TVar a -> STM a
readTVar (LocalEndPoint -> TVar LocalEndPointState
localEndPointState LocalEndPoint
lep)
                case LocalEndPointState
lepst of
                  LocalEndPointValid ValidLocalEndPointState
_ -> do
                    Either (TransportError SendErrorCode) ()
-> STM (Either (TransportError SendErrorCode) ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (TransportError SendErrorCode) ()
 -> STM (Either (TransportError SendErrorCode) ()))
-> Either (TransportError SendErrorCode) ()
-> STM (Either (TransportError SendErrorCode) ())
forall a b. (a -> b) -> a -> b
$ TransportError SendErrorCode
-> Either (TransportError SendErrorCode) ()
forall a b. a -> Either a b
Left (TransportError SendErrorCode
 -> Either (TransportError SendErrorCode) ())
-> TransportError SendErrorCode
-> Either (TransportError SendErrorCode) ()
forall a b. (a -> b) -> a -> b
$ SendErrorCode -> String -> TransportError SendErrorCode
forall error. error -> String -> TransportError error
TransportError SendErrorCode
SendClosed String
"Connection closed"
                  LocalEndPointState
LocalEndPointClosed -> do
                    TransportError SendErrorCode
-> STM (Either (TransportError SendErrorCode) ())
forall e a. Exception e => e -> STM a
throwSTM (TransportError SendErrorCode
 -> STM (Either (TransportError SendErrorCode) ()))
-> TransportError SendErrorCode
-> STM (Either (TransportError SendErrorCode) ())
forall a b. (a -> b) -> a -> b
$ SendErrorCode -> String -> TransportError SendErrorCode
forall error. error -> String -> TransportError error
TransportError SendErrorCode
SendFailed String
"Endpoint closed"
        LocalConnectionState
LocalConnectionFailed -> Either (TransportError SendErrorCode) ()
-> STM (Either (TransportError SendErrorCode) ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (TransportError SendErrorCode) ()
 -> STM (Either (TransportError SendErrorCode) ()))
-> Either (TransportError SendErrorCode) ()
-> STM (Either (TransportError SendErrorCode) ())
forall a b. (a -> b) -> a -> b
$
          TransportError SendErrorCode
-> Either (TransportError SendErrorCode) ()
forall a b. a -> Either a b
Left (TransportError SendErrorCode
 -> Either (TransportError SendErrorCode) ())
-> TransportError SendErrorCode
-> Either (TransportError SendErrorCode) ()
forall a b. (a -> b) -> a -> b
$ SendErrorCode -> String -> TransportError SendErrorCode
forall error. error -> String -> TransportError error
TransportError SendErrorCode
SendFailed String
"Endpoint closed"
    where
      sendFailed :: IOError -> TransportError SendErrorCode
sendFailed = SendErrorCode -> String -> TransportError SendErrorCode
forall error. error -> String -> TransportError error
TransportError SendErrorCode
SendFailed (String -> TransportError SendErrorCode)
-> (IOError -> String) -> IOError -> TransportError SendErrorCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> String
forall a. Show a => a -> String
show
      handleFailure :: TransportError SendErrorCode
-> IO (Either (TransportError SendErrorCode) b)
handleFailure ex :: TransportError SendErrorCode
ex@(TransportError SendErrorCode
SendFailed String
reason) = STM (Either (TransportError SendErrorCode) b)
-> IO (Either (TransportError SendErrorCode) b)
forall a. STM a -> IO a
atomically (STM (Either (TransportError SendErrorCode) b)
 -> IO (Either (TransportError SendErrorCode) b))
-> STM (Either (TransportError SendErrorCode) b)
-> IO (Either (TransportError SendErrorCode) b)
forall a b. (a -> b) -> a -> b
$ do
        TVar TransportState
-> EndPointAddress -> EndPointAddress -> String -> STM ()
apiBreakConnection TVar TransportState
state (LocalConnection -> EndPointAddress
localConnectionLocalAddress LocalConnection
lconn)
                                 (LocalConnection -> EndPointAddress
localConnectionRemoteAddress LocalConnection
lconn)
                                 String
reason
        Either (TransportError SendErrorCode) b
-> STM (Either (TransportError SendErrorCode) b)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (TransportError SendErrorCode
-> Either (TransportError SendErrorCode) b
forall a b. a -> Either a b
Left TransportError SendErrorCode
ex)
      handleFailure TransportError SendErrorCode
ex = Either (TransportError SendErrorCode) b
-> IO (Either (TransportError SendErrorCode) b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TransportError SendErrorCode
-> Either (TransportError SendErrorCode) b
forall a b. a -> Either a b
Left TransportError SendErrorCode
ex)

-- | Close a connection
apiClose :: TChan Event
         -> TVar TransportState
         -> LocalConnection
         -> IO ()
apiClose :: TChan Event -> TVar TransportState -> LocalConnection -> IO ()
apiClose TChan Event
chan TVar TransportState
state LocalConnection
lconn = do
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do -- XXX: whenValidConnectionState
    LocalConnectionState
connst <- TVar LocalConnectionState -> STM LocalConnectionState
forall a. TVar a -> STM a
readTVar (LocalConnection -> TVar LocalConnectionState
localConnectionState LocalConnection
lconn)
    case LocalConnectionState
connst of
      LocalConnectionState
LocalConnectionValid -> do
        TChan Event -> Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan Event
chan (Event -> STM ()) -> Event -> STM ()
forall a b. (a -> b) -> a -> b
$ ConnectionId -> Event
ConnectionClosed (LocalConnection -> ConnectionId
localConnectionId LocalConnection
lconn)
        TVar LocalConnectionState -> LocalConnectionState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (LocalConnection -> TVar LocalConnectionState
localConnectionState LocalConnection
lconn) LocalConnectionState
LocalConnectionClosed
        TVar TransportState -> (ValidTransportState -> STM ()) -> STM ()
forall m.
Monoid m =>
TVar TransportState -> (ValidTransportState -> STM m) -> STM m
whenValidTransportState TVar TransportState
state ((ValidTransportState -> STM ()) -> STM ())
-> (ValidTransportState -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \ValidTransportState
vst -> do
          let mblep :: Maybe LocalEndPoint
mblep = ValidTransportState
vst ValidTransportState
-> Accessor ValidTransportState (Maybe LocalEndPoint)
-> Maybe LocalEndPoint
forall r a. r -> T r a -> a
^. EndPointAddress
-> Accessor ValidTransportState (Maybe LocalEndPoint)
localEndPointAt (LocalConnection -> EndPointAddress
localConnectionLocalAddress LocalConnection
lconn)
              theirAddress :: EndPointAddress
theirAddress = LocalConnection -> EndPointAddress
localConnectionRemoteAddress LocalConnection
lconn
          Maybe LocalEndPoint -> (LocalEndPoint -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe LocalEndPoint
mblep ((LocalEndPoint -> STM ()) -> STM ())
-> (LocalEndPoint -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \LocalEndPoint
lep ->
            LocalEndPoint -> (ValidLocalEndPointState -> STM ()) -> STM ()
forall m.
Monoid m =>
LocalEndPoint -> (ValidLocalEndPointState -> STM m) -> STM m
whenValidLocalEndPointState LocalEndPoint
lep ((ValidLocalEndPointState -> STM ()) -> STM ())
-> (ValidLocalEndPointState -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$
              TVar LocalEndPointState -> LocalEndPointState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (LocalEndPoint -> TVar LocalEndPointState
localEndPointState LocalEndPoint
lep)
                (LocalEndPointState -> STM ())
-> (ValidLocalEndPointState -> LocalEndPointState)
-> ValidLocalEndPointState
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidLocalEndPointState -> LocalEndPointState
LocalEndPointValid
                (ValidLocalEndPointState -> LocalEndPointState)
-> (ValidLocalEndPointState -> ValidLocalEndPointState)
-> ValidLocalEndPointState
-> LocalEndPointState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (T ValidLocalEndPointState
  (Map (EndPointAddress, ConnectionId) LocalConnection)
connections T ValidLocalEndPointState
  (Map (EndPointAddress, ConnectionId) LocalConnection)
-> (Map (EndPointAddress, ConnectionId) LocalConnection
    -> Map (EndPointAddress, ConnectionId) LocalConnection)
-> ValidLocalEndPointState
-> ValidLocalEndPointState
forall r a. T r a -> (a -> a) -> r -> r
^: (EndPointAddress, ConnectionId)
-> Map (EndPointAddress, ConnectionId) LocalConnection
-> Map (EndPointAddress, ConnectionId) LocalConnection
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (EndPointAddress
theirAddress, LocalConnection -> ConnectionId
localConnectionId LocalConnection
lconn))
      LocalConnectionState
_ -> () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- [Multicast]
-- Currently multicast implementation doesn't pass it's tests, so it
-- disabled. Here we have old code that could be improved, see GitHub ISSUE 5
-- https://github.com/haskell-distributed/network-transport-inmemory/issues/5

-- | Construct a multicast group
--
-- When the group is deleted some endpoints may still receive messages, but
-- subsequent calls to resolveMulticastGroup will fail. This mimicks the fact
-- that some multicast messages may still be in transit when the group is
-- deleted.
createMulticastGroup :: TVar TransportState
                     -> EndPointAddress
                     -> MulticastAddress
                     -> TVar (Set EndPointAddress)
                     -> MulticastGroup
createMulticastGroup :: TVar TransportState
-> EndPointAddress
-> MulticastAddress
-> TVar (Set EndPointAddress)
-> MulticastGroup
createMulticastGroup TVar TransportState
state EndPointAddress
ourAddress MulticastAddress
groupAddress TVar (Set EndPointAddress)
group = MulticastGroup
    { multicastAddress :: MulticastAddress
multicastAddress     = MulticastAddress
groupAddress
    , deleteMulticastGroup :: IO ()
deleteMulticastGroup = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TVar TransportState -> (ValidTransportState -> STM ()) -> STM ()
forall m.
Monoid m =>
TVar TransportState -> (ValidTransportState -> STM m) -> STM m
whenValidTransportState TVar TransportState
state ((ValidTransportState -> STM ()) -> STM ())
-> (ValidTransportState -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \ValidTransportState
vst -> do
          -- XXX best we can do given current broken API, which needs fixing.
          let lep :: LocalEndPoint
lep = Maybe LocalEndPoint -> LocalEndPoint
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe LocalEndPoint -> LocalEndPoint)
-> Maybe LocalEndPoint -> LocalEndPoint
forall a b. (a -> b) -> a -> b
$ ValidTransportState
vst ValidTransportState
-> Accessor ValidTransportState (Maybe LocalEndPoint)
-> Maybe LocalEndPoint
forall r a. r -> T r a -> a
^. EndPointAddress
-> Accessor ValidTransportState (Maybe LocalEndPoint)
localEndPointAt EndPointAddress
ourAddress
          TVar LocalEndPointState
-> (LocalEndPointState -> LocalEndPointState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (LocalEndPoint -> TVar LocalEndPointState
localEndPointState LocalEndPoint
lep) ((LocalEndPointState -> LocalEndPointState) -> STM ())
-> (LocalEndPointState -> LocalEndPointState) -> STM ()
forall a b. (a -> b) -> a -> b
$ \LocalEndPointState
lepst -> case LocalEndPointState
lepst of
            LocalEndPointValid ValidLocalEndPointState
lepvst ->
              ValidLocalEndPointState -> LocalEndPointState
LocalEndPointValid (ValidLocalEndPointState -> LocalEndPointState)
-> ValidLocalEndPointState -> LocalEndPointState
forall a b. (a -> b) -> a -> b
$ Accessor
  ValidLocalEndPointState
  (Map MulticastAddress (TVar (Set EndPointAddress)))
multigroups Accessor
  ValidLocalEndPointState
  (Map MulticastAddress (TVar (Set EndPointAddress)))
-> (Map MulticastAddress (TVar (Set EndPointAddress))
    -> Map MulticastAddress (TVar (Set EndPointAddress)))
-> ValidLocalEndPointState
-> ValidLocalEndPointState
forall r a. T r a -> (a -> a) -> r -> r
^: MulticastAddress
-> Map MulticastAddress (TVar (Set EndPointAddress))
-> Map MulticastAddress (TVar (Set EndPointAddress))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete MulticastAddress
groupAddress (ValidLocalEndPointState -> ValidLocalEndPointState)
-> ValidLocalEndPointState -> ValidLocalEndPointState
forall a b. (a -> b) -> a -> b
$ ValidLocalEndPointState
lepvst
            LocalEndPointState
LocalEndPointClosed ->
              LocalEndPointState
LocalEndPointClosed
    , maxMsgSize :: Maybe Int
maxMsgSize           = Maybe Int
forall a. Maybe a
Nothing
    , multicastSend :: [ByteString] -> IO ()
multicastSend        = \[ByteString]
payload -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TVar TransportState
-> SendErrorCode -> (ValidTransportState -> STM ()) -> STM ()
forall e a.
(Typeable e, Show e) =>
TVar TransportState -> e -> (ValidTransportState -> STM a) -> STM a
withValidTransportState TVar TransportState
state SendErrorCode
SendFailed ((ValidTransportState -> STM ()) -> STM ())
-> (ValidTransportState -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \ValidTransportState
vst -> do
          Set EndPointAddress
es <- TVar (Set EndPointAddress) -> STM (Set EndPointAddress)
forall a. TVar a -> STM a
readTVar TVar (Set EndPointAddress)
group
          [EndPointAddress] -> (EndPointAddress -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Set EndPointAddress -> [EndPointAddress]
forall a. Set a -> [a]
Set.elems Set EndPointAddress
es) ((EndPointAddress -> STM ()) -> STM ())
-> (EndPointAddress -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \EndPointAddress
ep -> do
            let ch :: TChan Event
ch = LocalEndPoint -> TChan Event
localEndPointChannel (LocalEndPoint -> TChan Event) -> LocalEndPoint -> TChan Event
forall a b. (a -> b) -> a -> b
$ Maybe LocalEndPoint -> LocalEndPoint
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe LocalEndPoint -> LocalEndPoint)
-> Maybe LocalEndPoint -> LocalEndPoint
forall a b. (a -> b) -> a -> b
$ ValidTransportState
vst ValidTransportState
-> Accessor ValidTransportState (Maybe LocalEndPoint)
-> Maybe LocalEndPoint
forall r a. r -> T r a -> a
^. EndPointAddress
-> Accessor ValidTransportState (Maybe LocalEndPoint)
localEndPointAt EndPointAddress
ep
            TChan Event -> Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan Event
ch (MulticastAddress -> [ByteString] -> Event
ReceivedMulticast MulticastAddress
groupAddress [ByteString]
payload)
    , multicastSubscribe :: IO ()
multicastSubscribe   = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Set EndPointAddress)
-> (Set EndPointAddress -> Set EndPointAddress) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Set EndPointAddress)
group ((Set EndPointAddress -> Set EndPointAddress) -> STM ())
-> (Set EndPointAddress -> Set EndPointAddress) -> STM ()
forall a b. (a -> b) -> a -> b
$ EndPointAddress -> Set EndPointAddress -> Set EndPointAddress
forall a. Ord a => a -> Set a -> Set a
Set.insert EndPointAddress
ourAddress
    , multicastUnsubscribe :: IO ()
multicastUnsubscribe = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Set EndPointAddress)
-> (Set EndPointAddress -> Set EndPointAddress) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Set EndPointAddress)
group ((Set EndPointAddress -> Set EndPointAddress) -> STM ())
-> (Set EndPointAddress -> Set EndPointAddress) -> STM ()
forall a b. (a -> b) -> a -> b
$ EndPointAddress -> Set EndPointAddress -> Set EndPointAddress
forall a. Ord a => a -> Set a -> Set a
Set.delete EndPointAddress
ourAddress
    , multicastClose :: IO ()
multicastClose       = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    }

-- | Create a new multicast group
_apiNewMulticastGroup :: TVar TransportState
                     -> EndPointAddress
                     -> IO (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
_apiNewMulticastGroup :: TVar TransportState
-> EndPointAddress
-> IO
     (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
_apiNewMulticastGroup TVar TransportState
state EndPointAddress
ourAddress = (TransportError NewMulticastGroupErrorCode
 -> IO
      (Either
         (TransportError NewMulticastGroupErrorCode) MulticastGroup))
-> IO
     (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
-> IO
     (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup
-> IO
     (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup
 -> IO
      (Either
         (TransportError NewMulticastGroupErrorCode) MulticastGroup))
-> (TransportError NewMulticastGroupErrorCode
    -> Either
         (TransportError NewMulticastGroupErrorCode) MulticastGroup)
-> TransportError NewMulticastGroupErrorCode
-> IO
     (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransportError NewMulticastGroupErrorCode
-> Either
     (TransportError NewMulticastGroupErrorCode) MulticastGroup
forall a b. a -> Either a b
Left) (IO
   (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
 -> IO
      (Either
         (TransportError NewMulticastGroupErrorCode) MulticastGroup))
-> IO
     (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
-> IO
     (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
forall a b. (a -> b) -> a -> b
$ do
  TVar (Set EndPointAddress)
group <- Set EndPointAddress -> IO (TVar (Set EndPointAddress))
forall a. a -> IO (TVar a)
newTVarIO Set EndPointAddress
forall a. Set a
Set.empty
  MulticastAddress
groupAddr <- STM MulticastAddress -> IO MulticastAddress
forall a. STM a -> IO a
atomically (STM MulticastAddress -> IO MulticastAddress)
-> STM MulticastAddress -> IO MulticastAddress
forall a b. (a -> b) -> a -> b
$
    TVar TransportState
-> NewMulticastGroupErrorCode
-> (ValidTransportState -> STM MulticastAddress)
-> STM MulticastAddress
forall e a.
(Typeable e, Show e) =>
TVar TransportState -> e -> (ValidTransportState -> STM a) -> STM a
withValidTransportState TVar TransportState
state NewMulticastGroupErrorCode
NewMulticastGroupFailed ((ValidTransportState -> STM MulticastAddress)
 -> STM MulticastAddress)
-> (ValidTransportState -> STM MulticastAddress)
-> STM MulticastAddress
forall a b. (a -> b) -> a -> b
$ \ValidTransportState
vst -> do
      LocalEndPoint
lep <- STM LocalEndPoint
-> (LocalEndPoint -> STM LocalEndPoint)
-> Maybe LocalEndPoint
-> STM LocalEndPoint
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TransportError NewMulticastGroupErrorCode -> STM LocalEndPoint
forall e a. Exception e => e -> STM a
throwSTM (TransportError NewMulticastGroupErrorCode -> STM LocalEndPoint)
-> TransportError NewMulticastGroupErrorCode -> STM LocalEndPoint
forall a b. (a -> b) -> a -> b
$ NewMulticastGroupErrorCode
-> String -> TransportError NewMulticastGroupErrorCode
forall error. error -> String -> TransportError error
TransportError NewMulticastGroupErrorCode
NewMulticastGroupFailed String
"Endpoint closed")
                   LocalEndPoint -> STM LocalEndPoint
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return
                   (ValidTransportState
vst ValidTransportState
-> Accessor ValidTransportState (Maybe LocalEndPoint)
-> Maybe LocalEndPoint
forall r a. r -> T r a -> a
^. EndPointAddress
-> Accessor ValidTransportState (Maybe LocalEndPoint)
localEndPointAt EndPointAddress
ourAddress)
      LocalEndPoint
-> NewMulticastGroupErrorCode
-> (ValidLocalEndPointState -> STM MulticastAddress)
-> STM MulticastAddress
forall e a.
(Typeable e, Show e) =>
LocalEndPoint -> e -> (ValidLocalEndPointState -> STM a) -> STM a
withValidLocalEndPointState LocalEndPoint
lep NewMulticastGroupErrorCode
NewMulticastGroupFailed ((ValidLocalEndPointState -> STM MulticastAddress)
 -> STM MulticastAddress)
-> (ValidLocalEndPointState -> STM MulticastAddress)
-> STM MulticastAddress
forall a b. (a -> b) -> a -> b
$ \ValidLocalEndPointState
lepvst -> do
        let addr :: MulticastAddress
addr = ByteString -> MulticastAddress
MulticastAddress (ByteString -> MulticastAddress)
-> (Map MulticastAddress (TVar (Set EndPointAddress))
    -> ByteString)
-> Map MulticastAddress (TVar (Set EndPointAddress))
-> MulticastAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BSC.pack (String -> ByteString)
-> (Map MulticastAddress (TVar (Set EndPointAddress)) -> String)
-> Map MulticastAddress (TVar (Set EndPointAddress))
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> (Map MulticastAddress (TVar (Set EndPointAddress)) -> Int)
-> Map MulticastAddress (TVar (Set EndPointAddress))
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map MulticastAddress (TVar (Set EndPointAddress)) -> Int
forall k a. Map k a -> Int
Map.size (Map MulticastAddress (TVar (Set EndPointAddress))
 -> MulticastAddress)
-> Map MulticastAddress (TVar (Set EndPointAddress))
-> MulticastAddress
forall a b. (a -> b) -> a -> b
$ ValidLocalEndPointState
lepvst ValidLocalEndPointState
-> Accessor
     ValidLocalEndPointState
     (Map MulticastAddress (TVar (Set EndPointAddress)))
-> Map MulticastAddress (TVar (Set EndPointAddress))
forall r a. r -> T r a -> a
^. Accessor
  ValidLocalEndPointState
  (Map MulticastAddress (TVar (Set EndPointAddress)))
multigroups
        TVar LocalEndPointState -> LocalEndPointState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (LocalEndPoint -> TVar LocalEndPointState
localEndPointState LocalEndPoint
lep) (ValidLocalEndPointState -> LocalEndPointState
LocalEndPointValid (ValidLocalEndPointState -> LocalEndPointState)
-> ValidLocalEndPointState -> LocalEndPointState
forall a b. (a -> b) -> a -> b
$ MulticastAddress
-> Accessor ValidLocalEndPointState (TVar (Set EndPointAddress))
multigroupAt MulticastAddress
addr Accessor ValidLocalEndPointState (TVar (Set EndPointAddress))
-> TVar (Set EndPointAddress)
-> ValidLocalEndPointState
-> ValidLocalEndPointState
forall r a. T r a -> a -> r -> r
^= TVar (Set EndPointAddress)
group (ValidLocalEndPointState -> ValidLocalEndPointState)
-> ValidLocalEndPointState -> ValidLocalEndPointState
forall a b. (a -> b) -> a -> b
$ ValidLocalEndPointState
lepvst)
        MulticastAddress -> STM MulticastAddress
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return MulticastAddress
addr
  Either (TransportError NewMulticastGroupErrorCode) MulticastGroup
-> IO
     (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup
 -> IO
      (Either
         (TransportError NewMulticastGroupErrorCode) MulticastGroup))
-> (MulticastGroup
    -> Either
         (TransportError NewMulticastGroupErrorCode) MulticastGroup)
-> MulticastGroup
-> IO
     (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MulticastGroup
-> Either
     (TransportError NewMulticastGroupErrorCode) MulticastGroup
forall a b. b -> Either a b
Right (MulticastGroup
 -> IO
      (Either
         (TransportError NewMulticastGroupErrorCode) MulticastGroup))
-> MulticastGroup
-> IO
     (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)
forall a b. (a -> b) -> a -> b
$ TVar TransportState
-> EndPointAddress
-> MulticastAddress
-> TVar (Set EndPointAddress)
-> MulticastGroup
createMulticastGroup TVar TransportState
state EndPointAddress
ourAddress MulticastAddress
groupAddr TVar (Set EndPointAddress)
group

-- | Resolve a multicast group
_apiResolveMulticastGroup :: TVar TransportState
                         -> EndPointAddress
                         -> MulticastAddress
                         -> IO (Either (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
_apiResolveMulticastGroup :: TVar TransportState
-> EndPointAddress
-> MulticastAddress
-> IO
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
_apiResolveMulticastGroup TVar TransportState
state EndPointAddress
ourAddress MulticastAddress
groupAddress = (TransportError ResolveMulticastGroupErrorCode
 -> IO
      (Either
         (TransportError ResolveMulticastGroupErrorCode) MulticastGroup))
-> IO
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
-> IO
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (Either
  (TransportError ResolveMulticastGroupErrorCode) MulticastGroup
-> IO
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (TransportError ResolveMulticastGroupErrorCode) MulticastGroup
 -> IO
      (Either
         (TransportError ResolveMulticastGroupErrorCode) MulticastGroup))
-> (TransportError ResolveMulticastGroupErrorCode
    -> Either
         (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
-> TransportError ResolveMulticastGroupErrorCode
-> IO
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransportError ResolveMulticastGroupErrorCode
-> Either
     (TransportError ResolveMulticastGroupErrorCode) MulticastGroup
forall a b. a -> Either a b
Left) (IO
   (Either
      (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
 -> IO
      (Either
         (TransportError ResolveMulticastGroupErrorCode) MulticastGroup))
-> IO
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
-> IO
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
forall a b. (a -> b) -> a -> b
$ STM
  (Either
     (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
-> IO
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
forall a. STM a -> IO a
atomically (STM
   (Either
      (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
 -> IO
      (Either
         (TransportError ResolveMulticastGroupErrorCode) MulticastGroup))
-> STM
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
-> IO
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
forall a b. (a -> b) -> a -> b
$
    TVar TransportState
-> ResolveMulticastGroupErrorCode
-> (ValidTransportState
    -> STM
         (Either
            (TransportError ResolveMulticastGroupErrorCode) MulticastGroup))
-> STM
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
forall e a.
(Typeable e, Show e) =>
TVar TransportState -> e -> (ValidTransportState -> STM a) -> STM a
withValidTransportState TVar TransportState
state ResolveMulticastGroupErrorCode
ResolveMulticastGroupFailed ((ValidTransportState
  -> STM
       (Either
          (TransportError ResolveMulticastGroupErrorCode) MulticastGroup))
 -> STM
      (Either
         (TransportError ResolveMulticastGroupErrorCode) MulticastGroup))
-> (ValidTransportState
    -> STM
         (Either
            (TransportError ResolveMulticastGroupErrorCode) MulticastGroup))
-> STM
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
forall a b. (a -> b) -> a -> b
$ \ValidTransportState
vst -> do
      LocalEndPoint
lep <- STM LocalEndPoint
-> (LocalEndPoint -> STM LocalEndPoint)
-> Maybe LocalEndPoint
-> STM LocalEndPoint
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TransportError ResolveMulticastGroupErrorCode -> STM LocalEndPoint
forall e a. Exception e => e -> STM a
throwSTM (TransportError ResolveMulticastGroupErrorCode
 -> STM LocalEndPoint)
-> TransportError ResolveMulticastGroupErrorCode
-> STM LocalEndPoint
forall a b. (a -> b) -> a -> b
$ ResolveMulticastGroupErrorCode
-> String -> TransportError ResolveMulticastGroupErrorCode
forall error. error -> String -> TransportError error
TransportError ResolveMulticastGroupErrorCode
ResolveMulticastGroupFailed String
"Endpoint closed")
                   LocalEndPoint -> STM LocalEndPoint
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return
                   (ValidTransportState
vst ValidTransportState
-> Accessor ValidTransportState (Maybe LocalEndPoint)
-> Maybe LocalEndPoint
forall r a. r -> T r a -> a
^. EndPointAddress
-> Accessor ValidTransportState (Maybe LocalEndPoint)
localEndPointAt EndPointAddress
ourAddress)
      LocalEndPoint
-> ResolveMulticastGroupErrorCode
-> (ValidLocalEndPointState
    -> STM
         (Either
            (TransportError ResolveMulticastGroupErrorCode) MulticastGroup))
-> STM
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
forall e a.
(Typeable e, Show e) =>
LocalEndPoint -> e -> (ValidLocalEndPointState -> STM a) -> STM a
withValidLocalEndPointState LocalEndPoint
lep ResolveMulticastGroupErrorCode
ResolveMulticastGroupFailed ((ValidLocalEndPointState
  -> STM
       (Either
          (TransportError ResolveMulticastGroupErrorCode) MulticastGroup))
 -> STM
      (Either
         (TransportError ResolveMulticastGroupErrorCode) MulticastGroup))
-> (ValidLocalEndPointState
    -> STM
         (Either
            (TransportError ResolveMulticastGroupErrorCode) MulticastGroup))
-> STM
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
forall a b. (a -> b) -> a -> b
$ \ValidLocalEndPointState
lepvst -> do
          let group :: Maybe (TVar (Set EndPointAddress))
group = ValidLocalEndPointState
lepvst ValidLocalEndPointState
-> T ValidLocalEndPointState (Maybe (TVar (Set EndPointAddress)))
-> Maybe (TVar (Set EndPointAddress))
forall r a. r -> T r a -> a
^. (Accessor
  ValidLocalEndPointState
  (Map MulticastAddress (TVar (Set EndPointAddress)))
multigroups Accessor
  ValidLocalEndPointState
  (Map MulticastAddress (TVar (Set EndPointAddress)))
-> T (Map MulticastAddress (TVar (Set EndPointAddress)))
     (Maybe (TVar (Set EndPointAddress)))
-> T ValidLocalEndPointState (Maybe (TVar (Set EndPointAddress)))
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MulticastAddress
-> T (Map MulticastAddress (TVar (Set EndPointAddress)))
     (Maybe (TVar (Set EndPointAddress)))
forall key elem. Ord key => key -> T (Map key elem) (Maybe elem)
DAC.mapMaybe MulticastAddress
groupAddress)
          case Maybe (TVar (Set EndPointAddress))
group of
            Maybe (TVar (Set EndPointAddress))
Nothing ->
              Either
  (TransportError ResolveMulticastGroupErrorCode) MulticastGroup
-> STM
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (TransportError ResolveMulticastGroupErrorCode) MulticastGroup
 -> STM
      (Either
         (TransportError ResolveMulticastGroupErrorCode) MulticastGroup))
-> (TransportError ResolveMulticastGroupErrorCode
    -> Either
         (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
-> TransportError ResolveMulticastGroupErrorCode
-> STM
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransportError ResolveMulticastGroupErrorCode
-> Either
     (TransportError ResolveMulticastGroupErrorCode) MulticastGroup
forall a b. a -> Either a b
Left (TransportError ResolveMulticastGroupErrorCode
 -> STM
      (Either
         (TransportError ResolveMulticastGroupErrorCode) MulticastGroup))
-> TransportError ResolveMulticastGroupErrorCode
-> STM
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
forall a b. (a -> b) -> a -> b
$
                ResolveMulticastGroupErrorCode
-> String -> TransportError ResolveMulticastGroupErrorCode
forall error. error -> String -> TransportError error
TransportError ResolveMulticastGroupErrorCode
ResolveMulticastGroupNotFound
                  (String
"Group " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MulticastAddress -> String
forall a. Show a => a -> String
show MulticastAddress
groupAddress String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not found")
            Just TVar (Set EndPointAddress)
mvar ->
              Either
  (TransportError ResolveMulticastGroupErrorCode) MulticastGroup
-> STM
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (TransportError ResolveMulticastGroupErrorCode) MulticastGroup
 -> STM
      (Either
         (TransportError ResolveMulticastGroupErrorCode) MulticastGroup))
-> (MulticastGroup
    -> Either
         (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
-> MulticastGroup
-> STM
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MulticastGroup
-> Either
     (TransportError ResolveMulticastGroupErrorCode) MulticastGroup
forall a b. b -> Either a b
Right (MulticastGroup
 -> STM
      (Either
         (TransportError ResolveMulticastGroupErrorCode) MulticastGroup))
-> MulticastGroup
-> STM
     (Either
        (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)
forall a b. (a -> b) -> a -> b
$ TVar TransportState
-> EndPointAddress
-> MulticastAddress
-> TVar (Set EndPointAddress)
-> MulticastGroup
createMulticastGroup TVar TransportState
state EndPointAddress
ourAddress MulticastAddress
groupAddress TVar (Set EndPointAddress)
mvar

--------------------------------------------------------------------------------
-- Lens definitions                                                           --
--------------------------------------------------------------------------------

nextLocalEndPointId :: Accessor ValidTransportState Int
nextLocalEndPointId :: Accessor ValidTransportState Int
nextLocalEndPointId = (ValidTransportState -> Int)
-> (Int -> ValidTransportState -> ValidTransportState)
-> Accessor ValidTransportState Int
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor ValidTransportState -> Int
_nextLocalEndPointId (\Int
eid ValidTransportState
st -> ValidTransportState
st{ _nextLocalEndPointId = eid} )

localEndPoints :: Accessor ValidTransportState (Map EndPointAddress LocalEndPoint)
localEndPoints :: T ValidTransportState (Map EndPointAddress LocalEndPoint)
localEndPoints = (ValidTransportState -> Map EndPointAddress LocalEndPoint)
-> (Map EndPointAddress LocalEndPoint
    -> ValidTransportState -> ValidTransportState)
-> T ValidTransportState (Map EndPointAddress LocalEndPoint)
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor ValidTransportState -> Map EndPointAddress LocalEndPoint
_localEndPoints (\Map EndPointAddress LocalEndPoint
leps ValidTransportState
st -> ValidTransportState
st { _localEndPoints = leps })

nextConnectionId :: Accessor ValidLocalEndPointState ConnectionId
nextConnectionId :: Accessor ValidLocalEndPointState ConnectionId
nextConnectionId = (ValidLocalEndPointState -> ConnectionId)
-> (ConnectionId
    -> ValidLocalEndPointState -> ValidLocalEndPointState)
-> Accessor ValidLocalEndPointState ConnectionId
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor ValidLocalEndPointState -> ConnectionId
_nextConnectionId (\ConnectionId
cid ValidLocalEndPointState
st -> ValidLocalEndPointState
st { _nextConnectionId = cid })

connections :: Accessor ValidLocalEndPointState (Map (EndPointAddress,ConnectionId) LocalConnection)
connections :: T ValidLocalEndPointState
  (Map (EndPointAddress, ConnectionId) LocalConnection)
connections = (ValidLocalEndPointState
 -> Map (EndPointAddress, ConnectionId) LocalConnection)
-> (Map (EndPointAddress, ConnectionId) LocalConnection
    -> ValidLocalEndPointState -> ValidLocalEndPointState)
-> T ValidLocalEndPointState
     (Map (EndPointAddress, ConnectionId) LocalConnection)
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor ValidLocalEndPointState
-> Map (EndPointAddress, ConnectionId) LocalConnection
_connections (\Map (EndPointAddress, ConnectionId) LocalConnection
conns ValidLocalEndPointState
st -> ValidLocalEndPointState
st { _connections = conns })

multigroups :: Accessor ValidLocalEndPointState (Map MulticastAddress (TVar (Set EndPointAddress)))
multigroups :: Accessor
  ValidLocalEndPointState
  (Map MulticastAddress (TVar (Set EndPointAddress)))
multigroups = (ValidLocalEndPointState
 -> Map MulticastAddress (TVar (Set EndPointAddress)))
-> (Map MulticastAddress (TVar (Set EndPointAddress))
    -> ValidLocalEndPointState -> ValidLocalEndPointState)
-> Accessor
     ValidLocalEndPointState
     (Map MulticastAddress (TVar (Set EndPointAddress)))
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor ValidLocalEndPointState
-> Map MulticastAddress (TVar (Set EndPointAddress))
_multigroups (\Map MulticastAddress (TVar (Set EndPointAddress))
gs ValidLocalEndPointState
st -> ValidLocalEndPointState
st { _multigroups = gs })

at :: Ord k => k -> String -> Accessor (Map k v) v
at :: forall k v. Ord k => k -> String -> Accessor (Map k v) v
at k
k String
err = (Map k v -> v) -> (v -> Map k v -> Map k v) -> Accessor (Map k v) v
forall r a. (r -> a) -> (a -> r -> r) -> Accessor r a
accessor (v -> k -> Map k v -> v
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (String -> v
forall a. HasCallStack => String -> a
error String
err) k
k) (k -> v -> Map k v -> Map k v
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k)

localEndPointAt :: EndPointAddress -> Accessor ValidTransportState (Maybe LocalEndPoint)
localEndPointAt :: EndPointAddress
-> Accessor ValidTransportState (Maybe LocalEndPoint)
localEndPointAt EndPointAddress
addr = T ValidTransportState (Map EndPointAddress LocalEndPoint)
localEndPoints T ValidTransportState (Map EndPointAddress LocalEndPoint)
-> T (Map EndPointAddress LocalEndPoint) (Maybe LocalEndPoint)
-> Accessor ValidTransportState (Maybe LocalEndPoint)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> EndPointAddress
-> T (Map EndPointAddress LocalEndPoint) (Maybe LocalEndPoint)
forall key elem. Ord key => key -> T (Map key elem) (Maybe elem)
DAC.mapMaybe EndPointAddress
addr

connectionAt :: (EndPointAddress, ConnectionId) -> Accessor ValidLocalEndPointState LocalConnection
connectionAt :: (EndPointAddress, ConnectionId)
-> Accessor ValidLocalEndPointState LocalConnection
connectionAt (EndPointAddress, ConnectionId)
addr = T ValidLocalEndPointState
  (Map (EndPointAddress, ConnectionId) LocalConnection)
connections T ValidLocalEndPointState
  (Map (EndPointAddress, ConnectionId) LocalConnection)
-> T (Map (EndPointAddress, ConnectionId) LocalConnection)
     LocalConnection
-> Accessor ValidLocalEndPointState LocalConnection
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (EndPointAddress, ConnectionId)
-> String
-> T (Map (EndPointAddress, ConnectionId) LocalConnection)
     LocalConnection
forall k v. Ord k => k -> String -> Accessor (Map k v) v
at (EndPointAddress, ConnectionId)
addr String
"Invalid connection"

multigroupAt :: MulticastAddress -> Accessor ValidLocalEndPointState (TVar (Set EndPointAddress))
multigroupAt :: MulticastAddress
-> Accessor ValidLocalEndPointState (TVar (Set EndPointAddress))
multigroupAt MulticastAddress
addr = Accessor
  ValidLocalEndPointState
  (Map MulticastAddress (TVar (Set EndPointAddress)))
multigroups Accessor
  ValidLocalEndPointState
  (Map MulticastAddress (TVar (Set EndPointAddress)))
-> T (Map MulticastAddress (TVar (Set EndPointAddress)))
     (TVar (Set EndPointAddress))
-> Accessor ValidLocalEndPointState (TVar (Set EndPointAddress))
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MulticastAddress
-> String
-> T (Map MulticastAddress (TVar (Set EndPointAddress)))
     (TVar (Set EndPointAddress))
forall k v. Ord k => k -> String -> Accessor (Map k v) v
at MulticastAddress
addr String
"Invalid multigroup"

---------------------------------------------------------------------------------
-- Helpers
---------------------------------------------------------------------------------

-- | LocalEndPoint state deconstructor.
overValidLocalEndPointState :: LocalEndPoint -> STM a -> (ValidLocalEndPointState -> STM a) -> STM a
overValidLocalEndPointState :: forall a.
LocalEndPoint
-> STM a -> (ValidLocalEndPointState -> STM a) -> STM a
overValidLocalEndPointState LocalEndPoint
lep STM a
fallback ValidLocalEndPointState -> STM a
action = do
  LocalEndPointState
lepst <- TVar LocalEndPointState -> STM LocalEndPointState
forall a. TVar a -> STM a
readTVar (LocalEndPoint -> TVar LocalEndPointState
localEndPointState LocalEndPoint
lep)
  case LocalEndPointState
lepst of
    LocalEndPointValid ValidLocalEndPointState
lepvst -> ValidLocalEndPointState -> STM a
action ValidLocalEndPointState
lepvst
    LocalEndPointState
_ -> STM a
fallback

-- | Specialized deconstructor that throws TransportError in case of Closed state
withValidLocalEndPointState :: (Typeable e, Show e) => LocalEndPoint -> e -> (ValidLocalEndPointState -> STM a) -> STM a
withValidLocalEndPointState :: forall e a.
(Typeable e, Show e) =>
LocalEndPoint -> e -> (ValidLocalEndPointState -> STM a) -> STM a
withValidLocalEndPointState LocalEndPoint
lep e
ex = LocalEndPoint
-> STM a -> (ValidLocalEndPointState -> STM a) -> STM a
forall a.
LocalEndPoint
-> STM a -> (ValidLocalEndPointState -> STM a) -> STM a
overValidLocalEndPointState LocalEndPoint
lep (TransportError e -> STM a
forall a e. Exception e => e -> a
throw (TransportError e -> STM a) -> TransportError e -> STM a
forall a b. (a -> b) -> a -> b
$ e -> String -> TransportError e
forall error. error -> String -> TransportError error
TransportError e
ex String
"EndPoint closed")

-- | Specialized deconstructor that do nothing in case of failure
whenValidLocalEndPointState :: Monoid m => LocalEndPoint -> (ValidLocalEndPointState -> STM m) -> STM m
whenValidLocalEndPointState :: forall m.
Monoid m =>
LocalEndPoint -> (ValidLocalEndPointState -> STM m) -> STM m
whenValidLocalEndPointState LocalEndPoint
lep = LocalEndPoint
-> STM m -> (ValidLocalEndPointState -> STM m) -> STM m
forall a.
LocalEndPoint
-> STM a -> (ValidLocalEndPointState -> STM a) -> STM a
overValidLocalEndPointState LocalEndPoint
lep (m -> STM m
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return m
forall a. Monoid a => a
mempty)

overValidTransportState :: TVar TransportState -> STM a -> (ValidTransportState -> STM a) -> STM a
overValidTransportState :: forall a.
TVar TransportState
-> STM a -> (ValidTransportState -> STM a) -> STM a
overValidTransportState TVar TransportState
ts STM a
fallback ValidTransportState -> STM a
action = do
  TransportState
tsst <- TVar TransportState -> STM TransportState
forall a. TVar a -> STM a
readTVar TVar TransportState
ts
  case  TransportState
tsst of
    TransportValid ValidTransportState
tsvst -> ValidTransportState -> STM a
action ValidTransportState
tsvst
    TransportState
_ -> STM a
fallback

withValidTransportState :: (Typeable e, Show e) => TVar TransportState -> e -> (ValidTransportState -> STM a) -> STM a
withValidTransportState :: forall e a.
(Typeable e, Show e) =>
TVar TransportState -> e -> (ValidTransportState -> STM a) -> STM a
withValidTransportState TVar TransportState
ts e
ex = TVar TransportState
-> STM a -> (ValidTransportState -> STM a) -> STM a
forall a.
TVar TransportState
-> STM a -> (ValidTransportState -> STM a) -> STM a
overValidTransportState TVar TransportState
ts (TransportError e -> STM a
forall a e. Exception e => e -> a
throw (TransportError e -> STM a) -> TransportError e -> STM a
forall a b. (a -> b) -> a -> b
$ e -> String -> TransportError e
forall error. error -> String -> TransportError error
TransportError e
ex String
"Transport closed")

whenValidTransportState :: Monoid m => TVar TransportState -> (ValidTransportState -> STM m) -> STM m
whenValidTransportState :: forall m.
Monoid m =>
TVar TransportState -> (ValidTransportState -> STM m) -> STM m
whenValidTransportState TVar TransportState
ts = TVar TransportState
-> STM m -> (ValidTransportState -> STM m) -> STM m
forall a.
TVar TransportState
-> STM a -> (ValidTransportState -> STM a) -> STM a
overValidTransportState TVar TransportState
ts (m -> STM m
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return m
forall a. Monoid a => a
mempty)