summaryrefslogtreecommitdiff
path: root/Presence/XMPPServer.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Presence/XMPPServer.hs')
-rw-r--r--Presence/XMPPServer.hs34
1 files changed, 29 insertions, 5 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
42import Control.Monad.IO.Class 42import Control.Monad.IO.Class
43import Control.DeepSeq 43import Control.DeepSeq
44import Control.Concurrent.STM 44import Control.Concurrent.STM
45import Control.Concurrent
46import Control.Exception
45 47
46-- | Jabber ID (JID) datatype 48-- | Jabber ID (JID) datatype
47data JID = JID { name :: Maybe ByteString 49data 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
66data Presence = Presence JID JabberShow 68data Presence = Presence JID JabberShow
69 deriving Show
67 70
68instance NFData Presence where 71instance 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
81greet host = L.unlines 84greet 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
104data Commands = Send ByteString
105 deriving Show
106
101startCon session_factory sock st = do 107startCon 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
111iq_query_unavailable host id mjid xmlns kind = L.unlines $ 134iq_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
217doCon st elem cont = do 240doCon 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