module Network.Transport.Memory (
newMemoryTransport,
module Network.Transport
) where
import Control.Concurrent.Mailbox
import Network.Endpoints
import Network.Transport
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception
import qualified Data.Map as M
newMemoryTransport :: IO Transport
newMemoryTransport = do
vBindings <- atomically $ newTVar M.empty
return Transport {
bind = memoryBind vBindings,
dispatch = memoryDispatcher vBindings,
connect = memoryConnect,
shutdown = return ()
}
memoryDispatcher :: Bindings -> Endpoint -> IO Dispatcher
memoryDispatcher vBindings endpoint = do
d <- async disp
return Dispatcher {
stop = cancel d
}
where
disp = do
atomically $ do
bindings <- readTVar vBindings
env <- readMailbox $ endpointOutbound endpoint
case M.lookup (messageDestination env) bindings of
Nothing -> return ()
Just destination -> postMessage destination (envelopeMessage env)
disp
memoryBind :: Bindings -> Endpoint -> Name -> IO Binding
memoryBind vBindings endpoint name = atomically $ do
bindings <- readTVar vBindings
case M.lookup name bindings of
Nothing -> do
modifyTVar vBindings $ M.insert name endpoint
return Binding {
bindingName = name,
unbind = memoryUnbind vBindings endpoint name
}
Just _ -> throw $ BindingExists name
memoryUnbind :: Bindings -> Endpoint -> Name -> IO ()
memoryUnbind vBindings _ name = atomically $ do
modifyTVar vBindings $ M.delete name
type Bindings = TVar (M.Map Name Endpoint)
memoryConnect :: Endpoint -> Name -> IO Connection
memoryConnect _ _ =
return Connection {
disconnect = return ()
}