path: root/Presence/XMPPServer.hs

{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE TypeFamilies        #-}
-- {-# LANGUAGE GADTs               #-}
module XMPPServer where -- ( listenForXmppClients ) where

import Data.Char (isSpace)
import Todo
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 LocalPeerCred
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 Data.Binary.Builder as B
import Data.Binary.Put
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

data Peer = LocalHost | RemotePeer SockAddr
  deriving (Eq,Prelude.Show)

instance Ord Peer where
    LocalHost <= _  
      = True
    RemotePeer (SockAddrUnix a) <= RemotePeer (SockAddrUnix b)
      = a <= b
    RemotePeer (SockAddrUnix _) <= _
      = True
    RemotePeer (SockAddrInet aport a) <= RemotePeer (SockAddrInet bport b)
      = (a,aport) <= (b,bport)
    RemotePeer (SockAddrInet aport a) <= _
      = True
    RemotePeer (SockAddrInet6 aport aflow a ascope) <= RemotePeer (SockAddrInet6 bport bflow b bscope)
      = (a,aport,ascope,aflow) <= (b,bport,bscope,bflow)
    a <= b = False

-- | Jabber ID (JID) datatype
data JID = JID { name :: Maybe ByteString
               , peer :: Peer
               , resource :: Maybe ByteString
               }
 deriving (Eq,Ord)

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


showPeer :: Peer -> ByteString
showPeer LocalHost = "localhost"
showPeer (RemotePeer addr@(SockAddrInet _ _)) = pack $ stripColon (Prelude.show addr)
 where stripColon s = pre where (pre,port) = break (==':') s
showPeer (RemotePeer addr@(SockAddrInet6 _ _ _ _)) = pack $ stripColon (Prelude.show addr)
 where stripColon s = if null bracket then pre else pre ++ "]"
          where
            (pre,bracket) = break (==']') s

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

instance L.Show JID where
    showp (JID n s r ) = putBuilder . B.fromLazyByteString $ n <$++> "@" <?++> showPeer s <++?>  "/" <++$> r

instance Prelude.Show JID where
    show jid = L.unpack $ L.show jid

instance NFData JID where
    rnf v@(JID n s r) = n `seq` s `seq` r `seq` ()

jid user host rsrc = JID (Just user) host (Just rsrc)

data JabberShow = Offline
                | Away
                | Available
 deriving (Prelude.Show,Enum,Ord,Eq,Read)

data Presence = Presence JID JabberShow
 deriving Prelude.Show

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` ()


class XMPPSession session where
    data XMPPClass session
    newSession   :: XMPPClass session -> Socket -> Handle -> IO session
    setResource  :: session -> ByteString -> IO ()
    getJID       :: session -> IO JID
    closeSession :: session -> IO ()
    subscribe :: session -> Maybe JID -> IO (TChan Presence)
    announcePresence :: session -> Presence -> IO ()

class XMPPConfig config where
    getBuddies :: config -> ByteString -> IO [ByteString]
    getSubscribers :: config -> ByteString -> IO [ByteString]

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 h
    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
    let quit = L.putStrLn $ "IN peer: disconnected " <++> name
    session <- newSession session_factory sock h
    return ( session .*. ConnectionFinalizer quit .*. st )

doPeer st elem cont = do
    let session = 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
            announcePresence session (Presence peer_jid Offline)
          (Just jid,Just typ) -> 
            -- possible probe, ignored for now
            L.putStrLn $ "IN peer: 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
            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"

    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 -> ServiceName -> IO (Maybe Socket)
connect' addr serv = 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 port = getport addr
    let withPort (SockAddrInet _ a)      port = SockAddrInet port a
        withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 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` 5269)
  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
            _ -> return (Just ())
        loop