summaryrefslogtreecommitdiff
path: root/Presence/XMPPServer.hs
blob: f607989da3ee38b3dd0fdf607044ebb6cb7d6c91 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE TypeFamilies        #-}
-- {-# LANGUAGE GADTs               #-}
module XMPPServer 
    ( module XMPPServer
    , module XMPPTypes
    , quitListening 
    )  where

import Data.Char (isSpace)
import Data.HList.TypeEqGeneric1()
import Data.HList.TypeCastGeneric1()
import ByteStringOperators
import System.IO 
    ( IOMode(..)
    , BufferMode(..)
    , hSetBuffering
    )

import Server
import Data.ByteString.Lazy.Char8 as L 
    ( hPutStrLn
    , unlines
    , lines
    , uncons
    , takeWhile
    , concat
    , splitWith
    , drop
    , ByteString
    , pack
    , unpack )
import qualified Data.ByteString.Lazy.Char8 as L 
    ( putStrLn )
import System.IO 
    ( Handle
    )
import Data.HList
import AdaptServer
import Text.XML.HaXml.Lex (xmlLex,TokenT(..))
import Text.XML.HaXml.Parse  (XParser,xmlParseWith,element,{-doctypedecl,-}processinginstruction,elemOpenTag,elemCloseTag)
import Text.XML.HaXml.Types as Hax hiding (Element) -- (ElemTag,QName(..),Namespace(..),Element(..),Content(..),AttValue(..))
import qualified Text.XML.HaXml.Types as Hax (Element(..))
import Text.XML.HaXml.Posn (Posn, posnLine, posnColumn)
import qualified Text.XML.HaXml.Pretty as PP
import Text.PrettyPrint
import Data.Maybe
import Debug.Trace
import Control.Arrow
import Network.Socket
import Data.String
import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class
import Control.DeepSeq
import Control.Concurrent.STM
import Control.Concurrent
import Control.Exception as Exception
import Text.Show.ByteString as L
import qualified Data.Map as Map
import GHC.Conc
import Network.BSD hiding (getHostByAddr)
import Control.Concurrent.Async
import qualified Data.Set as Set
import GetHostByAddr
import XMPPTypes

is_remote (RemotePeer _) = True
is_remote _              = False

getNamesForPeer :: Peer -> IO [ByteString]
getNamesForPeer LocalHost = fmap ((:[]) . pack) getHostName
getNamesForPeer peer@(RemotePeer addr) = do
    {-
    let hints = Just $ defaultHints { addrFlags = [ AI_CANONNAME ] }
    L.putStrLn $ "getAddrInfo 1 " <++> showPeer peer
    infos <- getAddrInfo hints (Just . unpack . showPeer $ peer) Nothing
    return . map pack . mapMaybe addrCanonName $ infos
    -}
    -- ent <- getHostByName (unpack . showPeer $ peer)
    ent <- getHostByAddr addr --  AF_UNSPEC addr
    let names = hostName ent : hostAliases ent
    return . map pack $ names


peerAddr :: Peer -> SockAddr
peerAddr (RemotePeer addr) = addr
-- peerAddr LocalHost = throw exception


xmlifyPresenceForPeer sock (Presence jid stat) = do
    -- TODO: accept socket argument and determine local ip address
    --       connected to this peer.
    addr <- getSocketName sock
    let n = name jid
        rsc = resource jid
        jid_str = n <$++> "@" <?++> showPeer (RemotePeer addr) <++?>  "/" <++$> rsc 
    return . L.unlines $
      [ "<presence from='" <++> jid_str <++> "' " <++> typ stat <++> ">"
      , "<show>" <++> shw stat <++> "</show>"
      , "</presence>"
      ]
 where
    typ Offline = " type='unavailable'"
    typ _       = ""
    shw Available = "chat"
    shw Away      = "away"
    shw Offline   = "away" -- Is this right?

xmlifyPresenceForClient (Presence jid stat) = do
    let n   = name jid
        rsc = resource jid
    names <- getNamesForPeer (peer jid)
    let tostr p = n <$++> "@" <?++> p <++?>  "/" <++$> rsc
        jidstrs = fmap tostr names
    return (L.concat $ map doit jidstrs)
 where
    doit jidstr = L.unlines 
      [ "<presence from='" <++> jidstr <++> "' " <++> typ stat <++> ">"
      , "<show>" <++> shw stat <++> "</show>"
      , "</presence>"
      ]
    typ Offline = " type='unavailable'"
    typ _       = ""
    shw Available = "chat"
    shw Away      = "away"
    shw Offline   = "away" -- Is this right?

instance NFData Presence where
    rnf (Presence jid stat) = rnf jid `seq` stat `seq` ()


greet host = L.unlines 
    [ "<?xml version='1.0'?>"
    , "<stream:stream"
    , "from='" <++> host <++> "'"
    , "id='someid'"
    , "xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams' version='1.0'>"
    , "<stream:features>"
    , "  <bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'/>"
    {-
    -- , "  <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>"
    , " <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"
    -- , " <mechanism>DIGEST-MD5</mechanism>"
    , " <mechanism>PLAIN</mechanism>"
    , " </mechanisms> "
    -}
    , "</stream:features>"
    ]

-- data TaggedXMPPSession s = TaggedXMPPSession s

data Commands = Send ByteString
 deriving Prelude.Show

startCon session_factory sock st  = do
    let h = hOccursFst st :: Handle 
    -- cred <- getLocalPeerCred sock
    -- Prelude.putStrLn $ "PEER CRED: "++Prelude.show cred
    pname <- getPeerName sock
    session <- newSession session_factory sock
    Prelude.putStrLn $ "PEER NAME: "++Prelude.show pname
    pchan <- subscribe session Nothing
    cmdChan <- atomically newTChan
    reader <- forkIO $
        handle (\(SomeException e) -> L.putStrLn $ "quit reader via exception: "<++>bshow e) $
         fix $ \loop -> do
            event <- atomically $ 
                (fmap Left $ readTChan pchan)
              `orElse`
                (fmap Right $ readTChan cmdChan)
            case event of
                Left presence -> do
                    L.putStrLn $ "PRESENCE: " <++> bshow presence
                    -- TODO: it violates spec to send presence information before
                    --  a resource is bound.
                    r <- xmlifyPresenceForClient presence
                    hPutStrLn h r
                    L.putStrLn $ "\nOUT client:\n" <++> r
                Right (Send r) ->
                    hPutStrLn h r
            loop
    let quit = do
            killThread reader
            closeSession session
    return ( (session,cmdChan) .*. ConnectionFinalizer quit .*. st)

iq_query_unavailable host id mjid xmlns kind = L.unlines $
    [ "<iq type='error'"
    , "    from='" <++> host <++> "'" <++?> " to='" <++$> mjid <$++> "'"
    , "    id='" <++> id <++> "'>"
    , "  <" <++> kind <++> " xmlns='" <++> xmlns <++> "'/>"
    , "  <error type='cancel'>"
    , "    <service-unavailable"
    , "        xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>"
    , "  </error>"
    , "</iq>"
    ]

tagattrs tag content = Prelude.concatMap (\(CElem (Elem _ a _) _)->a) 
                          $ Prelude.filter (bindElem tag) content
anytagattrs content = Prelude.concatMap (\(CElem (Elem n a _) _)->map (second (n,)) a) content

bindElem tag (CElem (Elem (N n) _ _) _) | n==tag = True
bindElem _   _                                   = False

hasElem tag content =
  not . Prelude.null . Prelude.filter (bindElem tag) $ content

unattr (AttValue as) = listToMaybe $ Prelude.concatMap left as
    where left (Left x) = [x]
          left _        = []

astring (AttValue [Left s]) = [s]

tagcontent tag content = Prelude.concatMap (\(CElem (Elem _ _ c) _)->c) 
                              $ Prelude.filter (bindElem tag) content

iq_bind_reply id jid = L.unlines $
    [ "<iq type='result' id='" <++> id <++> "'>"
    , "<bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'>"
    , "<jid>" <++> jid <++> "</jid>"
    , "</bind>"
    , "</iq> "
    ]
iq_session_reply host id = L.unlines $
    [ "<iq type='result'"
    , "    id='" <++> id <++> "'"
    , "    from='" <++> host <++> "'"
    , "    /> "
    ]

{-
iqresult_info host id mjid = L.unlines $
    [ "<iq type='result'"
    , "    from='" <++> host <++> "'" <++?> " to='" <++$> mjid <$++> "'"
    , "    id='" <++> id <++> "'>"
    , "  <query xmlns='http://jabber.org/protocol/disco#info'>"
    , "    <identity"
    , "       category='server'"
    , "       type='im'"
    , "       name='" <++> host <++> "'/>"
    , "    <feature var='http://jabber.org/protocol/disco#info'/>"
    , "    <feature var='http://jabber.org/protocol/disco#items'/>"
    , "  </query>"
    , "</iq>"
    ]
-}

iqresponse session host (Elem _ attrs content) = runMaybeT $ do
    id <- MaybeT . return $ fmap pack (lookup (N "id") attrs >>= unattr) 
    typ <- MaybeT . return $ fmap pack (lookup (N "type") attrs >>= unattr)
    case typ of
      "set" -> do
        let string (CString _ s _) = [s]
        mplus (do
                rsrc <- MaybeT . return . fmap pack $ listToMaybe . Prelude.concatMap string . tagcontent "resource" . tagcontent "bind" $ content
                -- let jid = "TODO" <++> "@" <++> host <++> "/" <++> pack rsrc
                liftIO $ do
                 setResource session rsrc
                 jid <- getJID session
                 return $ iq_bind_reply id (L.show jid) )
              (do
                guard (hasElem "session" content)
                return (iq_session_reply host id))
                
      "get" -> {- trace ("iq-get "++show (attrs,content)) $ -} do
        (tag,as) <- MaybeT . return $ lookup (N "xmlns") (anytagattrs content) 
        xmlns <- MaybeT . return $ fmap pack $ listToMaybe . astring $ as
        let servicekind = case tag of { (N s) -> pack s ; _ -> "query" }
        case xmlns of
            "urn:xmpp:ping" ->
                return $ 
                    "<iq from='" <++> host 
                    <++> ("' " <++?> "to='" <++$> fmap pack (lookup (N "from") attrs >>= unattr) <$++> "' ")
                    <++> "id='" <++> id <++> "' type='result'/>"

            _ -> return (iq_query_unavailable host id Nothing xmlns servicekind)
      _ -> MaybeT (return Nothing)
    

presence_response host (Elem _ attrs content) = do
    -- let id = fmap pack (lookup (N "id") attrs >>= unattr) 
    typ <- fmap pack (lookup (N "type") attrs >>= unattr)
    case typ of
        "subscribe" -> do
            -- <presence to='guest@localhost' type='subscribe'/>
            to <- fmap pack (lookup (N "to") attrs >>= unattr)
            Just $ "<presence to='" <++> to <++> "' type='subscribed'/>"
        _ -> Nothing

doCon st elem cont = do
        let h = hOccursFst st :: Handle 
            (session,cmdChan) = hHead st
            hsend r = do
                atomically $ writeTChan cmdChan (Send r)
                -- hPutStrLn h r
                L.putStrLn $ "\nOUT client:\n" <++> r
        -- host <- fmap pack $ getHostName -- Assume localhost for client session JID
        host <- do
            jid <- getJID session
            names <- getNamesForPeer (peer jid)
            return (head names)
        
        putStrLn $ (Prelude.show $ hang (text "\nIN client:") 2 $ pp elem) ++ "\n"

        case elem of
            OpenTag _ -> 
                hsend (greet host)
            Element e@(Elem (N "iq") _ _) -> do
                rpns <- iqresponse session host e
                case rpns of
                    Nothing -> trace "IGNORE: no response to <iq>" $ return ()
                    Just r -> hsend r
            Element e@(Elem (N "presence") _ _) ->
                case presence_response host e of
                    Nothing -> trace "IGNORE: no response to <presence>" $ return ()
                    Just r -> hsend r

            _ -> return () -- putStrLn $ "unhandled: "++show v

        cont ()

instance Prelude.Show Hax.ElemTag where
    show _ = "elemtag"

data XmppObject
    = Element (Hax.Element Posn)
    | ProcessingInstruction Hax.ProcessingInstruction
    | OpenTag ElemTag
    | CloseTag ()
 deriving Prelude.Show

pp (Element e) = PP.element e
pp o = fromString (Prelude.show o)

streamName = QN (Namespace {nsPrefix= "stream" , nsURI="http://etherx.jabber.org/streams" }) "stream" 

newtype TryParse p x e = Try (Either e p,[x])

instance Monad (TryParse p x) where
        return v = Try (Left v,[])
        Try (Left m,xs)  >>= k = k m
        Try (Right e,xs) >>= _ = Try (Right e,xs)

runTryParse (Try p) = p
mapRight f (Right x,ls) = (Right (f x),ls)
mapRight f (Left  y,ls) = (Left  y    ,ls)

dropLeadingSpace toks = dropWhile space toks
 where
    space (_,TokFreeText cs) = all isSpace cs
    space _                  = False

xmppParse :: [(Posn, TokenT)] -> (Either String XmppObject, [(Posn, TokenT)])
xmppParse ls = runTryParse $ do
    let xml :: (t -> b) -> XParser t -> (Either String b, [(Posn, TokenT)])
        xml tag = mapRight tag . flip xmlParseWith (dropLeadingSpace ls)
    Try . xml Element               $ element
    Try . xml OpenTag               $ elemOpenTag
    Try . xml CloseTag              $ elemCloseTag streamName
    Try . xml ProcessingInstruction $ processinginstruction


showTokenT TokCommentOpen       =     "<!--"
showTokenT TokCommentClose      =     "-->"
showTokenT TokPIOpen        =     "<?"
showTokenT TokPIClose       =     "?>"
showTokenT TokSectionOpen       =     "<!["
showTokenT TokSectionClose      =     "]]>"
showTokenT TokSpecialOpen       =     "<!"
showTokenT TokEndOpen       =     "</"
showTokenT TokEndClose      =     "/>"
showTokenT TokAnyOpen       =     "<"
showTokenT TokAnyClose      =     ">"
showTokenT TokSqOpen        =     "["
showTokenT TokSqClose       =     "]"
showTokenT TokEqual         =     "="
showTokenT TokQuery         =     "?"
showTokenT TokStar          =     "*"
showTokenT TokPlus          =     "+"
showTokenT TokAmp           =     "&"
showTokenT TokSemi          =     ";"
showTokenT TokHash          =     "#"
showTokenT TokBraOpen       =     "("
showTokenT TokBraClose      =     ")"
showTokenT TokPipe          =     "|"
showTokenT TokPercent       =     "%"
showTokenT TokComma         =     ","
showTokenT TokQuote         =     "' or \""
showTokenT TokNull          =     "(null)"
showTokenT (TokError     s)     = "TokError "++ Prelude.show s
showTokenT (TokSection s)       = "TokSection "++Prelude.show s
showTokenT (TokSpecial s)       = "TokSpecial "++Prelude.show s
showTokenT (TokName      s)     = "TokName "++Prelude.show s
showTokenT (TokFreeText  s)     = "TokFreeText "++s

showtoks ts = Prelude.show $ map (showTokenT . snd) ts
    

listenForXmppClients addr_family session_factory port st = do
    -- standard port: 5222
    let (start,dopkt) = 
            adaptServer showtoks ( dropTill
                        , xmlLexPartial "local-client" . unpack
                        , xmppParse)
                        (startCon session_factory,doCon)
    doServer addr_family
             (port .*. st)
             dopkt
             start


startPeer session_factory sock st = do
    let h = hOccursFst st :: Handle 
    name <- fmap bshow $ getPeerName sock
    L.putStrLn $ "IN peer: connected " <++> name
    jids <- newTVarIO Set.empty
    session <- newSession session_factory sock
    let quit = do
            L.putStrLn $ "IN peer: disconnected " <++> name
            js <- fmap Set.toList (readTVarIO jids)
            let offline jid = Presence jid Offline
            forM_ js $ announcePresence session . offline
            closeSession session
    return ( (session,jids) .*. ConnectionFinalizer quit .*. st )

doPeer st elem cont = do
    let (session,jids) = hHead st
    L.putStrLn $ "IN peer: " <++> bshow elem
    case elem of
      Element e@(Elem (N "presence") attrs content) -> do
        let jid = fmap pack (lookup (N "from") attrs >>= unattr)
            typ = fmap pack (lookup (N "type") attrs >>= unattr)
        case (jid,typ) of
          (Just jid,Just "unavailable") -> do
            L.putStrLn $ "IN peer: PRESENCE! Offline jid=" <++> jid
            -- parseAddressJID -- convert peer reported user@address to JID data structure
            peer_jid <- parseAddressJID jid
            atomically $ do
                jids_ <- readTVar jids
                writeTVar jids (Set.delete peer_jid jids_)
            announcePresence session (Presence peer_jid Offline)
          (Just jid,Just typ) -> 
            -- possible probe, ignored for now
            L.putStrLn $ "IN peer: Ignored presence! "<++>typ<++>" jid="<++>jid
          (Just jid,Nothing) -> do
            let string (CString _ s _) = [s]
                stat = listToMaybe . Prelude.concatMap string . tagcontent "show" $ content
                stat' = case stat of
                         Nothing -> Available
                         Just "away" -> Away
                         Just "xa"   -> Away -- TODO: xa
                         Just "dnd"  -> Away -- TODO: dnd
                         Just "chat" -> Available
                         _       -> Available
            -- Available or Away.
            pjid <- parseAddressJID jid
            -- names <- getNamesForPeer  (peer pjid)
            -- L.putStrLn $ "IN peer: PRESENCE! "<++>bshow (stat,names)<++>" avail/away jid=" <++> jid
            atomically $ do
                jids_ <- readTVar jids
                writeTVar jids (Set.insert pjid jids_)
            announcePresence session (Presence pjid stat')
            L.putStrLn $ "IN peer: " <++> bshow (Presence pjid stat')
      _ -> return () -- putStrLn $ "inbound unhandled: "++show v
    cont ()

xmlLexPartial name cs =
    let ls = xmlLex name cs
        isTokError (_,TokError _) = True
        isTokError _              = False
        (gs,bs) = break isTokError ls
    in if any (not . isTokError) bs
        then ls
        else gs
        

listenForRemotePeers addrfamily session_factory port st = do
    -- standard port: 5269
    let (start,dopkt) = 
            adaptServer showtoks ( dropTill
                        , xmlLexPartial "remote-inbound" . unpack
                        , xmppParse)
                        (startPeer session_factory,doPeer)
    doServer addrfamily
             (port .*. st)
             dopkt
             start

dropTill bs ((fst->posn):_) =
  let ls = zip [1..] (L.lines bs)
      ln = posnLine posn
      col = posnColumn posn
      ls' = map snd $ dropWhile ((<ln).fst) ls
  in case ls' of
        []           -> ""
        fstLine:ls'' -> foldr1 (<++>) (L.drop (fromIntegral (col-1)) fstLine : ls'')


data OutBoundMessage = OutBoundPresence Presence
 deriving Prelude.Show

newServerConnections = atomically $ newTVar Map.empty

sendMessage cons msg peer = do
    found <- atomically $ do
        consmap <- readTVar cons
        return (Map.lookup peer consmap)
    let newEntry = do
          chan <- atomically newTChan
          t <- forkIO $ connect_to_server chan peer
          -- L.putStrLn $ "remote-map new: " <++> showPeer peer
          return (True,(chan,t))
    (is_new,entry) <- maybe newEntry
          ( \(chan,t) -> do 
                        st <- threadStatus t
                        let running = do
                                -- L.putStrLn $ "remote-map, thread running: " <++> showPeer peer
                                return (False,(chan,t))
                            died = do
                                -- L.putStrLn $ "remote-map, thread died("<++>bshow st<++>"): " <++> showPeer peer
                                newEntry 
                        case st of 
                          ThreadRunning   -> running
                          ThreadBlocked _ -> running
                          ThreadDied      -> died
                          ThreadFinished  -> died
                        )
          found
    -- L.putStrLn $ "sendMessage ->"<++>showPeer peer<++>": "<++>bshow msg
    atomically $ writeTChan (fst entry) msg
    when is_new . atomically $
        readTVar cons >>= writeTVar cons . Map.insert peer entry

connect_to_server chan peer = (>> return ()) . runMaybeT $ do
    let port = 5269 :: Int

    connected <- liftIO . async $ connect' (peerAddr peer) port

    -- We'll cache Presence notifications until the socket
    -- is ready.
    cached <- liftIO $ newIORef Map.empty

    sock <- MaybeT . fix $ \loop -> do
        e <- atomically $ orElse
                (fmap Right $ waitSTM connected)
                (fmap Left  $ readTChan chan)
        case e of
            Left (OutBoundPresence (Presence jid Offline)) -> do
                cached_map <- readIORef cached
                writeIORef cached (Map.delete jid cached_map)
                loop
            Left (OutBoundPresence p@(Presence jid st)) -> do
                cached_map <- readIORef cached
                writeIORef cached (Map.insert jid st cached_map)
                loop
            {-
            Left event -> do
                L.putStrLn $ "REMOTE-OUT DISCARDED: " <++> bshow event
                loop
            -}
            Right sock -> return sock

    liftIO $ do
        h <- socketToHandle sock ReadWriteMode
        hSetBuffering h NoBuffering
        hPutStrLn h "<stream>"
        L.putStrLn $ "OUT peer: <stream>"
        cache <- fmap Map.assocs . readIORef $ cached
        writeIORef cached Map.empty -- hint garbage collector: we're done with this
        forM_ cache $ \(jid,st) -> do
            r <- xmlifyPresenceForPeer sock (Presence jid st)
            hPutStrLn h r
            L.putStrLn $ "OUT peer: (cache)\n" <++> r <++> "\n"
        fix $ \loop -> do
            event <- atomically $ readTChan chan
            case event of
              OutBoundPresence p -> do
                r <- xmlifyPresenceForPeer sock p
                hPutStrLn h r
                L.putStrLn $ "OUT peer:\n" <++> r <++> "\n"
            loop
        hPutStrLn h "</stream>"
        L.putStrLn $ "OUT peer: </stream>"


splitJID :: ByteString -> (Maybe ByteString,ByteString,Maybe ByteString)
splitJID bjid = 
    let xs = L.splitWith (=='@') bjid
        ys = L.splitWith (=='/') (last xs)
        server = head ys
        name
            = case xs of
                (n:s:_) -> Just n
                (s:_)   -> Nothing
        rsrc = case ys of
                (s:_:_) -> Just $ last ys
                _       -> Nothing
    in (name,server,rsrc)

strip_brackets s = 
    case L.uncons s of
      Just ('[',t) -> L.takeWhile (/=']') t
      _            -> s

parseAddressJID :: ByteString -> IO JID
parseAddressJID jid = do
    let (name,peer_string,rsc) = splitJID jid
        hints = Just $ defaultHints { addrFlags = [ {- AI_NUMERICHOST, -} AI_CANONNAME ] }
        peer_string' = unpack . strip_brackets $ peer_string
    peer <- do
        -- putStrLn $ "getAddrInfo 2 " ++ Prelude.show ( Just (unpack peer_string))
        info <- getAddrInfo hints (Just peer_string') Nothing -- (Just "xmpp-server")
        let info0 = head info
        return . RemotePeer . addrAddress $ info0
    return $ JID name peer rsc

parseHostNameJID :: ByteString -> IO JID
parseHostNameJID jid = do
    let (name,peer_string,rsc) = splitJID jid
        hints = Just $ defaultHints { addrFlags = [ AI_CANONNAME ] }
    peer <- do
        if peer_string=="localhost"
          then return LocalHost
          else do
            -- putStrLn $ "getAddrInfo 3 " ++ Prelude.show ( Just (unpack peer_string))
            info <- getAddrInfo hints (Just (unpack peer_string)) Nothing -- (Just "xmpp-server")
            let info0 = head info
                cname = addrCanonName info0
            if cname==Just "localhost"
              then return LocalHost
              else do
                self <- getHostName
                return $ if Just self==cname
                          then LocalHost 
                          else RemotePeer (addrAddress info0)
    return $ JID name peer rsc

socketFamily (SockAddrInet _ _)      = AF_INET
socketFamily (SockAddrInet6 _ _ _ _) = AF_INET6
socketFamily (SockAddrUnix _)        = AF_UNIX

connect' :: SockAddr -> Int -> IO (Maybe Socket)
connect' addr port = do
    proto <- getProtocolNumber "tcp"
    {-
    -- Given (host :: HostName) ...
    let hints = defaultHints { addrFlags = [AI_ADDRCONFIG]
                             , addrProtocol = proto
                             , addrSocketType = Stream }
    addrs <- getAddrInfo (Just hints) (Just host) (Just serv)
    firstSuccessful $ map tryToConnect addrs
    -}
    let getport (SockAddrInet port _) = port
        getport (SockAddrInet6 port _ _ _) = port
    let withPort (SockAddrInet _ a)      port = SockAddrInet (toEnum port) a
        withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 (toEnum port) a b c
    let doException (SomeException e) = do
            L.putStrLn $  "\nFailed to reach "<++> showPeer (RemotePeer addr) <++> " on port "<++>bshow port<++>": " <++> bshow e
            return Nothing
    handle doException
         $ tryToConnect proto (addr `withPort` port)
  where
  tryToConnect proto addr =
    bracketOnError
        (socket (socketFamily addr) Stream proto)
        (sClose )  -- only done if there's an error
        (\sock -> do
          connect sock addr
          return (Just sock) -- socketToHandle sock ReadWriteMode
        )

catchIO :: IO a -> (IOException -> IO a) -> IO a
catchIO a h = Exception.catch a h

-- Returns the first action from a list which does not throw an exception.
-- If all the actions throw exceptions (and the list of actions is not empty),
-- the last exception is thrown.
firstSuccessful :: [IO a] -> IO a
firstSuccessful [] = error "firstSuccessful: empty list"
firstSuccessful (p:ps) = catchIO p $ \e ->
    case ps of
        [] -> Exception.throwIO e
        _  -> firstSuccessful ps


seekRemotePeers :: XMPPConfig config =>
     config -> TChan Presence -> IO b0
seekRemotePeers config chan = do
    server_connections <- newServerConnections
    fix $ \loop -> do
        event <- atomically $ readTChan chan
        case event of
            p@(Presence jid stat) | not (is_remote (peer jid)) -> do
              -- L.putStrLn $ "seekRemotePeers: " <++> L.show jid <++> " " <++> bshow stat
              runMaybeT $ do
                  u <- MaybeT . return $ name jid
                  subscribers <- liftIO $ do
                    subs <- getSubscribers config u
                    mapM parseHostNameJID subs
                  -- liftIO . L.putStrLn $ "subscribers: " <++> bshow subscribers
                  let peers = Set.map peer (Set.fromList subscribers)
                  forM_ (Set.toList peers) $ \peer -> do
                    when (is_remote peer) $
                        liftIO $ sendMessage server_connections (OutBoundPresence p) peer
                  -- TODO: send presence probes for buddies
                  -- TODO: cache remote presences for clients
            _ -> return (Just ())
        loop