diff options
Diffstat (limited to 'SendMessage.hs')
-rw-r--r-- | SendMessage.hs | 30 |
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 | ||
64 | class CacheableCommand cmd where | 64 | -- |Strict version of 'modifyIORef' |
65 | type CacheRef cmd :: * | 65 | modifyIORef' :: IORef a -> (a -> a) -> IO () |
66 | type Cache cmd :: * | 66 | modifyIORef' 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 | ||
76 | sendMessage :: | 72 | sendMessage :: |
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 () |
78 | sendMessage (newCache,cacheCmd,toPeer) cons msg peer0 = do | 74 | sendMessage (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 | ||
110 | connect_to_server chan peer (newCache,cacheCmd,toPeer) = (>> return ()) . runMaybeT $ do | 106 | connect_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 |
178 | cacheCmd :: msg -> cache -> IO () | 176 | -- cacheCmd :: msg -> cache -> IO () |
179 | cacheCmd _ cached = todo | 177 | -- cacheCmd _ cached = todo |
180 | -- toPeer = todo | 178 | -- toPeer = todo |
181 | 179 | ||
182 | type OutBoundXML sock cache msg = | 180 | type OutBoundXML sock cache msg = |