diff options
Diffstat (limited to 'Presence')
-rw-r--r-- | Presence/XMPPServer.hs | 34 | ||||
-rw-r--r-- | Presence/main.hs | 10 |
2 files changed, 35 insertions, 9 deletions
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index 4a859bc9..192e9d47 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs | |||
@@ -42,6 +42,8 @@ import Control.Monad.Trans.Maybe | |||
42 | import Control.Monad.IO.Class | 42 | import Control.Monad.IO.Class |
43 | import Control.DeepSeq | 43 | import Control.DeepSeq |
44 | import Control.Concurrent.STM | 44 | import Control.Concurrent.STM |
45 | import Control.Concurrent | ||
46 | import Control.Exception | ||
45 | 47 | ||
46 | -- | Jabber ID (JID) datatype | 48 | -- | Jabber ID (JID) datatype |
47 | data JID = JID { name :: Maybe ByteString | 49 | data JID = JID { name :: Maybe ByteString |
@@ -64,6 +66,7 @@ data JabberShow = Offline | |||
64 | deriving (Show,Enum,Ord,Eq,Read) | 66 | deriving (Show,Enum,Ord,Eq,Read) |
65 | 67 | ||
66 | data Presence = Presence JID JabberShow | 68 | data Presence = Presence JID JabberShow |
69 | deriving Show | ||
67 | 70 | ||
68 | instance NFData Presence where | 71 | instance NFData Presence where |
69 | rnf (Presence jid stat) = rnf jid `seq` stat `seq` () | 72 | rnf (Presence jid stat) = rnf jid `seq` stat `seq` () |
@@ -75,7 +78,7 @@ class XMPPSession session where | |||
75 | setResource :: session -> ByteString -> IO () | 78 | setResource :: session -> ByteString -> IO () |
76 | getJID :: session -> IO ByteString | 79 | getJID :: session -> IO ByteString |
77 | closeSession :: session -> IO () | 80 | closeSession :: session -> IO () |
78 | subscribeToPresence :: session -> Maybe JID -> IO (TChan Presence) | 81 | subscribe :: session -> Maybe JID -> IO (TChan Presence) |
79 | 82 | ||
80 | 83 | ||
81 | greet host = L.unlines | 84 | greet host = L.unlines |
@@ -98,6 +101,9 @@ greet host = L.unlines | |||
98 | 101 | ||
99 | -- data TaggedXMPPSession s = TaggedXMPPSession s | 102 | -- data TaggedXMPPSession s = TaggedXMPPSession s |
100 | 103 | ||
104 | data Commands = Send ByteString | ||
105 | deriving Show | ||
106 | |||
101 | startCon session_factory sock st = do | 107 | startCon session_factory sock st = do |
102 | let h = hOccursFst st :: Handle | 108 | let h = hOccursFst st :: Handle |
103 | cred <- getLocalPeerCred sock | 109 | cred <- getLocalPeerCred sock |
@@ -105,8 +111,25 @@ startCon session_factory sock st = do | |||
105 | pname <- getPeerName sock | 111 | pname <- getPeerName sock |
106 | session <- newSession session_factory sock h | 112 | session <- newSession session_factory sock h |
107 | Prelude.putStrLn $ "PEER NAME: "++show pname | 113 | Prelude.putStrLn $ "PEER NAME: "++show pname |
108 | 114 | pchan <- subscribe session Nothing | |
109 | return ( session .*. ConnectionFinalizer (closeSession session) .*. st) | 115 | cmdChan <- atomically newTChan |
116 | reader <- forkIO $ | ||
117 | handle (\(SomeException _) -> L.putStrLn "quit reader.") $ | ||
118 | fix $ \loop -> do | ||
119 | event <- atomically $ | ||
120 | (fmap Left $ readTChan pchan) | ||
121 | `orElse` | ||
122 | (fmap Right $ readTChan cmdChan) | ||
123 | case event of | ||
124 | Left presence -> | ||
125 | L.putStrLn $ "PRESENCE: " <++> bshow presence | ||
126 | Right (Send r) -> | ||
127 | hPutStrLn h r | ||
128 | loop | ||
129 | let quit = do | ||
130 | killThread reader | ||
131 | closeSession session | ||
132 | return ( (session,cmdChan) .*. ConnectionFinalizer quit .*. st) | ||
110 | 133 | ||
111 | iq_query_unavailable host id mjid xmlns kind = L.unlines $ | 134 | iq_query_unavailable host id mjid xmlns kind = L.unlines $ |
112 | [ "<iq type='error'" | 135 | [ "<iq type='error'" |
@@ -217,10 +240,11 @@ presence_response host (Elem _ attrs content) = do | |||
217 | doCon st elem cont = do | 240 | doCon st elem cont = do |
218 | let h = hOccursFst st :: Handle | 241 | let h = hOccursFst st :: Handle |
219 | host = "localhost" | 242 | host = "localhost" |
243 | (session,cmdChan) = hHead st | ||
220 | hsend r = do | 244 | hsend r = do |
221 | hPutStrLn h r | 245 | atomically $ writeTChan cmdChan (Send r) |
246 | -- hPutStrLn h r | ||
222 | L.putStrLn $ "\nOUT:\n" <++> r | 247 | L.putStrLn $ "\nOUT:\n" <++> r |
223 | session = hHead st | ||
224 | 248 | ||
225 | putStrLn $ (show $ hang (text "\nIN:") 2 $ pp elem) ++ "\n" | 249 | putStrLn $ (show $ hang (text "\nIN:") 2 $ pp elem) ++ "\n" |
226 | 250 | ||
diff --git a/Presence/main.hs b/Presence/main.hs index 78ca4363..44af40e3 100644 --- a/Presence/main.hs +++ b/Presence/main.hs | |||
@@ -82,18 +82,19 @@ instance XMPPSession UnixSession where | |||
82 | L.putStrLn $ "SESSION: jid " <++> jid | 82 | L.putStrLn $ "SESSION: jid " <++> jid |
83 | return jid | 83 | return jid |
84 | closeSession _ = L.putStrLn "SESSION: close" | 84 | closeSession _ = L.putStrLn "SESSION: close" |
85 | subscribeToPresence session Nothing = do | 85 | subscribe session Nothing = do |
86 | let tmvar = greedySubscriber (presence_state session) | 86 | let tmvar = greedySubscriber (presence_state session) |
87 | chan <- atomically $ | 87 | chan <- atomically $ |
88 | (do (cnt,chan) <- takeTMVar tmvar | 88 | (do (cnt,chan) <- takeTMVar tmvar |
89 | putTMVar tmvar (cnt+1,chan) | 89 | putTMVar tmvar (cnt+1,chan) |
90 | return chan ) | 90 | chan' <- dupTChan chan |
91 | return chan' ) | ||
91 | `orElse` | 92 | `orElse` |
92 | (do chan <- newTChan | 93 | (do chan <- newTChan |
93 | putTMVar tmvar (1,chan) | 94 | putTMVar tmvar (1,chan) |
94 | return chan ) | 95 | return chan ) |
95 | return chan | 96 | return chan |
96 | subscribeToPresence session (Just jid) = do | 97 | subscribe session (Just jid) = do |
97 | let tvar = subscriberMap (presence_state session) | 98 | let tvar = subscriberMap (presence_state session) |
98 | atomically $ do | 99 | atomically $ do |
99 | subs <- readTVar tvar | 100 | subs <- readTVar tvar |
@@ -104,7 +105,8 @@ instance XMPPSession UnixSession where | |||
104 | newchan <- newTChan | 105 | newchan <- newTChan |
105 | return (newchan, Map.insert jid (1,newchan) subs) | 106 | return (newchan, Map.insert jid (1,newchan) subs) |
106 | Just (cnt,chan) -> do | 107 | Just (cnt,chan) -> do |
107 | return (chan, Map.insert jid (cnt+1,chan) subs) | 108 | chan' <- dupTChan chan |
109 | return (chan', Map.insert jid (cnt+1,chan) subs) | ||
108 | writeTVar tvar subs' | 110 | writeTVar tvar subs' |
109 | return chan | 111 | return chan |
110 | 112 | ||