summaryrefslogtreecommitdiff
path: root/Presence/XMPP.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Presence/XMPP.hs')
-rw-r--r--Presence/XMPP.hs142
1 files changed, 125 insertions, 17 deletions
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index bfa5827e..656ed170 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -1,6 +1,7 @@
1{-# LANGUAGE OverloadedStrings #-} 1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE FlexibleContexts #-} 2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE CPP #-} 3{-# LANGUAGE CPP #-}
4{-# LANGUAGE ViewPatterns #-}
4module XMPP 5module XMPP
5 ( module XMPPTypes 6 ( module XMPPTypes
6 , listenForXmppClients 7 , listenForXmppClients
@@ -38,8 +39,8 @@ import Text.XML.Stream.Parse
38import Text.XML.Stream.Render 39import Text.XML.Stream.Render
39import Data.XML.Types as XML 40import Data.XML.Types as XML
40import Network.BSD (getHostName,hostName,hostAliases) 41import Network.BSD (getHostName,hostName,hostAliases)
41import Data.Text.Encoding as S (decodeUtf8) 42import Data.Text.Encoding as S (decodeUtf8,encodeUtf8)
42import Data.Text.Lazy.Encoding as L (decodeUtf8) 43import Data.Text.Lazy.Encoding as L (decodeUtf8,encodeUtf8)
43import Data.Text.Lazy (toStrict) 44import Data.Text.Lazy (toStrict)
44import GetHostByAddr 45import GetHostByAddr
45import Data.Monoid 46import Data.Monoid
@@ -48,6 +49,8 @@ import Data.Foldable (toList)
48#ifdef RENDERFLUSH 49#ifdef RENDERFLUSH
49import Data.Conduit.Blaze 50import Data.Conduit.Blaze
50#endif 51#endif
52import Data.List (find)
53import qualified Text.Show.ByteString as L
51 54
52data Commands = Send [XML.Event] | QuitThread 55data Commands = Send [XML.Event] | QuitThread
53 deriving Prelude.Show 56 deriving Prelude.Show
@@ -126,24 +129,131 @@ eventIsBeginElement _ = False
126eventIsEndElement (EventEndElement _) = True 129eventIsEndElement (EventEndElement _) = True
127eventIsEndElement _ = False 130eventIsEndElement _ = False
128 131
132filterMapElement::
133 (Monad m, MonadPlus mp) =>
134 (Event -> mp a) -> Event -> mp a -> MaybeT (ConduitM Event o m) (mp a)
135filterMapElement ret opentag empty = loop (empty `mplus` ret opentag) 1
136 where
137 loop ts 0 = return ts
138 loop ts cnt = do
139 tag <- mawait
140 let ts' = mplus ts (ret tag)
141 case () of
142 _ | eventIsEndElement tag -> loop ts' (cnt-1)
143 _ | eventIsBeginElement tag -> loop ts' (cnt+1)
144 _ -> loop ts' cnt
145
129gatherElement :: 146gatherElement ::
130 (Monad m, MonadPlus mp) => 147 (Monad m, MonadPlus mp) =>
131 Event -> mp Event -> MaybeT (ConduitM Event o m) (mp Event) 148 Event -> mp Event -> MaybeT (ConduitM Event o m) (mp Event)
132gatherElement opentag empty = gatherElement' (empty `mplus` return opentag) 1 149gatherElement opentag empty = loop (empty `mplus` return opentag) 1
133 where 150 where
134 gatherElement' ts cnt = do 151 loop ts 0 = return ts
152 loop ts cnt = do
135 tag <- mawait 153 tag <- mawait
136 let ts' = ts `mplus` return tag 154 let ts' = mplus ts (return tag)
137 cnt' = case () of 155 case () of
138 _ | eventIsEndElement tag -> cnt-1 156 _ | eventIsEndElement tag -> loop ts' (cnt-1)
139 _ | eventIsBeginElement tag -> cnt+1 157 _ | eventIsBeginElement tag -> loop ts' (cnt+1)
140 _ -> cnt 158 _ -> loop ts' cnt
141 if (cnt'>0) then gatherElement' ts' cnt' 159
142 else return ts' 160{-
161sourceStanza :: Monad m => Event -> ConduitM Event Event m ()
162sourceStanza opentag = yield opentag >> loop 1
163 where
164 loop 0 = return ()
165 loop cnt = do
166 e <- await
167 let go tag cnt = yield tag >> loop cnt
168 case e of
169 Just tag | eventIsEndElement tag -> go tag (cnt-1)
170 Just tag | eventIsBeginElement tag -> go tag (cnt+1)
171 Just tag -> go tag cnt
172 Nothing -> return ()
173-}
143 174
144voidMaybeT body = (>> return ()) . runMaybeT $ body 175voidMaybeT body = (>> return ()) . runMaybeT $ body
145fixMaybeT f = (>> return ()) . runMaybeT . fix $ f 176fixMaybeT f = (>> return ()) . runMaybeT . fix $ f
146 177
178iq_bind_reply id jid =
179 [ EventBeginElement "{jabber:client}iq" [("type",[ContentText "result"]),("id",[ContentText id])]
180
181 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
182 [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])]
183 , EventBeginElement "jid" []
184 , EventContent (ContentText jid)
185 , EventEndElement "jid"
186 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
187 , EventEndElement "{jabber:client}iq"
188 ]
189
190uncontent cs = head $ map getText cs
191 where
192 getText (ContentText x) = x
193 getText (ContentEntity x ) = x
194
195-- doIQ :: MonadIO m => Event -> MaybeT (ConduitM Event o m) ()
196doIQ session cmdChan tag@(EventBeginElement name attrs) = do
197 (_,uncontent->iq_id) <- MaybeT . return $ find (\(n,v)->isId n) attrs
198 -- The 'id' attribute is REQUIRED for IQ stanzas.
199 -- todo: handle it's absence more gracefully
200 case (find (\(n,v)->isType n) attrs) of
201 Just (_,[ContentText "get"]) -> discard
202 Just (_,[ContentText "set"]) -> do
203 fix $ \iqsetloop -> do
204 setwhat <- mawait
205 liftIO (putStrLn $ "IQ-set " ++ show setwhat)
206 case setwhat of
207 bind@(EventBeginElement name attrs) | isBind name -> do
208 fix $ \again -> do
209 rscElem <- mawait
210 liftIO (putStrLn $ "IQ-set-bind " ++ show rscElem)
211 case rscElem of
212 bindchild@(EventBeginElement name _) | isResource name -> do
213 let isContent (EventContent (ContentText v)) = return v
214 isContent _ = mzero
215 xs <- filterMapElement isContent bindchild Nothing
216 case xs of
217 Just rsrc ->
218 liftIO $ do
219 setResource session (L.fromChunks [S.encodeUtf8 rsrc])
220 jid <- getJID session
221 atomically $ writeTChan cmdChan (Send $ iq_bind_reply iq_id (toStrict $ L.decodeUtf8 $ L.show jid) )
222 Nothing -> return () -- TODO: empty resource tag?
223 void $ gatherElement bind Nothing
224 bindchild@(EventBeginElement _ _) -> do
225 liftIO (putStrLn "unknown bind child")
226 gatherElement bindchild Nothing
227 void $ gatherElement bind Nothing
228 EventEndElement _ -> do
229 liftIO (putStrLn "empty bind")
230 -- TODO
231 -- A server that supports resource binding MUST be able to
232 -- generate a resource identifier on behalf of a client. A
233 -- resource identifier generated by the server MUST be unique
234 -- for that <node@domain>.
235 _ -> again
236 discard
237 req@(EventBeginElement name attrs) -> do
238 liftIO (putStrLn $ "IQ-set-unknown " ++ show req)
239 gatherElement req Nothing
240 discard
241 endtag@(EventEndElement _) -> do
242 liftIO (putStrLn $ "IQ-set-empty" ++ show endtag)
243 _ -> iqsetloop
244 Just (_,[ContentText "result"]) -> discard
245 Just (_,[ContentText "error"]) -> discard
246 Just _ -> discard -- error: type must be one of {get,set,result,error}
247 Nothing -> discard -- error: The 'type' attribute is REQUIRED for IQ stanzas.
248 where
249 isId n = n=="id"
250 isType n = n=="type"
251 isResource n = n=="{urn:ietf:params:xml:ns:xmpp-bind}resource"
252 isBind n = n=="{urn:ietf:params:xml:ns:xmpp-bind}bind"
253 discard = do
254 xs <- gatherElement tag Seq.empty
255 prettyPrint "client-in: ignoring iq:" (toList xs)
256
147fromClient :: (MonadIO m, XMPPSession session) => 257fromClient :: (MonadIO m, XMPPSession session) =>
148 session -> TChan Commands -> Sink XML.Event m () 258 session -> TChan Commands -> Sink XML.Event m ()
149fromClient session cmdChan = voidMaybeT $ do 259fromClient session cmdChan = voidMaybeT $ do
@@ -163,16 +273,14 @@ fromClient session cmdChan = voidMaybeT $ do
163 fix $ \loop -> do 273 fix $ \loop -> do
164 xml <- mawait 274 xml <- mawait
165 log $ bshow xml 275 log $ bshow xml
276 let isIQ n = n=="{jabber:client}iq"
166 case xml of 277 case xml of
167 _ | eventIsEndElement xml -> return () 278 _ | eventIsEndElement xml -> return ()
279 tag@(EventBeginElement name attrs) | isIQ name -> doIQ session cmdChan tag >> loop
280
168 tag@(EventBeginElement _ _) -> do 281 tag@(EventBeginElement _ _) -> do
169 xs <- gatherElement tag Seq.empty 282 xs <- gatherElement tag Seq.empty
170 prettyPrint "client-in: ignoring..." (toList xs) 283 prettyPrint "client-in: ignoring..." (toList xs)
171 {-
172 liftIO (putStrLn "client-in: ignoring\n{")
173 liftIO (mapM_ print xs)
174 liftIO (putStrLn "}")
175 -}
176 loop 284 loop
177 _ -> loop 285 _ -> loop
178 286
@@ -192,7 +300,7 @@ toClient pchan cmdChan = fix $ \loop -> do
192 (fmap Right $ readTChan cmdChan) 300 (fmap Right $ readTChan cmdChan)
193 case event of 301 case event of
194 Right QuitThread -> return () 302 Right QuitThread -> return ()
195 Right (Send xs) -> yield xs >> loop -- prettyPrint "client-out: " xs >> loop 303 Right (Send xs) -> yield xs >> prettyPrint "client-out: " xs >> loop
196 Left presence -> do 304 Left presence -> do
197 xs <- liftIO $ xmlifyPresenceForClient presence 305 xs <- liftIO $ xmlifyPresenceForClient presence
198 yield xs 306 yield xs