summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--SendMessage.hs30
1 files changed, 14 insertions, 16 deletions
diff --git a/SendMessage.hs b/SendMessage.hs
index c6eec01e..ff779e11 100644
--- a/SendMessage.hs
+++ b/SendMessage.hs
@@ -61,28 +61,24 @@ type OutgoingToPeer sock cache msg =
61 -> ByteStringSink 61 -> ByteStringSink
62 -> IO (Maybe msg) 62 -> IO (Maybe msg)
63 63
64class CacheableCommand cmd where 64-- |Strict version of 'modifyIORef'
65 type CacheRef cmd :: * 65modifyIORef' :: IORef a -> (a -> a) -> IO ()
66 type Cache cmd :: * 66modifyIORef' ref f = do
67 x <- readIORef ref
68 let x' = f x
69 x' `seq` writeIORef ref x'
67 70
68 emptyCache :: CacheRef cmd
69
70 cache :: cmd -> CacheRef cmd -> IO ()
71
72 interpretCommands :: SocketLike sock =>
73 sock -> Cache cmd -> TChan cmd -> ByteStringSink -> IO (Maybe cmd)
74
75 71
76sendMessage :: 72sendMessage ::
77 (cache, msg -> IORef cache -> IO (), OutBoundXML RestrictedSocket cache msg) -> TVar (Map Peer (TChan msg, ThreadId)) -> msg -> Peer -> IO () 73 (cache, msg -> cache -> cache, OutBoundXML RestrictedSocket cache msg) -> TVar (Map Peer (TChan msg, ThreadId)) -> msg -> Peer -> IO ()
78sendMessage (newCache,cacheCmd,toPeer) cons msg peer0 = do 74sendMessage (newCache,updateCache,toPeer) cons msg peer0 = do
79 let peer = discardPort peer0 75 let peer = discardPort peer0
80 found <- atomically $ do 76 found <- atomically $ do
81 consmap <- readTVar cons 77 consmap <- readTVar cons
82 return (Map.lookup peer consmap) 78 return (Map.lookup peer consmap)
83 let newEntry = do 79 let newEntry = do
84 chan <- atomically newTChan 80 chan <- atomically newTChan
85 t <- forkIO $ connect_to_server chan peer (newCache,cacheCmd,toPeer) 81 t <- forkIO $ connect_to_server chan peer (newCache,updateCache,toPeer)
86 -- L.putStrLn $ "remote-map new: " <++> showPeer peer 82 -- L.putStrLn $ "remote-map new: " <++> showPeer peer
87 return (True,(chan,t)) 83 return (True,(chan,t))
88 (is_new,entry) <- maybe newEntry 84 (is_new,entry) <- maybe newEntry
@@ -107,12 +103,14 @@ sendMessage (newCache,cacheCmd,toPeer) cons msg peer0 = do
107 readTVar cons >>= writeTVar cons . Map.insert peer entry 103 readTVar cons >>= writeTVar cons . Map.insert peer entry
108 104
109 105
110connect_to_server chan peer (newCache,cacheCmd,toPeer) = (>> return ()) . runMaybeT $ do 106connect_to_server chan peer (newCache,updateCache,toPeer) = (>> return ()) . runMaybeT $ do
111 let port = 5269 :: Int 107 let port = 5269 :: Int
112 -- We'll cache Presence notifications until the socket 108 -- We'll cache Presence notifications until the socket
113 -- is ready. 109 -- is ready.
114 cached <- liftIO $ newIORef newCache 110 cached <- liftIO $ newIORef newCache
115 111
112 let cacheCmd msg cached = modifyIORef' cached (updateCache msg)
113
116 fix $ \sendmsgs -> do 114 fix $ \sendmsgs -> do
117 connected <- liftIO . async $ connect' (peerAddr peer) port 115 connected <- liftIO . async $ connect' (peerAddr peer) port
118 116
@@ -175,8 +173,8 @@ mmInsert val key mm = Map.alter f key mm
175-} 173-}
176 174
177-- newCache = todo 175-- newCache = todo
178cacheCmd :: msg -> cache -> IO () 176-- cacheCmd :: msg -> cache -> IO ()
179cacheCmd _ cached = todo 177-- cacheCmd _ cached = todo
180-- toPeer = todo 178-- toPeer = todo
181 179
182type OutBoundXML sock cache msg = 180type OutBoundXML sock cache msg =