summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ConduitServer.hs48
-rw-r--r--Presence/XMPP.hs1461
-rw-r--r--simplechat.hs66
-rw-r--r--test-server.hs541
4 files changed, 0 insertions, 2116 deletions
diff --git a/ConduitServer.hs b/ConduitServer.hs
deleted file mode 100644
index 0838ce26..00000000
--- a/ConduitServer.hs
+++ /dev/null
@@ -1,48 +0,0 @@
1{-# LANGUAGE OverloadedStrings #-}
2module Main where
3
4import Data.Conduit.Binary
5import Data.Conduit.Network
6import Data.Conduit
7import qualified Data.Conduit.List as CL
8import qualified Data.ByteString.Char8 as S
9
10import Network.Socket (Family(..))
11import Data.HList
12import ServerC
13
14{-
15data AppData m = AppData
16 { appSource :: Source m ByteString
17 , appSink :: Sink ByteString m ()
18 , appSockAddr :: SockAddr
19 , appLocalAddr :: Maybe SockAddr
20 }
21-}
22
23-- handleConnection will simply output everything
24-- it sees from the connection to the terminal
25handleConnection :: AppData IO -> IO ()
26handleConnection appdata = do
27 sourceLbs "<stream>\n" $$ appSink appdata -- send bytestring
28 appSource appdata $$ CL.mapM_ S.putStrLn -- display inbound bytestring
29
30mainOld = do
31 -- Listen to port 5222 and invoke handleConnection on every
32 -- inbound connection.
33 runTCPServer (serverSettings 5222 HostAny) handleConnection
34 return ()
35
36
37
38
39handleC st src snk = do
40 sourceLbs "<stream>\n" $$ snk
41 src $$ CL.mapM_ S.putStrLn
42
43mainC = do
44 doServer (AF_INET .*. 5222 .*. HNil) handleC
45 _ <- getLine
46 return ()
47
48main = mainC
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
deleted file mode 100644
index eab57da5..00000000
--- a/Presence/XMPP.hs
+++ /dev/null
@@ -1,1461 +0,0 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE ViewPatterns #-}
4{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE CPP #-}
6module XMPP
7 ( module XMPPTypes
8 , listenForXmppClients
9 , listenForRemotePeers
10 , newServerConnections
11 , seekRemotePeers
12 , quitListening
13 , OutBoundMessage(..)
14 , OutgoingConnections
15 , CachedMessages
16 , toPeer
17 , newOutgoingConnections
18 , sendMessage
19 ) where
20
21import ServerC
22import XMPPTypes
23import ByteStringOperators
24import ControlMaybe
25import XMLToByteStrings
26import SendMessage
27import Logging
28import Todo
29
30import Data.Maybe (catMaybes)
31import Data.HList hiding (hHead)
32import Network.Socket ( Family )
33import Control.Concurrent.STM
34import Control.Concurrent.STM.Delay
35import Data.Conduit
36import Data.Maybe
37import Data.ByteString (ByteString)
38import qualified Data.ByteString.Lazy.Char8 as L
39 ( fromChunks
40 )
41import Control.Concurrent.Async
42import Control.Exception as E ( finally )
43import System.IO.Error (isDoesNotExistError)
44import Control.Monad.IO.Class
45import Control.Monad.Trans.Class
46import Control.Monad.Trans.Maybe
47import Text.XML.Stream.Parse (def,parseBytes,content)
48import Data.XML.Types as XML
49import qualified Data.Text as S (Text,takeWhile)
50import Data.Text.Encoding as S (decodeUtf8,encodeUtf8)
51import Data.Text.Lazy.Encoding as L (decodeUtf8)
52import Data.Text.Lazy (toStrict)
53import qualified Data.Sequence as Seq
54import Data.Foldable (toList)
55import Data.List (find)
56import qualified Text.Show.ByteString as L
57import NestingXML
58import Data.Set as Set (Set,(\\))
59import qualified Data.Set as Set
60import qualified Data.Map as Map
61import Data.Map as Map (Map)
62
63#if MIN_VERSION_HList(0,3,0)
64#define HCONS HCons'
65#else
66#define HCONS HCons
67#endif
68
69hHead (HCONS x _) = x
70
71textToByteString x = L.fromChunks [S.encodeUtf8 x]
72
73
74
75xmlifyPresenceForClient :: Presence -> IO [XML.Event]
76xmlifyPresenceForClient (Presence jid stat) = do
77 let n = name jid
78 rsc = resource jid
79 names <- getNamesForPeer (peer jid)
80 let tostr p = L.decodeUtf8 $ n <$++> "@" <?++> L.fromChunks [p] <++?> "/" <++$> rsc
81 jidstrs = fmap (toStrict . tostr) names
82 return (concatMap presenceEvents jidstrs)
83 where
84 presenceEvents jidstr =
85 [ EventBeginElement "{jabber:client}presence" (("from",[ContentText jidstr]):typ stat) ]
86 ++ ( shw stat >>= jabberShow ) ++
87 [ EventEndElement "{jabber:client}presence" ]
88 typ Offline = [("type",[ContentText "unavailable"])]
89 typ _ = []
90 shw ExtendedAway = ["xa"]
91 shw Chatty = ["chat"]
92 shw Away = ["away"]
93 shw DoNotDisturb = ["dnd"]
94 shw _ = []
95 jabberShow stat =
96 [ EventBeginElement "{jabber:client}show" []
97 , EventContent (ContentText stat)
98 , EventEndElement "{jabber:client}show" ]
99
100prefix ## name = Name name Nothing (Just prefix)
101
102streamP name = Name name (Just "http://etherx.jabber.org/streams") (Just "stream")
103
104greet host =
105 [ EventBeginDocument
106 , EventBeginElement (streamP "stream")
107 [("from",[ContentText host])
108 ,("id",[ContentText "someid"])
109 ,("xmlns",[ContentText "jabber:client"])
110 ,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"])
111 ,("version",[ContentText "1.0"])
112 ]
113 , EventBeginElement (streamP "features") []
114 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" []
115 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
116
117 {-
118 -- , " <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>"
119 , " <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"
120 -- , " <mechanism>DIGEST-MD5</mechanism>"
121 , " <mechanism>PLAIN</mechanism>"
122 , " </mechanisms> "
123 -}
124
125 , EventEndElement (streamP "features")
126 ]
127
128
129-- type Consumer i m r = forall o. ConduitM i o m r
130mawait :: Monad m => MaybeT (ConduitM i o m) i
131mawait = MaybeT await
132
133-- Note: This function ignores name space qualification
134elementAttrs expected (EventBeginElement name attrs)
135 | nameLocalName name==expected
136 = return attrs
137elementAttrs _ _ = mzero
138
139eventIsBeginElement (EventBeginElement _ _) = True
140eventIsBeginElement _ = False
141
142eventIsEndElement (EventEndElement _) = True
143eventIsEndElement _ = False
144
145filterMapElement::
146 (Monad m, MonadPlus mp) =>
147 (Event -> mp a) -> Event -> mp a -> MaybeT (ConduitM Event o m) (mp a)
148filterMapElement ret opentag empty = loop (empty `mplus` ret opentag) 1
149 where
150 loop ts 0 = return ts
151 loop ts cnt = do
152 tag <- mawait
153 let ts' = mplus ts (ret tag)
154 case () of
155 _ | eventIsEndElement tag -> loop ts' (cnt-1)
156 _ | eventIsBeginElement tag -> loop ts' (cnt+1)
157 _ -> loop ts' cnt
158
159gatherElement ::
160 (Monad m, MonadPlus mp) =>
161 Event -> mp Event -> NestingXML o m (mp Event)
162gatherElement opentag empty = loop (empty `mplus` return opentag) 1
163 where
164 loop ts 0 = return ts
165 loop ts cnt = do
166 maybeXML (return ts) $ \tag -> do
167 let ts' = mplus ts (return tag)
168 case () of
169 _ | eventIsEndElement tag -> loop ts' (cnt-1)
170 _ | eventIsBeginElement tag -> loop ts' (cnt+1)
171 _ -> loop ts' cnt
172
173
174voidMaybeT body = (>> return ()) . runMaybeT $ body
175fixMaybeT f = (>> return ()) . runMaybeT . fix $ f
176
177iq_bind_reply id jid =
178 [ EventBeginElement "{jabber:client}iq" [("type",[ContentText "result"]),("id",[ContentText id])]
179
180 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
181 [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])]
182 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}jid" []
183 , EventContent (ContentText jid)
184 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}jid"
185 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
186 , EventEndElement "{jabber:client}iq"
187 ]
188
189uncontent cs = head $ map getText cs
190 where
191 getText (ContentText x) = x
192 getText (ContentEntity x ) = x
193
194tagAttrs (EventBeginElement _ xs) = xs
195tagAttrs _ = []
196
197tagName (EventBeginElement n _) = n
198tagName _ = ""
199
200handleIQSetBind session cmdChan stanza_id = do
201 mchild <- nextElement
202 rsc <- case mchild of
203 Just child -> do
204 let unhandledBind = do
205 liftIO $ debugStr $ "unhandled-bind: "++show child
206 return ""
207 case tagName child of
208 "{urn:ietf:params:xml:ns:xmpp-bind}resource"
209 -> do
210 rsc <- lift content
211 return . textToByteString $ rsc
212 _ -> unhandledBind
213 Nothing -> do
214 liftIO $ debugStr $ "empty bind request!"
215 return ""
216 liftIO $ do
217 debugL $ "iq-set-bind-resource " <++> rsc
218 setResource session rsc
219 jid <- getJID session
220 atomically $ do
221 writeTChan cmdChan (Send $ iq_bind_reply stanza_id (toStrict $ L.decodeUtf8 $ L.show jid) )
222 writeTChan cmdChan BoundToResource
223 forCachedPresence session $ \presence -> do
224 xs <- xmlifyPresenceForClient presence
225 atomically . writeTChan cmdChan . Send $ xs
226
227
228iq_session_reply host stanza_id =
229 [ EventBeginElement "{jabber:client}iq"
230 [("id",[ContentText stanza_id])
231 ,("from",[ContentText host])
232 ,("type",[ContentText "result"])
233 ]
234 , EventEndElement "{jabber:client}iq"
235 ]
236
237handleIQSetSession session cmdChan stanza_id = do
238 host <- liftIO $ do
239 jid <- getJID session
240 names <- getNamesForPeer (peer jid)
241 return (S.decodeUtf8 . head $ names)
242 liftIO . atomically . writeTChan cmdChan . Send $ iq_session_reply host stanza_id
243
244handleIQSet session cmdChan tag = do
245 withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do
246 whenJust nextElement $ \child -> do
247 let unhandledSet = liftIO $ debugStr ("iq-set: "++show (stanza_id,child))
248 case tagName child of
249 "{urn:ietf:params:xml:ns:xmpp-bind}bind"
250 -> handleIQSetBind session cmdChan stanza_id
251 "{urn:ietf:params:xml:ns:xmpp-session}session"
252 -> handleIQSetSession session cmdChan stanza_id
253 _ -> unhandledSet
254
255matchAttrib name value attrs =
256 case find ( (==name) . fst) attrs of
257 Just (_,[ContentText x]) | x==value -> True
258 Just (_,[ContentEntity x]) | x==value -> True
259 _ -> False
260
261lookupAttrib name attrs =
262 case find ( (==name) . fst) attrs of
263 Just (_,[ContentText x]) -> Just x
264 Just (_,[ContentEntity x]) -> Just x
265 _ -> Nothing
266
267iqTypeSet = "set"
268iqTypeGet = "get"
269iqTypeResult = "result"
270iqTypeError = "error"
271
272isIQOf (EventBeginElement name attrs) testType
273 | name=="{jabber:client}iq"
274 && matchAttrib "type" testType attrs
275 = True
276isIQOf _ _ = False
277
278isServerIQOf (EventBeginElement name attrs) testType
279 | name=="{jabber:server}iq"
280 && matchAttrib "type" testType attrs
281 = True
282isServerIQOf _ _ = False
283
284iq_service_unavailable host iq_id mjid req =
285 [ EventBeginElement "{jabber:client}iq"
286 [("type",[ContentText "error"])
287 ,("id",[ContentText iq_id])
288 -- , TODO: set "from" if isJust mjid
289 ]
290 , EventBeginElement req []
291 , EventEndElement req
292 , EventBeginElement "{jabber:client}error" [("type",[ContentText "cancel"])]
293 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable" []
294 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable"
295 , EventEndElement "{jabber:client}error"
296 , EventEndElement "{jabber:client}iq"
297 ]
298
299attr name value = (name,[ContentText value])
300attrbs name value = (name,[ContentText (toStrict . L.decodeUtf8 $ value)])
301
302
303getRoster session iqid = do
304 let getlist f = do
305 bs <- f session
306 -- js <- mapM parseHostNameJID bs
307 return (Set.fromList bs) -- js)
308 buddies <- getlist getMyBuddies
309 subscribers <- getlist getMySubscribers
310 solicited <- getlist getMySolicited
311 subnone0 <- getlist getMyOthers
312 let subnone = subnone0 \\ (Set.union buddies subscribers)
313 let subto = buddies \\ subscribers
314 let subfrom = subscribers \\ buddies
315 let subboth = Set.intersection buddies subscribers
316 -- solicited -> ask='subscribe'
317 jid <- getJID session
318 let dest = toStrict . L.decodeUtf8 . bshow $ jid
319 let items= (xmlify solicited "to" subto)
320 ++(xmlify solicited "from" subfrom)
321 ++(xmlify solicited "both" subboth)
322 ++(xmlify solicited "none" subnone)
323 openiq = [EventBeginElement "{jabber:client}iq"
324 [ attr "id" iqid
325 , attr "to" dest
326 , attr "type" "result" ]
327 ,EventBeginElement "{jabber:iq:roster}query"
328 [] -- todo: ver?
329 ]
330 closeiq = [EventEndElement "{jabber:iq:roster}query"
331 ,EventEndElement "{jabber:client}iq"]
332 return $ openiq ++ items ++ closeiq
333 where
334 xmlify solicited stype set = flip concatMap (Set.toList set)
335 $ \jid ->
336 [ EventBeginElement "item"
337 ([ attr "jid" (toStrict . L.decodeUtf8 $ jid)
338 , attr "subscription" stype
339 ]++if Set.member jid solicited
340 then [attr "ask" "subscribe"]
341 else [] )
342 , EventEndElement "item"
343 ]
344
345handleIQGet session cmdChan tag = do
346 withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do
347 whenJust nextElement $ \child -> do
348 host <- liftIO $ do
349 jid <- getJID session
350 names <- getNamesForPeer (peer jid)
351 return (S.decodeUtf8 . head $ names)
352 let unhandledGet req = do
353 liftIO $ debugStr ("iq-get: "++show (stanza_id,child))
354 liftIO . atomically . writeTChan cmdChan . Send $ iq_service_unavailable host stanza_id Nothing req
355 case tagName child of
356 -- "{http://jabber.org/protocol/disco#items}query" -> liftIO $ debugStr "iq-get-query-items"
357 "{urn:xmpp:ping}ping" -> liftIO $ do
358 let mjid = lookupAttrib "from" (tagAttrs tag)
359 let pong = [ EventBeginElement "{jabber:client}iq"
360 $ (case mjid of
361 Just jid -> (attr "to" jid :)
362 _ -> id )
363 [ attr "type" "result"
364 , attr "id" stanza_id
365 , attr "from" host
366 ]
367 , EventEndElement "{jabber:client}iq"
368 ]
369 atomically . writeTChan cmdChan . Send $ pong
370 "{jabber:iq:roster}query" -> liftIO $ do
371 debugStr $ "REQUESTED ROSTER " ++ show tag
372 roster <- getRoster session stanza_id
373 atomically $ do
374 writeTChan cmdChan InterestedInRoster
375 writeTChan cmdChan . Send $ roster
376 sendPending session
377 req -> unhandledGet req
378
379
380handleClientPresence session stanza = do
381 -- online (Available or Away)
382 let log = liftIO . debugL . ("(C) " <++>)
383 log $ "handleClientPresence "<++>bshow stanza
384 jid <- liftIO $ getJID session
385 -- cjid <- liftIO $ parseAddressJID (textToByteString jid)
386 let parseChildren stat = do
387 child <- nextElement
388 log $ " child: "<++> bshow child
389 case child of
390 Just tag | tagName tag=="{jabber:client}show"
391 -> fmap toStat (lift content)
392 Just tag | otherwise -> parseChildren stat
393 Nothing -> return stat
394 toStat "away" = Away
395 toStat "xa" = ExtendedAway
396 toStat "dnd" = DoNotDisturb
397 toStat "chat" = Chatty
398
399 stat' <- parseChildren Available
400 liftIO $ setPresence session stat'
401 log $ "requesting presence: "<++>bshow stat'
402 return ()
403
404
405fromClient :: (MonadThrow m,MonadIO m, JabberClientSession session) =>
406 session -> TChan ClientCommands -> Sink XML.Event m ()
407fromClient session cmdChan = doNestingXML $ do
408 let log = liftIO . debugL . ("(C) " <++>)
409 send = liftIO . atomically . writeTChan cmdChan . Send
410 withXML $ \begindoc -> do
411 when (begindoc==EventBeginDocument) $ do
412 log "begin-doc"
413 withXML $ \xml -> do
414 withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
415 log $ "stream atributes: " <++> bshow stream_attrs
416 host <- liftIO $ do
417 jid <- getJID session
418 names <- getNamesForPeer (peer jid)
419 return (S.decodeUtf8 . head $ names)
420 send $ greet host
421
422 fix $ \loop -> do
423 log "waiting for stanza."
424 whenJust nextElement $ \stanza -> do
425 stanza_lvl <- nesting
426
427 liftIO . debugStr $ "stanza: "++show stanza
428
429 let unhandledStanza = do
430 xs <- gatherElement stanza Seq.empty
431 prettyPrint "unhandled-C: " (toList xs)
432 case () of
433 _ | stanza `isIQOf` iqTypeSet -> handleIQSet session cmdChan stanza
434 _ | stanza `isIQOf` iqTypeGet -> handleIQGet session cmdChan stanza
435 _ | stanza `isClientPresenceOf` presenceTypeSubscribe
436 -> clientRequestsSubscription session cmdChan stanza
437 _ | stanza `isClientPresenceOf` presenceTypeSubscribed
438 -> clientApprovesSubscription session stanza
439 _ | stanza `isClientPresenceOf` presenceTypeUnsubscribed
440 -> clientRejectsSubscription session stanza
441 _ | stanza `isClientPresenceOf` presenceTypeOnline
442 -> handleClientPresence session stanza
443 _ | isMessageStanza stanza -> handleClientMessage session stanza
444 _ | otherwise -> unhandledStanza
445
446 awaitCloser stanza_lvl
447 loop
448
449 log $ "end of stream"
450 withXML $ \xml -> do
451 log $ "end-of-document: " <++> bshow xml
452
453
454rosterPush to contact attrs = do
455 let n = name to
456 rsc = resource to
457 names <- getNamesForPeer (peer to)
458 let tostr p = L.decodeUtf8 $ n <$++> "@" <?++> L.fromChunks [p] <++?> "/" <++$> rsc
459 jidstrs = fmap (toStrict . tostr) names
460 tojid = head jidstrs
461 return
462 [ EventBeginElement "{jabber:client}iq"
463 [ attr "to" tojid
464 , attr "id" "someid"
465 , attr "type" "set"
466 ]
467 , EventBeginElement "{jabber:iq:roster}query" []
468 , EventBeginElement "{jabber:iq:roster}item" (attr "jid" contact : attrs)
469 , EventEndElement "{jabber:iq:roster}item"
470 , EventEndElement "{jabber:iq:roster}query"
471 , EventEndElement "{jabber:client}iq"
472 ]
473
474data EventsForClient = CmdChan ClientCommands
475 | PChan Presence
476 | RChan RosterEvent
477
478toClient :: (MonadIO m, JabberClientSession session ) =>
479 session -> TChan Presence -> TChan ClientCommands -> TChan RosterEvent -> Source m [XML.Event]
480toClient session pchan cmdChan rchan = toClient' False False
481 where
482 toClient' isBound isInterested = do
483 let loop = toClient' isBound isInterested
484 send xs = yield xs >> prettyPrint ">C: " xs
485 event <- liftIO . atomically $
486 foldr1 orElse [fmap CmdChan $ readTChan cmdChan
487 ,fmap RChan $ readTChan rchan
488 ,fmap PChan $ readTChan pchan
489 ]
490 case event of
491 CmdChan QuitThread -> return ()
492 CmdChan (Send xs) -> send xs >> loop
493 CmdChan BoundToResource -> toClient' True isInterested
494 CmdChan InterestedInRoster -> do
495 liftIO . debugStr $ "Roster: interested"
496 toClient' isBound True
497 CmdChan (Chat msg) -> do
498 xs <- liftIO $ xmlifyMessageForClient msg
499 send xs
500 loop
501 -- CmdChan cmd -> liftIO (debugStr $ "unhandled event: "++show cmd) >> loop
502 RChan (RequestedSubscription who contact) -> do
503 jid <- liftIO $ getJID session
504 when (isInterested && Just who==name jid) $ do
505 r <- liftIO $ rosterPush jid (toStrict . L.decodeUtf8 $ contact) [attr "ask" "subscribe"]
506 send r
507 loop
508 RChan (NewBuddy who contact) -> do
509 liftIO . debugStr $ "Roster push: NewBuddy "++show (isInterested,who,contact)
510 (jid,me) <- liftIO $ do
511 jid <- getJID session
512 me <- asHostNameJID jid
513 return (jid,me)
514 withJust me $ \me -> do
515 when (isInterested && Just who==name jid) $ do
516 send [ EventBeginElement "{jabber:client}presence"
517 [ attrbs "from" contact
518 , attrbs "to" me
519 , attr "type" "subscribed"
520 ]
521 , EventEndElement "{jabber:client}presence" ]
522 let f True = "both"
523 f False = "to"
524 subscription <- fmap f (liftIO $ isSubscribed session contact)
525 r <- liftIO . handleIO (\e -> debugStr ("Roster NewBuddy error: "++show e) >> return []) $ do
526 rosterPush jid
527 (toStrict . L.decodeUtf8 $ contact)
528 [attr "subscription" subscription]
529 send r
530 loop
531 RChan (RemovedBuddy who contact) -> do
532 liftIO . debugStr $ "Roster push: RemovedBuddy "++show (isInterested,who,contact)
533 (jid,me) <- liftIO $ do
534 jid <- getJID session
535 me <- asHostNameJID jid
536 return (jid,me)
537 withJust me $ \me -> do
538 when (isInterested && Just who==name jid) $ do
539 send [ EventBeginElement "{jabber:client}presence"
540 [ attrbs "from" contact
541 , attrbs "to" me
542 , attr "type" "unsubscribed"
543 ]
544 , EventEndElement "{jabber:client}presence" ]
545 let f True = "from"
546 f False = "none"
547 subscription <- fmap f (liftIO $ isSubscribed session contact)
548 r <- liftIO . handleIO (\e -> debugStr ("Roster RemovedBuddy error: "++show e) >> return []) $ do
549 rosterPush jid
550 (toStrict . L.decodeUtf8 $ contact)
551 [attr "subscription" subscription]
552 send r
553 loop
554 RChan (NewSubscriber who contact) -> do
555 liftIO . debugStr $ "Roster push: NewSubscriber "++show (isInterested,who,contact)
556 (jid,me) <- liftIO $ do
557 jid <- getJID session
558 me <- asHostNameJID jid
559 return (jid,me)
560 withJust me $ \me -> do
561 when (isInterested && Just who==name jid) $ do
562 let f True = "both"
563 f False = "from"
564 subscription <- fmap f (liftIO $ isBuddy session contact)
565 r <- liftIO . handleIO (\e -> debugStr ("Roster NewSubscriber error: "++show e) >> return []) $ do
566 rosterPush jid
567 (toStrict . L.decodeUtf8 $ contact)
568 [attr "subscription" subscription]
569 send r
570 loop
571 RChan (RejectSubscriber who contact) -> do
572 liftIO . debugStr $ "Roster push: RejectSubscriber "++show (isInterested,who,contact)
573 (jid,me) <- liftIO $ do
574 jid <- getJID session
575 me <- asHostNameJID jid
576 return (jid,me)
577 withJust me $ \me -> do
578 when (isInterested && Just who==name jid) $ do
579 let f True = "to"
580 f False = "none"
581 subscription <- fmap f (liftIO $ isBuddy session contact)
582 r <- liftIO . handleIO (\e -> debugStr ("Roster RejectSubscriber error: "++show e) >> return []) $ do
583 rosterPush jid
584 (toStrict . L.decodeUtf8 $ contact)
585 [attr "subscription" subscription]
586 send r
587 loop
588 RChan (PendingSubscriber who contact) -> do
589 liftIO . debugStr $ "Roster: Pending buddy "++show (isInterested,who,contact)
590 (jid,me) <- liftIO $ do
591 jid <- getJID session
592 me <- asHostNameJID jid
593 return (jid,me)
594 withJust me $ \me -> do
595 when (isInterested && Just who==name jid) $ do
596 send [ EventBeginElement "{jabber:client}presence"
597 [ attrbs "from" contact
598 , attrbs "to" me
599 , attr "type" "subscribe"
600 ]
601 , EventEndElement "{jabber:client}presence" ]
602 loop
603 PChan presence -> do
604 when isBound $ do
605 xs <- liftIO $ xmlifyPresenceForClient presence
606 send xs
607 loop
608
609
610{-
611handleClient
612 :: (SocketLike sock, HHead l (XMPPClass session),
613 JabberClientSession session) =>
614 HCONS sock (HCONS t l) -> Source IO ByteString -> Sink ByteString IO () -> IO ()
615-}
616handleClient st src snk = do
617#if MIN_VERSION_HList(0,3,0)
618 let HCons' sock (HCons' _ st') = st
619#else
620 let HCons sock (HCons _ st') = st
621#endif
622 session_factory = hHead st'
623 pname <- getPeerName sock
624 session <- newSession session_factory sock
625 debugStr $ "PEER NAME: "++Prelude.show pname
626 pchan <- subscribe session Nothing
627 rchan <- subscribeToRoster session
628 let cmdChan = clientChannel session
629
630 writer <- async ( toClient session pchan cmdChan rchan `xmlToByteStrings` snk )
631 finally ( src $= parseBytes def $$ fromClient session cmdChan )
632 $ do
633 atomically $ writeTChan cmdChan QuitThread
634 wait writer
635 closeSession session
636
637{-
638listenForXmppClients ::
639 (HList l, HHead l (XMPPClass session), HExtend e1 l2 l1,
640 HExtend e l1 (HCONS PortNumber l), JabberClientSession session) =>
641 Family -> e1 -> e -> l2 -> IO ServerHandle
642-}
643listenForXmppClients addr_family session_factory port st = do
644#if MIN_VERSION_HList(0,3,0)
645 doServer (HCons' addr_family $ HCons' port $ HCons' session_factory st) handleClient
646#else
647 doServer (HCons addr_family $ HCons port $ HCons session_factory st) handleClient
648#endif
649
650
651{-
652listenForRemotePeers
653 :: (HList l, HHead l (XMPPPeerClass session),
654 HExtend e l1 (HCONS PortNumber l), HExtend e1 l2 l1,
655 JabberPeerSession session) =>
656 Family -> e1 -> e -> l2 -> IO ServerHandle
657-}
658listenForRemotePeers addrfamily session_factory port st = do
659#if MIN_VERSION_HList(0,3,0)
660 doServer (HCons' addrfamily $ HCons' port $ HCons' session_factory st) handlePeer
661#else
662 doServer (HCons addrfamily $ HCons port $ HCons session_factory st) handlePeer
663#endif
664
665{-
666handlePeer
667 :: (HHead l (XMPPPeerClass session),
668 JabberPeerSession session) =>
669 HCONS RestrictedSocket (HCONS t1 l) -> Source IO ByteString -> t -> IO ()
670-}
671handlePeer st src snk = do
672#if MIN_VERSION_HList(0,3,0)
673 let HCons' sock (HCons' _ st') = st
674#else
675 let HCons sock (HCons _ st') = st
676#endif
677 session_factory = hHead st'
678 name <- fmap bshow $ getPeerName sock
679 debugL $ "(P) connected " <++> name
680 session <- newPeerSession session_factory sock
681
682 didClose <- newTVarIO False
683 finally ( src $= parseBytes def $$ fromPeer sock session didClose )
684 $ do
685 debugL $ "(P) disconnected " <++> name
686 didc <- readTVarIO didClose
687 when (not didc) $ closePeerSession session
688
689
690handlePeerPresence session stanza False = do
691 -- Offline
692 liftIO . debugStr $ "PEER-OFFLINE: "++show stanza
693 withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do
694 peer_jid <- liftIO $ parseAddressJID (textToByteString jid)
695 liftIO . debugStr $ "PEER-OFFLINE-JID: "++show peer_jid
696 liftIO $ announcePresence session (Presence peer_jid Offline)
697handlePeerPresence session stanza True = do
698 -- online (Available or Away)
699 let log = liftIO . debugL . ("(P) " <++>)
700 withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do
701 pjid <- liftIO $ parseAddressJID (textToByteString jid)
702 -- stat <- show element content
703 let parseChildren stat = do
704 child <- nextElement
705 case child of
706 Just tag | tagName tag=="{jabber:server}show"
707 -> fmap toStat (lift content)
708 Just tag | otherwise -> parseChildren stat
709 Nothing -> return stat
710 toStat "away" = Away
711 toStat "xa" = ExtendedAway
712 toStat "dnd" = DoNotDisturb
713 toStat "chat" = Chatty
714
715 stat' <- parseChildren Available
716 liftIO . debugStr $ "announcing peer online: "++show (pjid,stat')
717 liftIO $ announcePresence session (Presence pjid stat')
718 log $ bshow (Presence pjid stat')
719
720handlePeerMessage session stanza = do
721 withJust (lookupAttrib "from" (tagAttrs stanza)) $ \fromstr-> do
722 withJust (lookupAttrib "to" (tagAttrs stanza)) $ \tostr -> do
723 fromjid <- liftIO $ parseAddressJID (textToByteString fromstr)
724 tojid <- liftIO $ parseAddressJID (textToByteString tostr)
725 let log = liftIO . debugL . ("(P) " <++>)
726 log $ "handlePeerMessage "<++>bshow stanza
727 msg <- parseMessage ("{jabber:server}body"
728 ,"{jabber:server}subject"
729 ,"{jabber:server}thread"
730 )
731 log
732 fromjid
733 tojid
734 stanza
735 liftIO $ sendChatToClient session msg
736
737matchAttribMaybe name (Just value) attrs =
738 case find ( (==name) . fst) attrs of
739 Just (_,[ContentText x]) | x==value -> True
740 Just (_,[ContentEntity x]) | x==value -> True
741 _ -> False
742matchAttribMaybe name Nothing attrs
743 | find ( (==name) . fst) attrs==Nothing
744 = True
745matchAttribMaybe name Nothing attrs
746 | otherwise
747 = False
748
749presenceTypeOffline = Just "unavailable"
750presenceTypeOnline = Nothing
751presenceTypeProbe = Just "probe"
752presenceTypeSubscribe = Just "subscribe"
753presenceTypeSubscribed = Just "subscribed"
754presenceTypeUnsubscribed = Just "unsubscribed"
755
756isPresenceOf (EventBeginElement name attrs) testType
757 | name=="{jabber:server}presence"
758 && matchAttribMaybe "type" testType attrs
759 = True
760isPresenceOf _ _ = False
761
762isMessageStanza (EventBeginElement name attrs)
763 | name=="{jabber:client}message"
764 = True
765isMessageStanza (EventBeginElement name attrs)
766 | name=="{jabber:server}message"
767 = True
768isMessageStanza _ = False
769
770isClientPresenceOf (EventBeginElement name attrs) testType
771 | name=="{jabber:client}presence"
772 && matchAttribMaybe "type" testType attrs
773 = True
774isClientPresenceOf _ _ = False
775
776
777handlePresenceProbe session stanza = do
778 withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to -> do
779 -- withJust (lookupAttrib "from" (tagAttrs stanza)) $ \from -> do
780 jid <- liftIO $ parseAddressJID $ textToByteString to
781 withJust (name jid) $ \user -> do
782 liftIO $ debugL $ "RECEIVED PROBE "<++>bshow (peerAddress session,to)
783 liftIO $ do
784 subs <- getSubscribers (peerSessionFactory session) user
785 liftIO $ debugL $ "subscribers for "<++>bshow user<++>": " <++>bshow subs
786 forM_ subs $ \jidstr -> do
787 handleIO_ (return ()) $ do
788 debugL $ "parsing " <++>jidstr
789 sub <- parseHostNameJID jidstr
790 debugStr $ "comparing " ++show (peer sub , peerAddress session)
791 when (peer sub == discardPort (peerAddress session)) $ do
792 ps <- userStatus session user
793 -- todo: Consider making this a directed presence
794 forM_ ps $ \p -> do
795 debugStr ("PROBE-REPLY: "++show p)
796 mapM_ (sendPeerMessage session . OutBoundPresence) ps
797 return ()
798
799subscribeToPresence subscribers peer_jid user = do
800 pjid <- parseAddressJID peer_jid
801 if Set.member pjid subscribers
802 then return ()
803 else return ()
804
805bare (JID n host _) = JID n host Nothing
806
807presenceErrorRemoteNotFound iqid from to = return
808 [ EventBeginElement "{stream:client}presence"
809 ( case iqid of { Nothing -> id; Just iqid -> ( attr "id" iqid :) }
810 $ [ attr "from" to
811 , attr "type" "error"
812 ] )
813 , EventBeginElement "{stream:client}error"
814 [ attr "type" "modify"]
815 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}remote-server-not-found"
816 []
817 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}remote-server-not-found"
818 , EventEndElement "{stream:client}error"
819 , EventEndElement "{stream:client}presence"
820 ]
821
822presenceSubscribed from = return
823 [ EventBeginElement "{stream:client}presence"
824 [ attr "from" from
825 , attr "type" "subscribed"
826 ]
827 , EventEndElement "{stream:client}presence"
828 ]
829
830clientRequestsSubscription session cmdChan stanza = do
831 liftIO $ do
832 debugStr $ "CLIENT PRESENCE SUBSCRIBE " ++ show stanza
833 withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str0 -> do
834 let to_str = S.takeWhile (/='/') to_str0
835 from = lookupAttrib "from" (tagAttrs stanza)
836 iqid = lookupAttrib "id" (tagAttrs stanza)
837 let handleError e | isDoesNotExistError e = do
838 debugStr $ "remote-server-not-found"
839 r <- presenceErrorRemoteNotFound iqid from to_str
840 atomically $ writeTChan cmdChan (Send r)
841 handleError e = do
842 debugStr $ "ERROR: "++ show e
843 handleIO handleError $ do
844 let to_str' = textToByteString to_str
845 to_jid <- fmap bare $ parseHostNameJID to_str'
846 if (is_remote . peer) to_jid
847 then do
848 addSolicited session to_str' to_jid
849 debugStr $ "added to solicited: " ++ show to_jid
850 else do
851 -- addLocalSubscriber session to_str
852 -- self <- getJID session
853 r <- presenceSubscribed to_str -- self
854 atomically $ writeTChan cmdChan (Send r)
855 return ()
856
857
858stanzaFromTo ::
859 JabberPeerSession session =>
860 session -> Event -> IO (Maybe (JID, JID))
861stanzaFromTo session stanza =
862 let lookup key = fmap textToByteString (lookupAttrib key (tagAttrs stanza))
863 parse jidstr = handleIO_ (return Nothing) (fmap Just $ parseAddressJID jidstr)
864 in case liftM2 (,) (lookup "from") (lookup "to") of
865 Nothing -> return Nothing
866 Just (from,to) -> do
867 mfrom <- parse from
868 mto <- parse to
869 case liftM2 (,) mfrom mto of
870 Nothing -> return Nothing
871 Just (from,to) -> do
872 let fromjid = JID (name from) (peerAddress session) Nothing
873 return $ Just (fromjid,to)
874
875peerRequestsSubsription session stanza = do
876 liftIO $ debugStr $ "PEER PRESENCE SUBSCRIBE " ++ show stanza
877
878 whenJust (liftIO . handleIO (\e -> debugStr ("peerRequestsSubsription: "++show e) >> return Nothing)
879 $ stanzaFromTo session stanza) $ \(fromjid,tojid) -> do
880 withJust (name tojid) $ \user -> do
881
882 subs <- liftIO $ do
883 subs <- getSubscribers (peerSessionFactory session) user
884 msubs <- flip mapM subs $ \str -> do
885 handleIO_ (return Nothing)
886 (fmap Just $ parseHostNameJID str)
887 return (catMaybes msubs)
888 if elem fromjid subs
889 then do
890 liftIO . debugL $ bshow fromjid <++> " already subscribed to " <++> user
891 -- if already subscribed, reply
892 liftIO $ do
893 sendPeerMessage session (Approval tojid fromjid)
894 ps <- userStatus session user
895 -- todo: consider making this a directed presence
896 mapM_ (sendPeerMessage session . OutBoundPresence) ps
897 else
898 liftIO $ processRequest session user fromjid
899
900clientApprovesSubscription session stanza = do
901 liftIO $ debugStr $ "CLIENT APPROVES SUBSCRIPTION"
902 withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do
903 liftIO $ approveSubscriber session (textToByteString to_str)
904
905clientRejectsSubscription session stanza = do
906 liftIO $ debugStr $ "CLIENT REJECTS SUBSCRIPTION"
907 withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do
908 liftIO $ rejectSubscriber session (textToByteString to_str)
909
910peerApprovesSubscription session stanza = do
911 liftIO $ debugStr $ "PEER APPROVES SUBSCRIPTION"
912 whenJust (liftIO . handleIO (\e -> debugStr ("peerApprovesSubscription: "++show e) >> return Nothing)
913 $ stanzaFromTo session stanza) $ \(fromjid,tojid) -> do
914 withJust (name tojid) $ \user -> do
915 liftIO $ processApproval session user fromjid
916
917peerRejectsSubscription session stanza = do
918 liftIO $ debugStr $ "PEER REJECTS SUBSCRIPTION"
919 whenJust (liftIO . handleIO (\e -> debugStr ("peerRejectsSubscription: "++show e) >> return Nothing)
920 $ stanzaFromTo session stanza) $ \(fromjid,tojid) -> do
921 withJust (name tojid) $ \user -> do
922 liftIO $ processRejection session user fromjid
923
924handlePeerIQGet :: (JabberPeerSession session, MonadIO m) =>
925 session -> XML.Event -> NestingXML o m ()
926handlePeerIQGet session tag = do
927 -- TODO: Pings should not require an id field.
928 withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do
929 whenJust nextElement $ \child -> do
930 let unhandledGet req = do
931 liftIO $ debugStr ("iq-peer-get: "++show (stanza_id,child))
932 liftIO $
933 sendPeerMessage session (Unsupported (JID Nothing LocalHost Nothing)
934 (JID Nothing (peerAddress session) Nothing)
935 (Just (ContentText stanza_id))
936 req)
937 -- Client equiv: liftIO . atomically . writeTChan cmdChan . Send $ iq_service_unavailable host stanza_id Nothing req
938 case tagName child of
939 -- "{http://jabber.org/protocol/disco#items}query" -> liftIO $ debugStr "iq-get-query-items"
940 "{urn:xmpp:ping}ping" -> liftIO $ do
941 sendPeerMessage session (Pong (JID Nothing LocalHost Nothing)
942 (JID Nothing (peerAddress session) Nothing)
943 (Just (ContentText stanza_id)))
944 -- Client equiv: atomically . writeTChan cmdChan . Send $ pong
945 return ()
946
947 req -> unhandledGet req
948
949fromPeer :: (MonadThrow m,MonadIO m, JabberPeerSession session) =>
950 RestrictedSocket -> session -> TVar Bool -> Sink XML.Event m ()
951fromPeer sock session didClose = doNestingXML $ do
952 let log = liftIO . debugL . ("(P) " <++>)
953 withXML $ \begindoc -> do
954 when (begindoc==EventBeginDocument) $ do
955 log "begin-doc"
956 withXML $ \xml -> do
957 withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
958 log $ "stream atributes: " <++> bshow stream_attrs
959
960 let doTimeout = Thunk $ do
961 atomically $ writeTVar didClose True
962 closePeerSession session
963
964 fix $ \loop -> do
965 log "waiting for stanza."
966 whenJust nextElement $ \stanza -> do
967 stanza_lvl <- nesting
968
969 liftIO $ sendPeerMessage session (ActivityBump doTimeout) -- reset ping timer
970
971 let unhandledStanza = do
972 xs <- gatherElement stanza Seq.empty
973 prettyPrint "P: " (toList xs)
974 case () of
975 _ | stanza `isServerIQOf` iqTypeGet -> handlePeerIQGet session stanza
976 _ | stanza `isPresenceOf` presenceTypeOnline
977 -> handlePeerPresence session stanza True
978 _ | stanza `isPresenceOf` presenceTypeOffline
979 -> handlePeerPresence session stanza False
980 _ | stanza `isPresenceOf` presenceTypeProbe
981 -> handlePresenceProbe session stanza
982 _ | stanza `isPresenceOf` presenceTypeSubscribe
983 -> peerRequestsSubsription session stanza
984 _ | stanza `isPresenceOf` presenceTypeSubscribed
985 -> peerApprovesSubscription session stanza
986 _ | stanza `isPresenceOf` presenceTypeUnsubscribed
987 -> peerRejectsSubscription session stanza
988 _ | isMessageStanza stanza
989 -> handlePeerMessage session stanza
990 _ -> unhandledStanza
991
992 awaitCloser stanza_lvl
993 loop
994
995 log $ "end of stream"
996 withXML $ \xml -> do
997 log $ "end-of-document: " <++> bshow xml
998
999
1000
1001
1002newServerConnections = newTVar Map.empty
1003
1004data CachedMessages = CachedMessages
1005 { presences :: Map JID JabberShow
1006 , probes :: Map JID (Set (Bool,JID)) -- False means solicitation rather than probe
1007 , approvals :: Map JID (Set (Bool,JID) ) -- False means rejection rather than approval
1008 }
1009
1010instance CommandCache CachedMessages where
1011 type CacheableCommand CachedMessages = OutBoundMessage
1012 emptyCache = CachedMessages Map.empty Map.empty Map.empty
1013
1014 updateCache (OutBoundPresence (Presence jid Offline)) cache =
1015 cache { presences=Map.delete jid . presences $ cache }
1016 updateCache (OutBoundPresence p@(Presence jid st)) cache =
1017 cache { presences=Map.insert jid st . presences $ cache }
1018 updateCache (PresenceProbe from to) cache =
1019 cache { probes = mmInsert (True,from) to $ probes cache }
1020 updateCache (Solicitation from to) cache =
1021 cache { probes= mmInsert (False,from) to $ probes cache }
1022 updateCache (Approval from to) cache =
1023 cache { approvals= mmInsert (True,from) to $ approvals cache }
1024 updateCache (Rejection from to) cache =
1025 cache { approvals= mmInsert (False,from) to $ approvals cache }
1026 updateCache (OutBoundMessage msg) cache = cache -- TODO: cache chat?
1027 updateCache (Pong _ _ _) cache = trace "(DISCARDING Pong)" cache -- pings are not cached
1028 updateCache (Unsupported _ _ _ _) cache = cache -- error messages are not cached
1029 updateCache (ActivityBump sock) cache = cache
1030
1031instance ThreadChannelCommand OutBoundMessage where
1032 isQuitCommand Disconnect = True
1033 isQuitCommand _ = False
1034
1035mmInsert val key mm = Map.alter f key mm
1036 where
1037 f Nothing = Just $ Set.singleton val
1038 f (Just set) = Just $ Set.insert val set
1039
1040
1041greetPeer =
1042 [ EventBeginDocument
1043 , EventBeginElement (streamP "stream")
1044 [ attr "xmlns" "jabber:server"
1045 , attr "version" "1.0"
1046 ]
1047 ]
1048
1049goodbyePeer =
1050 [ EventEndElement (streamP "stream")
1051 , EventEndDocument
1052 ]
1053
1054peerJidTextLocal sock jid = do
1055 addr <- getSocketName sock
1056 return . toStrict . L.decodeUtf8
1057 $ name jid <$++> "@"
1058 <?++> showPeer (RemotePeer addr)
1059 <++?> "/" <++$> resource jid
1060
1061peerJidTextRemote sock jid = do
1062 addr <- getPeerName sock
1063 return . toStrict . L.decodeUtf8
1064 $ name jid <$++> "@"
1065 <?++> showPeer (RemotePeer addr)
1066 <++?> "/" <++$> resource jid
1067
1068presenceStanza sock fromjid tojid typ = do
1069 from <- peerJidTextLocal sock fromjid
1070 let to = toStrict . L.decodeUtf8
1071 $ name tojid <$++> "@"
1072 <?++> showPeer (peer tojid)
1073 return
1074 [ EventBeginElement "{jabber:server}presence"
1075 [ attr "from" from
1076 , attr "to" to
1077 , attr "type" typ
1078 ]
1079 , EventEndElement "{jabber:server}presence"
1080 ]
1081
1082
1083toPeer
1084 :: SocketLike sock =>
1085 sock
1086 -> CachedMessages
1087 -> TChan OutBoundMessage
1088 -> (Maybe OutBoundMessage -> IO ())
1089 -> ConduitM i [Event] IO ()
1090toPeer sock cache chan fail = do
1091 let -- log = liftIO . debugL . ("(>P) " <++>)
1092 send xs = yield xs >> prettyPrint ">P: " xs -- >> return (3::Int)
1093 checkConnection cmd = do
1094 liftIO $ catchIO (getPeerName sock >> return ())
1095 (\_ -> fail . Just $ cmd)
1096 sendOrFail getXML cmd = do
1097 checkConnection cmd
1098 r <- liftIO $ getXML
1099 -- handleIO (\e -> debugStr ("ERROR: "++show e) >> return []) getXML
1100 yieldOr r (fail . Just $ cmd)
1101 prettyPrint ">P: " r
1102 sendPresence presence =
1103 sendOrFail (xmlifyPresenceForPeer sock presence)
1104 (OutBoundPresence presence)
1105 sendProbe from to =
1106 sendOrFail (presenceStanza sock from to "probe")
1107 (PresenceProbe from to)
1108 sendSolicitation from to =
1109 sendOrFail (presenceStanza sock from to "subscribe")
1110 (Solicitation from to)
1111 sendApproval approve from to =
1112 sendOrFail (presenceStanza sock from to
1113 (if approve then "subscribed" else "unsubscribed"))
1114 (if approve then Approval from to
1115 else Rejection from to)
1116 sendMessage msg =
1117 sendOrFail (xmlifyMessageForPeer sock msg)
1118 (OutBoundMessage msg)
1119
1120 sendPong from to mid = do
1121 liftIO . debugL $ "SEND PONG"
1122 sendOrFail (xmlifyPong sock from to mid)
1123 (Pong from to mid)
1124 where
1125 xmlifyPong sock from to mid = do
1126 fromjid <- peerJidTextLocal sock to
1127 tojid <- peerJidTextRemote sock to
1128 return $ [ EventBeginElement "{jabber:server}iq"
1129 $ (case mid of
1130 Just c -> (("id",[c]):)
1131 _ -> id )
1132 [ attr "type" "result"
1133 , attr "to" tojid
1134 , attr "from" fromjid
1135 ]
1136 , EventEndElement "{jabber:server}iq"
1137 ]
1138 sendUnsupported from to mid tag =
1139 sendOrFail (xmlifyUnsupported sock from to mid tag)
1140 (Unsupported from to mid tag)
1141 where
1142 xmlifyUnsupported sock from to mid req = do
1143 fromjid <- peerJidTextLocal sock to
1144 tojid <- peerJidTextRemote sock to
1145 return $
1146 [ EventBeginElement "{jabber:server}iq"
1147 $ (case mid of
1148 Just c -> (("id",[c]):)
1149 _ -> id )
1150 [("type",[ContentText "error"])
1151 , attr "to" tojid
1152 , attr "from" fromjid
1153 ]
1154 , EventBeginElement req []
1155 , EventEndElement req
1156 , EventBeginElement "{jabber:server}error" [("type",[ContentText "cancel"])]
1157 , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable" []
1158 , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable"
1159 , EventEndElement "{jabber:server}error"
1160 , EventEndElement "{jabber:server}iq"
1161 ]
1162
1163
1164 send greetPeer
1165 forM_ (Map.assocs . approvals $ cache) $ \(to,froms) -> do
1166 forM_ (Set.toList froms) $ \(approve,from) -> do
1167 liftIO $ debugL "sending cached approval/rejection..."
1168 sendApproval approve from to
1169 forM_ (Map.assocs . presences $ cache) $ \(jid,st) -> do
1170 sendPresence (Presence jid st)
1171 forM_ (Map.assocs . probes $ cache) $ \(to,froms) -> do
1172 forM_ (Set.toList froms) $ \(got,from) -> do
1173 if got
1174 then do
1175 liftIO $ debugL "sending cached probe..."
1176 sendProbe from to
1177 else do
1178 liftIO $ debugL "sending cached solicitation..."
1179 sendSolicitation from to
1180
1181
1182 let five_sec = 5 * 1000000 :: Int
1183 pingref <- liftIO $ do
1184 ping_timer <- liftIO $ newDelay five_sec
1185 newTVarIO (ping_timer,0::Int)
1186
1187 sockref <- liftIO $ atomically newEmptyTMVar
1188 let bump fromsock = do
1189 remote <- liftIO $ catchIO (fmap Just $ getPeerName sock)
1190 (\_ -> return Nothing)
1191 debugL $ "PING BUMP" <++?> fmap (showPeer . RemotePeer) remote
1192 timer <- atomically $ do
1193 tryTakeTMVar sockref
1194 putTMVar sockref fromsock
1195 (timer,v) <- readTVar pingref
1196 writeTVar pingref (timer,0)
1197 return timer
1198 updateDelay timer five_sec
1199 waitPing = do
1200 (timer,v) <- readTVar pingref
1201 waitDelay timer
1202 return v
1203
1204 fix $ \loop -> do
1205 liftIO . debugStr $ "LOOP waiting..."
1206 event <- lift . atomically $ orElse (Left `fmap` readTChan chan)
1207 (Right `fmap` waitPing)
1208 liftIO . debugStr $ "LOOP event = " ++ show event
1209 let sendPing n = do
1210 case n of
1211 0 -> do
1212 ping <- liftIO makePing
1213 yield ping
1214 liftIO . debugL $ "SEND PING"
1215 prettyPrint ">P: " ping
1216 ping_timer <- liftIO $ newDelay five_sec
1217 liftIO . atomically $ writeTVar pingref (ping_timer,1)
1218 loop
1219 1 -> do
1220 remote <- liftIO $ getPeerName sock
1221 liftIO . debugL $ "PING TIMEOUT: " <++> showPeer (RemotePeer remote)
1222 fromsock <- liftIO $ atomically $ readTMVar sockref
1223 -- liftIO $ sClose fromsock
1224 liftIO $ runThunk fromsock
1225
1226 return () -- PING TIMEOUT (loop quits)
1227 x -> error ("What? "++show x)
1228 where makePing = do
1229 addr <- getSocketName sock
1230 remote <- getPeerName sock
1231 let from = toStrict . L.decodeUtf8 . showPeer $ RemotePeer addr
1232 to = toStrict . L.decodeUtf8 . showPeer $ RemotePeer remote
1233 mid = Just (ContentText "iduno")
1234 return $
1235 [ EventBeginElement "{jabber:server}iq"
1236 $ (case mid of
1237 Just c -> (("id",[c]):)
1238 _ -> id )
1239 [ ("type",[ContentText "get"])
1240 , attr "to" to
1241 , attr "from" from
1242 ]
1243 , EventBeginElement "{urn:xmpp:ping}ping" []
1244 , EventEndElement "{urn:xmpp:ping}ping"
1245 , EventEndElement "{jabber:server}iq" ]
1246 chanEvent event = do
1247 case event of
1248 OutBoundPresence p -> sendPresence p
1249 PresenceProbe from to -> do
1250 liftIO $ debugL "sending live probe..."
1251 sendProbe from to
1252 Solicitation from to -> do
1253 liftIO $ debugL "sending live solicitation..."
1254 sendSolicitation from to
1255 Approval from to -> do
1256 liftIO . debugL $ "sending approval "<++>bshow (from,to)
1257 sendApproval True from to
1258 Rejection from to -> do
1259 liftIO . debugL $ "sending rejection "<++>bshow (from,to)
1260 sendApproval False from to
1261 OutBoundMessage msg -> sendMessage msg
1262 Pong from to mid -> do
1263 liftIO . debugL $ "sending pong "<++>bshow (from,to)
1264 sendPong from to mid
1265 Unsupported from to mid tag -> sendUnsupported from to mid tag
1266 Disconnect -> return ()
1267 ActivityBump fromsock -> liftIO (bump fromsock)
1268 when (not . isQuitCommand $ event) loop
1269 either chanEvent sendPing event
1270 return ()
1271 -- send goodbyePeer -- TODO: why does this cause an exception?
1272 -- Text/XML/Stream/Render.hs:169:5-15:
1273 -- Irrefutable pattern failed for pattern (sl : s')
1274
1275
1276
1277
1278seekRemotePeers :: JabberPeerSession config =>
1279 XMPPPeerClass config -> TChan Presence -> OutgoingConnections CachedMessages -> IO b0
1280seekRemotePeers config chan server_connections = do
1281 fix $ \loop -> do
1282 event <- atomically $ readTChan chan
1283 case event of
1284 p@(Presence jid stat) | not (is_remote (peer jid)) -> do
1285 -- debugL $ "seekRemotePeers: " <++> L.show jid <++> " " <++> bshow stat
1286 runMaybeT $ do
1287 u <- MaybeT . return $ name jid
1288 subscribers <- liftIO $ do
1289 subs <- getSubscribers config u
1290 mapM parseHostNameJID subs
1291 -- liftIO . debugL $ "subscribers: " <++> bshow subscribers
1292 let peers = Set.map peer (Set.fromList subscribers)
1293 forM_ (Set.toList peers) $ \peer -> do
1294 when (is_remote peer) $
1295 liftIO $ sendMessage server_connections (OutBoundPresence p) peer
1296 _ -> return (Just ())
1297 loop
1298
1299xmlifyPresenceForPeer sock (Presence jid stat) = do
1300 addr <- getSocketName sock
1301 let n = name jid
1302 rsc = resource jid
1303 jidstr = toStrict . L.decodeUtf8
1304 $ n <$++> "@" <?++> showPeer (RemotePeer addr) <++?> "/" <++$> rsc
1305 return $
1306 [ EventBeginElement "{jabber:server}presence"
1307 (attr "from" jidstr:typ stat) ]
1308 ++ ( shw stat >>= jabberShow ) ++
1309 [ EventEndElement "{jabber:server}presence" ]
1310 where
1311 typ Offline = [attr "type" "unavailable"]
1312 typ _ = []
1313
1314 shw ExtendedAway = ["xa"]
1315 shw Chatty = ["chat"]
1316 shw Away = ["away"]
1317 shw DoNotDisturb = ["dnd"]
1318 shw _ = []
1319 jabberShow stat =
1320 [ EventBeginElement "{jabber:server}show" []
1321 , EventContent (ContentText stat)
1322 , EventEndElement "{jabber:server}show" ]
1323
1324xmlifyMessageForClient msg = do
1325 let tojid = msgTo msg
1326 fromjid = msgFrom msg
1327 tonames <- getNamesForPeer (peer tojid)
1328 fromnames <- getNamesForPeer (peer fromjid)
1329 let mk_str ns jid = toStrict . L.decodeUtf8 $ name jid <$++> "@" <?++> L.fromChunks [head ns] <++?> "/" <++$> resource jid
1330 to_str = mk_str tonames tojid
1331 from_str = mk_str fromnames fromjid
1332 tags = ( "{jabber:client}subject"
1333 , "{jabber:client}body"
1334 )
1335 return $
1336 [ EventBeginElement "{jabber:client}message"
1337 [ attr "from" from_str
1338 , attr "to" to_str
1339 ]
1340 ]
1341 ++ xmlifyMsgElements tags (msgLangMap msg) ++
1342 [ EventEndElement "{jabber:client}message" ]
1343
1344
1345xmlifyMessageForPeer sock msg = do
1346 addr <- getSocketName sock
1347 remote <- getPeerName sock
1348 let n = name (msgFrom msg)
1349 rsc = resource (msgFrom msg)
1350 jidstr = toStrict . L.decodeUtf8
1351 $ n <$++> "@" <?++> showPeer (RemotePeer addr) <++?> "/" <++$> rsc
1352 tostr = toStrict . L.decodeUtf8
1353 $ name (msgTo msg) <$++> "@"
1354 <?++> showPeer (RemotePeer remote) <++?> "/"
1355 <++$> resource (msgTo msg)
1356 tags = ( "{jabber:server}subject"
1357 , "{jabber:server}body"
1358 )
1359 return $
1360 [ EventBeginElement "{jabber:server}message"
1361 [ attr "from" jidstr
1362 , attr "to" tostr
1363 ]
1364 ]
1365 ++ xmlifyMsgElements tags (msgLangMap msg) ++
1366 [ EventEndElement "{jabber:server}message" ]
1367
1368xmlifyMsgElements tags langmap = concatMap (uncurry (langElements tags)) . Map.toList $ langmap
1369
1370langElements (subjecttag,bodytag) lang msg =
1371 ( maybeToList (msgSubject msg)
1372 >>= wrap subjecttag )
1373 ++ ( maybeToList (msgBody msg)
1374 >>= wrap bodytag )
1375 ++ ( Set.toList (msgElements msg)
1376 >>= wrapTriple )
1377 where
1378 wrap name content =
1379 [ EventBeginElement name
1380 ( if lang/="" then [attr "xml:lang" lang]
1381 else [] )
1382 , EventContent (ContentText content)
1383 , EventEndElement name
1384 ]
1385 wrapTriple (name,attrs,content) =
1386 [ EventBeginElement name attrs -- Note: we assume lang specified in attrs
1387 , EventContent (ContentText content)
1388 , EventEndElement name
1389 ]
1390
1391
1392handleClientMessage session stanza = do
1393 let log = liftIO . debugL . ("(C) " <++>)
1394 log $ "handleClientMessage "<++>bshow stanza
1395 from <- liftIO $ getJID session
1396 withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do
1397 log $ " to = "<++>bshow to_str
1398 tojid <- liftIO $ parseHostNameJID (textToByteString to_str)
1399 msg <- parseMessage ("{jabber:client}body"
1400 ,"{jabber:client}subject"
1401 ,"{jabber:client}thread"
1402 )
1403 log
1404 from
1405 tojid
1406 stanza
1407 liftIO $ sendChat session msg
1408
1409{-
1410unhandled-C: <message
1411unhandled-C: type="chat"
1412unhandled-C: id="purplea0a7fd24"
1413unhandled-C: to="user@vm2"
1414unhandled-C: xmlns="jabber:client">
1415unhandled-C: <active xmlns="http://jabber.org/protocol/chatstates"/>
1416unhandled-C: <body>
1417unhandled-C: hello dude
1418unhandled-C: </body>
1419unhandled-C: </message>
1420-}
1421parseMessage (bodytag,subjecttag,threadtag) log from tojid stanza = do
1422 let emptyMsg = LangSpecificMessage { msgBody=Nothing, msgSubject=Nothing, msgElements=Set.empty }
1423 parseChildren (th,cmap) = do
1424 child <- nextElement
1425 lvl <- nesting
1426 xmllang <- xmlLang
1427 let lang = maybe "" id xmllang
1428 let c = maybe emptyMsg id (Map.lookup lang cmap)
1429 log $ " child: "<++> bshow child
1430 case child of
1431 Just tag | tagName tag==bodytag
1432 -> do
1433 txt <- lift content
1434 awaitCloser lvl
1435 parseChildren (th,Map.insert lang (c { msgBody=Just txt }) cmap)
1436 Just tag | tagName tag==subjecttag
1437 -> do
1438 txt <- lift content
1439 awaitCloser lvl
1440 parseChildren (th,Map.insert lang (c { msgSubject=Just txt }) cmap)
1441 Just tag | tagName tag==threadtag
1442 -> do
1443 txt <- lift content
1444 awaitCloser lvl
1445 parseChildren (th {msgThreadContent=txt},cmap)
1446 Just tag -> do
1447 let nm = tagName tag
1448 attrs = tagAttrs tag
1449 elems = msgElements c
1450 txt <- lift content
1451 awaitCloser lvl
1452 parseChildren (th,Map.insert lang (c {msgElements=Set.insert (nm,attrs,txt) elems}) cmap)
1453 Nothing -> return (th,cmap)
1454 (th,langmap) <- parseChildren ( MessageThread {msgThreadParent=Nothing, msgThreadContent=""}
1455 , Map.empty )
1456 return Message {
1457 msgTo = tojid,
1458 msgFrom = from,
1459 msgLangMap = langmap,
1460 msgThread = if msgThreadContent th/="" then Just th else Nothing
1461 }
diff --git a/simplechat.hs b/simplechat.hs
deleted file mode 100644
index 84b33e13..00000000
--- a/simplechat.hs
+++ /dev/null
@@ -1,66 +0,0 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3
4import Data.HList.TypeEqGeneric1()
5import Data.HList.TypeCastGeneric1()
6import ByteStringOperators
7
8import Data.ByteString.Lazy.Char8 as L
9 ( ByteString
10 , hPutStrLn
11 , init )
12import System.IO
13 ( Handle
14 )
15import Control.Concurrent (forkIO)
16import Control.Concurrent.Chan
17import Data.HList
18
19import Connection.Tcp
20
21
22startCon socket st = do
23 let chan = hOccursFst st
24 nr = hOccursFst st :: ConnId
25 hdl = hOccursFst st :: Handle
26 quit = writeChan chan (nr,Nothing)
27 broadcast msg = writeChan chan (nr,Just msg)
28 chan' <- dupChan chan
29 reader <- forkIO $ fix $ \loop -> do
30 (nr', line) <- readChan chan'
31 case ( line, nr==nr') of
32 ( Nothing , True ) -> Prelude.putStrLn "quit-client."
33 ( Just msg , False ) -> hPutStrLn hdl msg >> loop
34 _ -> loop
35
36 hPutStrLn hdl "Hi, what's your name?"
37 line <- getPacket hdl
38 let name = L.init line
39 Prelude.putStrLn $ "readFst: " ++ show line
40 hPutStrLn hdl ("Welcome, " <++> name <++> "!")
41 broadcast ("--> " <++> name <++> " entered.")
42
43 return (name .*. ConnectionFinalizer quit .*. st)
44
45doCon st bs cont = do
46 let hdl = hOccursFst st :: Handle
47 nr = hOccursFst st :: ConnId
48 chan = hOccursFst st
49 broadcast msg = writeChan chan (nr,Just msg)
50 name = hHead st
51 Prelude.putStrLn $ "read: " ++ show bs
52 case bs of
53 "quit\n" -> hPutStrLn hdl "Bye!"
54 _ -> do
55 broadcast (name <++> ": " <++> L.init bs)
56 cont ()
57
58
59main = do
60 (chan :: Chan (ConnId, Maybe ByteString)) <- newChan
61 doServer (5222 .*. chan .*. HNil)
62 doCon
63 startCon
64 getLine
65
66
diff --git a/test-server.hs b/test-server.hs
deleted file mode 100644
index b47a4bcb..00000000
--- a/test-server.hs
+++ /dev/null
@@ -1,541 +0,0 @@
1{-# LANGUAGE OverloadedStrings #-}
2module Main where
3
4import Debug.Trace
5import Control.Exception (evaluate) -- ,handle,SomeException(..),bracketOnError)
6import Control.Exception ({-evaluate,-}handle,SomeException(..),bracketOnError,ErrorCall(..))
7import System.IO.Error (ioeGetErrorType)
8import Connection.Tcp
9import Control.Monad
10import Control.Monad.Trans.Resource
11import Control.Monad.IO.Class
12import Control.Monad.STM
13import Control.Monad.Fix
14import Control.Concurrent (threadDelay,forkOS,forkIO)
15import Control.Concurrent.STM.TMVar
16import Control.Concurrent.STM.TChan
17import Network.Socket
18import System.Process.Internals
19import System.Process
20import Data.Char
21import System.IO hiding (isEOF)
22import System.Posix.Signals hiding (Ignore)
23
24
25makeGots sv = do
26 let chan = serverEvent sv
27 gotchan <- atomically $ dupTChan chan
28 forkIO $ do
29 fix $ \loop -> do
30 (k,e) <- atomically $ readTChan chan
31 case e of
32 Connection pingflag read write -> todo
33 EOF -> todo
34 loop
35 return gotchan
36
37isConnection (_,Connection {}) = True
38isConnection _ = False
39isPending want (_,HalfConnection got) | got/=want = True
40isPending _ _ = False
41isRead str (_,Got r) | r==str = True
42isRead _ _ = False
43isEOF (_,EOF) = True
44isEOF _ = False
45
46-- localhost port = SockAddrInet port 127
47localhost port = SockAddrInet6 port 0 (0,0,0,1) 0
48
49withServer f = runResourceT $ do
50 sv <- server
51 result <- liftIO $ f sv
52 release (serverReleaseKey sv)
53 return result
54
55writeToPort port str = do
56 s <- readProcess "/usr/bin/socat" ["-","TCP6:localhost:"++show port] str
57 reverse s `seq` return ()
58
59connectToPort port = do
60 (inp,outp,err,p) <-
61 runInteractiveProcess "/usr/bin/socat"
62 ["-","TCP6:localhost:"++show port]
63 Nothing
64 Nothing
65 hSetBuffering inp NoBuffering
66 hSetBuffering outp NoBuffering
67 hSetBuffering err NoBuffering
68 forkOS $ do putStrLn $ "SOCAT-ConnectToPort:"++show (port,(inp,outp,err))
69 hGetContents err >>= putStrLn
70 return (inp,outp,err,p)
71
72listenOnPort port = do
73 putStrLn $ "socat - TCP6-LISTEN:"++show port++",fork"
74 (inp,outp,err,p) <-
75 runInteractiveProcess "/usr/bin/socat"
76 ["-","TCP6-LISTEN:"++show port++",fork"]
77 Nothing
78 Nothing
79 hSetBuffering inp NoBuffering
80 hSetBuffering outp NoBuffering
81 hSetBuffering err NoBuffering
82 forkOS $ do { putStrLn "SOCAT-listenOnPort:"; hGetContents err >>= putStrLn }
83 -- forkOS $ do { putStrLn "SOCAT-listenOnPort:"; hGetContents outp >>= putStrLn }
84 return (inp,outp,err,p)
85
86stopListening (inp,outp,err,p) = do
87 {-
88 forkOS $ do
89 o <- hGetContents outp
90 void $ evaluate (length o)
91 forkOS $ do
92 e <- hGetContents err
93 void $ evaluate (length e)
94 threadDelay 1000000
95 hClose inp
96 threadDelay 1000000
97 forkOS $ do
98 threadDelay 100000
99 mapM_ hClose [outp,err]
100 -}
101 withProcessHandle p $ \p -> do
102 case p of
103 OpenHandle pid -> trace ("interrupting: "++show pid)
104 $ signalProcess sigINT pid
105 _ -> return ()
106 return (p,())
107 {-
108 threadDelay 500000
109 terminateProcess p
110 -}
111 e <- waitForProcess p
112 putStrLn $ "SOCAT-LISTEN exit: "++show e
113
114
115
116chanContents ch = do
117 x <- atomically $ do
118 bempty <- isEmptyTChan ch
119 if bempty
120 then return Nothing
121 else fmap Just $ readTChan ch
122 maybe (return [])
123 (\x -> do
124 xs <- chanContents ch
125 return (x:xs))
126 x
127
128control sv = atomically . putTMVar (serverCommand sv)
129
130testListen = do
131 let send con str = do hPutStr con str
132 hFlush con
133 threadDelay 100000
134 events <- withServer $ \sv -> do
135 let _ = sv :: Server SockAddr
136 events = serverEvent sv
137 params :: ConnectionParameters SockAddr
138 params = connectionDefaults (return . snd)
139 control sv (Listen 39242 params)
140 h1@(con1,con2,_,_)<- connectToPort 39242
141 send con1 "Joe was here"
142 control sv (Ignore 39242)
143 threadDelay 500000
144 stopListening h1
145 threadDelay 500000
146 return events
147 e <- chanContents events
148 putStrLn $ "testListen: "++ show e
149 return $
150 and [ length e == 3
151 , isConnection $ e !! 0
152 , isRead "Joe was here" $ e !! 1
153 , isEOF $ e !! 2
154 ]
155
156
157testReplace = do
158 let send con str = do hPutStrLn con str
159 hFlush con
160 threadDelay 100000
161 events <- withServer $ \sv -> do
162 let _ = sv :: Server ()
163 events = serverEvent sv
164 params = connectionDefaults (const $ return ())
165 control sv (Listen 39242 params)
166 h1@(con1,_,_,_)<- connectToPort 39242
167 send con1 "Joe was here"
168 h2@(con2,_,_,_) <- connectToPort 39242
169 send con2 "Jim also"
170 send con1 "What?"
171 threadDelay 500000
172 stopListening h1 -- misnomer
173 stopListening h2 -- misnomer
174 threadDelay 500000
175 return events
176 e <- chanContents events
177 -- [([::ffff:127.0.0.1]:43722,Connection)
178 -- ,([::ffff:127.0.0.1]:43722,Got "Joe was here\n")
179 -- ,([::ffff:127.0.0.1]:43723,Connection)
180 -- ,([::ffff:127.0.0.1]:43723,Got "Jim also\n")
181 -- ,([::ffff:127.0.0.1]:43722,Got "What?\n")
182 -- ,([::ffff:127.0.0.1,EOF)]:43722
183 -- ,([::ffff:127.0.0.1,EOF)]:43723]
184 -- putStrLn $ show e
185 putStrLn $ "testReplace: "++ show e
186 return $ case e of
187 [(_,Connection {})
188 ,(_,Got "Joe was here\n")
189 ,(_,EOF)
190 ,(_,Connection {})
191 ,(_,Got "Jim also\n")
192 ,(_,EOF)]
193 -> True
194 _ -> False
195
196testPendingOut = do
197 let send con str = do hPutStr con str
198 hFlush con
199 threadDelay 100000
200 events <- withServer $ \sv -> do
201 let _ = sv :: Server SockAddr
202 events = serverEvent sv
203 params :: ConnectionParameters SockAddr
204 params = (connectionDefaults (return . snd))
205 { duplex = False }
206 control sv (Listen 39249 params)
207 h1@(con1,con2,_,_)<- connectToPort 39249
208 send con1 "Joe was here"
209 stopListening h1
210 threadDelay 500000
211 return events
212
213 e <- chanContents events
214 putStrLn $ "testPendingOut: "++ show e
215 return $
216 and [ length e == 3
217 , isPending Out $ e !! 0
218 , isRead "Joe was here" $ e !! 1
219 , isEOF $ e !! 2
220 ]
221
222testReplacePendingOut = do
223 let send con str = do hPutStrLn con str
224 hFlush con
225 threadDelay 100000
226 events <- withServer $ \sv -> do
227 let _ = sv :: Server ()
228 events = serverEvent sv
229 params = (connectionDefaults (const $ return ()))
230 { duplex = False }
231 control sv (Ignore 39242)
232 control sv (Listen 39242 params)
233 threadDelay 500000
234 h1@(con1,_,_,_) <- connectToPort 39242
235 send con1 "Joe was here"
236 h2@(con2,_,_,_) <- connectToPort 39242
237 send con2 "Jim also"
238 send con1 "What?"
239 threadDelay 500000
240 control sv (Ignore 39242)
241 threadDelay 500000
242 stopListening h1 -- misnomer
243 stopListening h2 -- misnomer
244 threadDelay 500000
245 return events
246 e <- chanContents events
247 putStrLn $ "testReplacePendingOut: "++ show e
248 return $ case e of
249 [ (_,HalfConnection In)
250 ,(_,Got "Joe was here\n")
251 ,(_,EOF)
252 ,(_,HalfConnection In)
253 ,(_,Got "Jim also\n")
254 ,(_,EOF)]
255 -> True
256 _ -> False
257
258testReplacePendingIn = do
259 let send con str = do hPutStrLn con str
260 hFlush con
261 threadDelay 100000
262 (events,socat) <- withServer $ \sv -> do
263 let _ = sv :: Server ()
264 events = serverEvent sv
265 params = (connectionDefaults (const $ return ()))
266 { duplex = False }
267 threadDelay 500000
268 socat <- listenOnPort 39242
269 threadDelay 500000
270 control sv (Connect (localhost 39242) params)
271 control sv (Connect (localhost 39242) params)
272 return (events,socat)
273 threadDelay 500000
274 stopListening socat
275 threadDelay 500000
276 e <- chanContents events
277 putStrLn $ "testReplacePendingIn: "++ show e
278 return $ e==[((),HalfConnection Out)
279 ,((),EOF)
280 ,((),HalfConnection Out)
281 ,((),EOF)]
282
283testPromotePendingOut = do
284 putStrLn "----------- testPromotePendingOut"
285 hFlush stdout
286 let send con str = do hPutStr con str
287 hFlush con
288 threadDelay 100000
289 (events,s,socat) <- withServer $ \sv -> do
290 let _ = sv :: Server ()
291 events = serverEvent sv
292 params = (connectionDefaults (const $ return ()))
293 { duplex = False }
294 control sv (Ignore 39244)
295 threadDelay 500000
296 control sv (Listen 39244 params)
297 socat <- listenOnPort 39243
298 h@(con1,con2,_,_) <- connectToPort 39244
299 putStrLn $ "connected to 39244, Sending Joe was here"
300 send con1 "Joe was here"
301 threadDelay 500000
302 putStrLn $ "Connecting to 39243"
303 control sv (Connect (localhost 39243) params)
304 threadDelay 500000
305 putStrLn $ "probably connected to 39243"
306 control sv (Send () "and jim")
307 putStrLn $ "connected to 39244, Sending Joe was here twice"
308 hFlush stdout
309 send con1 "Joe was here twice"
310 threadDelay 500000
311 s <- fmap (take 7) $ hGetContents ((\(_,x,_,_)->x) socat)
312 last s `seq` threadDelay 500000
313 stopListening h -- misnomer
314 threadDelay 50000
315 return (events,s,socat)
316 stopListening socat
317 threadDelay 500000
318 e <- chanContents events
319 putStrLn $ "testPromotePendingOut: "++ show (s,e)
320 -- testPromotePendingOut: ("and jim",[HalfConnection () In,((),Got "Joe was here"),((),Read () "Joe was here twice",((),EOF)]),Connection)
321 --
322 return . and $
323 [ s== "and jim"
324 , e== [ ((),HalfConnection In)
325 , ((),Got "Joe was here")
326 , ((),Connection {})
327 , ((),Got "Joe was here twice")
328 , ((),EOF) ]
329 ]
330
331testPromotePendingIn = do
332 putStrLn "----------- testPromotePendingIn"
333 hFlush stdout
334 let send con str = do handle (\e -> putStrLn . show $ ioeGetErrorType e) $ do
335 hPutStrLn con str
336 hFlush con
337 threadDelay 500000
338 (events,socat,s) <- withServer $ \sv -> do
339 let _ = sv :: Server ()
340 events = serverEvent sv
341 params = (connectionDefaults (const $ return ()))
342 { duplex = False }
343
344 -- Outgoing connection
345 socat <- listenOnPort 39248
346 threadDelay 500000
347 putStrLn $ "Connecting to 39248..."
348 control sv (Connect (localhost 39248) params)
349 threadDelay 1000000
350 putStrLn $ "...probably connected to 39248"
351 control sv (Send () "and jim")
352 threadDelay 1000000
353
354 s <- fmap (take 7) $ hGetContents ((\(_,x,_,_)->x) socat)
355 length s `seq` threadDelay 500000
356
357 control sv (Listen 39247 params)
358 threadDelay 500000
359 h@(con1,con2,_,_) <- connectToPort 39247
360 send con1 "howdy!"
361 h2@(con1',con2',_,_) <- connectToPort 39247
362 threadDelay 500000
363 send con1' "what?"
364 threadDelay 1000000
365 hClose con1
366 hClose con1'
367 threadDelay 1000000
368 stopListening socat
369 threadDelay 1000000
370
371 return (events,socat,s)
372 e <- chanContents events
373 putStrLn $ "testPromotePendingIn: "++ show (s,e)
374 -- testPromotePendingIn: ("and jim",[HalfConnection () Out,((),((),Got "howdy!\n"),((),EOF (),HalfConnection () In,Read () "what?\n",EOF (),EOF)]),Connection)
375 -- ("and jim",[HalfConnection () Out,((),((),Got "howdy!\n"),((),HalfConnection () In,Read () "what?\n",EOF (),EOF)]),Connection)
376 return . and $
377 [ s == "and jim"
378 , e == [ ((),HalfConnection Out)
379 ,((),Connection {})
380 ,((),Got "howdy!\n")
381 ,((),EOF)
382 ,((),HalfConnection In)
383 ,((),Got "what?\n")
384 ,((),EOF)]
385 ]
386
387testPing = do
388 putStrLn "----------- testPing"
389 let send con str = do handle (\e -> putStrLn . show $ ioeGetErrorType e) $ do
390 hPutStrLn con str
391 hFlush con
392 threadDelay 500000
393 events <- withServer $ \sv -> do
394 let _ = sv :: Server ()
395 events = serverEvent sv
396 params = (connectionDefaults (const $ return ()))
397 { pingInterval = 2000
398 , timeout = 1000 }
399 control sv (Listen 32957 params)
400 threadDelay 500000
401 socat@(h,_,_,_) <- connectToPort 32957
402
403 -- putStrLn $ "sending hey you!"
404 send h "hey you!"
405 -- putStrLn $ "delay"
406 threadDelay 3500000 -- ping timeout
407 -- putStrLn $ "sending what?"
408 send h "what?" -- lost due to timeout
409 -- putStrLn $ "delay-2"
410 threadDelay 500000
411 -- putStrLn $ "close h"
412 hClose h
413
414 threadDelay 500000
415 socat@(h,_,_,_) <- connectToPort 32957
416 send h "try 2: hey you!"
417 threadDelay 2500000 -- ping warning
418 send h "try 2: what?"
419 threadDelay 1000000 -- no warning or timeout
420 send h "try 2: yes."
421 stopListening socat
422 threadDelay 1000000
423 return events
424
425 e <- chanContents events
426 putStrLn $ "testPing: "++show e
427 -- testPing: [((),Connection <STM action> <IO action> <function>)
428{-
429,((),Got "hey you!\n")
430,((),RequiresPing)
431,((),RequiresPing)
432,((),Got "what?\n")
433,((),EOF)
434,((),Connection <STM action> <IO action> <function>)
435,((),Got "try 2: hey you!\n")
436,((),RequiresPing)
437,((),Got "try 2: what?\n")
438,((),Got "try 2: yes.\n")
439,((),EOF)]
440testPing: [((),Connection <STM action> <IO action> <function>)
441,((),Got "hey you!\n")
442,((),RequiresPing)
443,((),Got "what?\n")
444,((),RequiresPing)
445,((),EOF)
446,((),Connection <STM action> <IO action> <function>)
447,((),Got "try 2: hey you!\n")
448,((),RequiresPing)
449,((),Got "try 2: what?\n")
450,((),RequiresPing)]
451testPing: [((),Connection <STM action> <IO action> <function>)
452,((),Got "hey you!\n")
453,((),RequiresPing)
454,((),Got "what?\n")
455,((),RequiresPing)
456,((),EOF)
457,((),Connection <STM action> <IO action> <function>)
458,((),Got "try 2: hey you!\n")
459,((),RequiresPing)
460,((),Got "try 2: what?\n")
461,((),Got "try 2: yes.\n")
462,((),EOF)]
463
464-}
465
466 return $ e == [((),Connection {})
467 ,((),Got "hey you!\n")
468 ,((),RequiresPing)
469 ,((),EOF)
470 ,((),Connection {})
471 ,((),Got "try 2: hey you!\n")
472 ,((),RequiresPing)
473 ,((),Got "try 2: what?\n")
474 ,((),Got "try 2: yes.\n")
475 ,((),EOF)]
476
477testDisabledPing = do
478 let send con str = do hPutStrLn con str
479 hFlush con
480 threadDelay 500000
481 events <- withServer $ \sv -> do
482 let _ = sv :: Server ()
483 events = serverEvent sv
484 params = (connectionDefaults (const $ return ()))
485 { pingInterval = 0
486 , timeout = 0 }
487 control sv (Listen 32958 params)
488 threadDelay 500000
489 socat@(h,_,_,_) <- connectToPort 32958
490
491 send h "hey you!"
492 threadDelay 3500000 -- ping timeout
493 send h "what?" -- lost due to timeout
494 threadDelay 500000
495 hClose h
496
497 threadDelay 500000
498 socat@(h,_,_,_) <- connectToPort 32958
499 send h "try 2: hey you!"
500 threadDelay 2500000 -- ping warning
501 send h "try 2: what?"
502 threadDelay 1000000 -- no warning or timeout
503 send h "try 2: yes."
504 stopListening socat
505 threadDelay 5000000
506 return events
507
508 e <- chanContents events
509 putStrLn $ "testDisabledPing: "++show e
510 return $ e == [((),Connection {})
511 ,((),Got "hey you!\n")
512 ,((),Got "what?\n")
513 ,((),EOF)
514 ,((),Connection {})
515 ,((),Got "try 2: hey you!\n")
516 ,((),Got "try 2: what?\n")
517 ,((),Got "try 2: yes.\n")
518 ,((),EOF)]
519main = do
520 result1 <- testListen
521 result2 <- testReplace
522 result3 <- testPendingOut
523 result4 <- testReplacePendingOut
524 threadDelay 100000
525 result5 <- testReplacePendingIn
526 result6 <- testPromotePendingOut
527 result7 <- testPromotePendingIn
528 result8 <- testPing
529 result9 <- testDisabledPing
530 let passOrFail str True = putStrLn $ str ++ ": passed"
531 passOrFail str False = putStrLn $ str ++ ": failed"
532 passOrFail "testListen" result1
533 passOrFail "testReplace" result2
534 passOrFail "testPendingOut" result3
535 passOrFail "testReplacePendingOut" result4
536 passOrFail "testReplacePendingIn" result5
537 passOrFail "testPromotePendingOut" result6
538 passOrFail "testPromotePendingIn" result7
539 passOrFail "testPing" result8
540 passOrFail "testDisabledPing" result9
541 return ()
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 16:56:26 +0000