summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Presence/XMPP.hs17
-rw-r--r--Presence/XMPPTypes.hs8
-rw-r--r--Presence/main.hs25
3 files changed, 41 insertions, 9 deletions
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index c4e4d7f6..fb53c2fb 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -331,6 +331,11 @@ iq_service_unavailable host iq_id mjid req =
331 , EventEndElement "{jabber:client}iq" 331 , EventEndElement "{jabber:client}iq"
332 ] 332 ]
333 333
334getRoster session = do
335 budies <- getMyBuddies session
336 subscribers <- getMySubscribers session
337 return ([]::[Event]) -- TODO
338
334handleIQGet session cmdChan tag = do 339handleIQGet session cmdChan tag = do
335 withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do 340 withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do
336 whenJust nextElement $ \child -> do 341 whenJust nextElement $ \child -> do
@@ -356,6 +361,18 @@ handleIQGet session cmdChan tag = do
356 , EventEndElement "{jabber:client}iq" 361 , EventEndElement "{jabber:client}iq"
357 ] 362 ]
358 atomically . writeTChan cmdChan . Send $ pong 363 atomically . writeTChan cmdChan . Send $ pong
364 "{jabber:iq:roster}query" -> liftIO $ do
365 putStrLn $ "REQUESTED ROSTER " ++ show tag
366 -- REQUESTED ROSTER EventBeginElement
367 -- (Name {nameLocalName = "iq", nameNamespace = Just "jabber:client", namePrefix = Nothing})
368 -- [(Name { nameLocalName = "id"
369 -- , nameNamespace = Nothing
370 -- , namePrefix = Nothing},
371 -- [ContentText "32a337c2-7b22-45b6-9d21-15ded0d079ec"])
372 -- ,(Name {nameLocalName = "type", nameNamespace = Nothing, namePrefix = Nothing},
373 -- [ContentText "get"])]
374 roster <- getRoster session
375 atomically . writeTChan cmdChan . Send $ roster
359 req -> unhandledGet req 376 req -> unhandledGet req
360 377
361 378
diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs
index c6925aa4..747ceb0e 100644
--- a/Presence/XMPPTypes.hs
+++ b/Presence/XMPPTypes.hs
@@ -39,6 +39,11 @@ class JabberClientSession session where
39 closeSession :: session -> IO () 39 closeSession :: session -> IO ()
40 subscribe :: session -> Maybe JID -> IO (TChan Presence) 40 subscribe :: session -> Maybe JID -> IO (TChan Presence)
41 forCachedPresence :: session -> (Presence -> IO ()) -> IO () 41 forCachedPresence :: session -> (Presence -> IO ()) -> IO ()
42 getMyBuddies :: session -> IO [ByteString]
43 getMySubscribers :: session -> IO [ByteString]
44 getMyOthers :: session -> IO [ByteString]
45 getMyPending :: session -> IO [ByteString]
46 getMySolicited :: session -> IO [ByteString]
42 47
43class JabberPeerSession session where 48class JabberPeerSession session where
44 data XMPPPeerClass session 49 data XMPPPeerClass session
@@ -50,9 +55,6 @@ class JabberPeerSession session where
50 peerSessionFactory :: session -> XMPPPeerClass session 55 peerSessionFactory :: session -> XMPPPeerClass session
51 getBuddies :: XMPPPeerClass session -> ByteString -> IO [ByteString] 56 getBuddies :: XMPPPeerClass session -> ByteString -> IO [ByteString]
52 getSubscribers :: XMPPPeerClass session -> ByteString -> IO [ByteString] 57 getSubscribers :: XMPPPeerClass session -> ByteString -> IO [ByteString]
53 getOthers :: XMPPPeerClass session -> ByteString -> IO [ByteString]
54 getPending :: XMPPPeerClass session -> ByteString -> IO [ByteString]
55 getSolicited :: XMPPPeerClass session -> ByteString -> IO [ByteString]
56 58
57-- | Jabber ID (JID) datatype 59-- | Jabber ID (JID) datatype
58data JID = JID { name :: Maybe ByteString 60data JID = JID { name :: Maybe ByteString
diff --git a/Presence/main.hs b/Presence/main.hs
index 25ac994b..0eae8677 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -86,7 +86,7 @@ data PresenceState = PresenceState
86 86
87getJabberUserForId muid = 87getJabberUserForId muid =
88 maybe (return "nobody") 88 maybe (return "nobody")
89 (\uid -> 89 (\(uid,_) ->
90 handle (\(SomeException _) -> 90 handle (\(SomeException _) ->
91 return . L.append "uid." . L.pack . show $ uid) 91 return . L.append "uid." . L.pack . show $ uid)
92 $ do 92 $ do
@@ -129,8 +129,7 @@ instance JabberClientSession ClientSession where
129 129
130 getJID s = do 130 getJID s = do
131 let host = localhost s 131 let host = localhost s
132 muid <- fmap (fmap fst) $ readIORef (unix_uid s) 132 user <- readIORef (unix_uid s) >>= getJabberUserForId
133 user <- getJabberUserForId muid
134 133
135 rsc <- readIORef (unix_resource s) 134 rsc <- readIORef (unix_resource s)
136 -- let jid = user <++> "@" <++> host <++?> "/" <++$> rsc 135 -- let jid = user <++> "@" <++> host <++?> "/" <++$> rsc
@@ -169,6 +168,23 @@ instance JabberClientSession ClientSession where
169 L.putStrLn $ "cached presence: " <++> bshow p 168 L.putStrLn $ "cached presence: " <++> bshow p
170 action p 169 action p
171 170
171 getMyBuddies s = do
172 user <- readIORef (unix_uid s) >>= getJabberUserForId
173 ConfigFiles.getBuddies user
174 getMySubscribers s = do
175 user <- readIORef (unix_uid s) >>= getJabberUserForId
176 ConfigFiles.getSubscribers user
177 getMyOthers s = do
178 user <- readIORef (unix_uid s) >>= getJabberUserForId
179 ConfigFiles.getOthers user
180 getMyPending s = do
181 user <- readIORef (unix_uid s) >>= getJabberUserForId
182 ConfigFiles.getPending user
183 getMySolicited s = do
184 user <- readIORef (unix_uid s) >>= getJabberUserForId
185 ConfigFiles.getSolicited user
186
187
172tupleToJID (user,tty,pid) = jid user LocalHost tty 188tupleToJID (user,tty,pid) = jid user LocalHost tty
173 189
174data PeerSession = PeerSession { 190data PeerSession = PeerSession {
@@ -229,9 +245,6 @@ instance JabberPeerSession PeerSession where
229 245
230 getBuddies _ user = ConfigFiles.getBuddies user 246 getBuddies _ user = ConfigFiles.getBuddies user
231 getSubscribers _ user = ConfigFiles.getSubscribers user 247 getSubscribers _ user = ConfigFiles.getSubscribers user
232 getOthers _ user = ConfigFiles.getOthers user
233 getPending _ user = ConfigFiles.getPending user
234 getSolicited _ user = ConfigFiles.getSolicited user
235 248
236 249
237subscribeToChan tmvar = 250subscribeToChan tmvar =