diff options
-rw-r--r-- | dht/Presence/Stanza/Types.hs | 1 | ||||
-rw-r--r-- | dht/ToxToXMPP.hs | 44 |
2 files changed, 24 insertions, 21 deletions
diff --git a/dht/Presence/Stanza/Types.hs b/dht/Presence/Stanza/Types.hs index 7275c8ab..8fc23f84 100644 --- a/dht/Presence/Stanza/Types.hs +++ b/dht/Presence/Stanza/Types.hs | |||
@@ -1,4 +1,5 @@ | |||
1 | {-# LANGUAGE FlexibleInstances #-} | 1 | {-# LANGUAGE FlexibleInstances #-} |
2 | {-# LANGUAGE StrictData #-} | ||
2 | module Stanza.Types where | 3 | module Stanza.Types where |
3 | 4 | ||
4 | import Control.Concurrent.STM | 5 | import Control.Concurrent.STM |
diff --git a/dht/ToxToXMPP.hs b/dht/ToxToXMPP.hs index 1420c642..aec8f499 100644 --- a/dht/ToxToXMPP.hs +++ b/dht/ToxToXMPP.hs | |||
@@ -1,3 +1,4 @@ | |||
1 | {-# LANGUAGE BangPatterns #-} | ||
1 | {-# LANGUAGE CPP #-} | 2 | {-# LANGUAGE CPP #-} |
2 | {-# LANGUAGE GADTs #-} | 3 | {-# LANGUAGE GADTs #-} |
3 | {-# LANGUAGE LambdaCase #-} | 4 | {-# LANGUAGE LambdaCase #-} |
@@ -103,28 +104,29 @@ toxToXmpp store_invite _ me theirhost = do | |||
103 | [ attr "style" "font-weight:bold; color:red" ] | 104 | [ attr "style" "font-weight:bold; color:red" ] |
104 | (T.pack $ "Unhandled message: " ++ show (msgID toxmsg)) | 105 | (T.pack $ "Unhandled message: " ++ show (msgID toxmsg)) |
105 | 106 | ||
106 | flip fix available $ \loop status -> do | 107 | flip fix available $ \loop !status -> do |
107 | m <- await | 108 | m <- await |
108 | forM_ m $ \(addr,x) -> do | 109 | case m of |
109 | let im_from = (Just $ toxJID theirhost addr) | 110 | Just (addr,x) -> let im_from = Just $ toxJID theirhost addr in case x of |
110 | case x of | 111 | |
111 | Pkt USERSTATUS :=> Identity st -> do | 112 | Pkt USERSTATUS :=> Identity st -> do |
112 | let status' = status { presenceShow = toxUserStatus st } | 113 | let status' = status { presenceShow = toxUserStatus st } |
113 | xmppPresence "jabber:server" im_from status' | 114 | xmppPresence "jabber:server" im_from status' |
114 | loop status' | 115 | loop status' |
115 | 116 | Pkt STATUSMESSAGE :=> Identity bs -> do | |
116 | Pkt STATUSMESSAGE :=> Identity bs -> do | 117 | let status' = status { presenceStatus = [("",bs)] } |
117 | let status' = status { presenceStatus = [("",bs)] } | 118 | xmppPresence "jabber:server" im_from status' |
118 | xmppPresence "jabber:server" im_from status' | 119 | loop status' |
119 | loop status' | 120 | |
120 | 121 | Pkt ONLINE :=> _ -> do | |
121 | Pkt ONLINE :=> _ -> do | 122 | xmppPresence "jabber:server" im_from status |
122 | xmppPresence "jabber:server" im_from status | 123 | loop status |
123 | loop status | 124 | |
124 | 125 | x -> do | |
125 | x -> do | 126 | statelessMessages addr im_from x |
126 | statelessMessages addr im_from x | 127 | loop status |
127 | loop status | 128 | |
129 | Nothing -> return () | ||
128 | 130 | ||
129 | xmppPresence :: Monad m => Text -> Maybe Text -> StanzaType -> ConduitM i XML.Event m () | 131 | xmppPresence :: Monad m => Text -> Maybe Text -> StanzaType -> ConduitM i XML.Event m () |
130 | xmppPresence namespace mjid p = do | 132 | xmppPresence namespace mjid p = do |