module Network.Transport.Memory (
newMemoryTransport
) where
import Network.Transport
import Control.Concurrent.STM
import qualified Data.Map as M
import Data.Maybe (fromJust)
memoryScheme :: Scheme
memoryScheme = "mem"
data MemoryTransport = MemoryTransport {
boundMailboxes :: TVar (M.Map Name Mailbox)
}
newMemoryTransport :: IO Transport
newMemoryTransport = do
bindings <- atomically $ newTVar M.empty
let transport = MemoryTransport {
boundMailboxes = bindings
}
return Transport {
scheme = memoryScheme,
handles = memoryHandles transport,
bind = memoryBind transport,
sendTo = memorySendTo transport,
shutdown = return ()
}
memoryBind :: MemoryTransport -> Mailbox -> Name -> IO (Either String Binding)
memoryBind transport mailbox name = do
atomically $ modifyTVar (boundMailboxes transport)
(\mailboxes -> M.insert name mailbox mailboxes)
return $ Right Binding {
bindingName = name,
unbind = memoryUnbind transport name
}
memoryHandles :: MemoryTransport -> Name -> IO Bool
memoryHandles _ _ = return True
memorySendTo :: MemoryTransport -> Name -> Message -> IO ()
memorySendTo transport name msg = do
mailboxes <- atomically $ readTVar $ boundMailboxes transport
let mailbox = fromJust $ M.lookup name mailboxes
atomically $ writeTQueue mailbox msg
memoryUnbind :: MemoryTransport -> Name -> IO ()
memoryUnbind transport name = do
atomically $ modifyTVar (boundMailboxes transport) deleteBinding
where deleteBinding m = M.delete name m