path: root/Presence/XMPP.hs

{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ViewPatterns        #-}
{-# LANGUAGE TypeFamilies        #-}
module XMPP 
    ( module XMPPTypes
    , listenForXmppClients
    , listenForRemotePeers
    , newServerConnections
    , seekRemotePeers
    , quitListening
    , OutBoundMessage(..)
    , OutgoingConnections
    , CachedMessages
    , toPeer
    , newOutgoingConnections
    , sendMessage
    )  where

import ServerC
import XMPPTypes
import ByteStringOperators
import ControlMaybe
import XMLToByteStrings
import SendMessage
import Logging
import Todo

import Data.Maybe (catMaybes)
import Data.HList
import Network.Socket ( Family )
import Control.Concurrent.STM
import Control.Concurrent.STM.Delay
import Data.Conduit
import Data.Maybe
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy.Char8 as L
    ( fromChunks
    )
import Control.Concurrent.Async
import Control.Exception as E ( finally )
import System.IO.Error (isDoesNotExistError)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Text.XML.Stream.Parse (def,parseBytes,content)
import Data.XML.Types as XML
import qualified Data.Text as S (Text,takeWhile)
import Data.Text.Encoding      as S (decodeUtf8,encodeUtf8)
import Data.Text.Lazy.Encoding as L (decodeUtf8)
import Data.Text.Lazy (toStrict)
import qualified Data.Sequence as Seq
import Data.Foldable (toList)
import Data.List (find)
import qualified Text.Show.ByteString as L
import NestingXML
import           Data.Set as Set (Set,(\\))
import qualified Data.Set as Set
import qualified Data.Map as Map
import           Data.Map as Map (Map)

textToByteString x = L.fromChunks [S.encodeUtf8 x]



xmlifyPresenceForClient :: Presence -> IO [XML.Event]
xmlifyPresenceForClient (Presence jid stat) = do
    let n   = name jid
        rsc = resource jid
    names <- getNamesForPeer (peer jid)
    let tostr p = L.decodeUtf8 $ n <$++> "@" <?++> L.fromChunks [p] <++?>  "/" <++$> rsc
        jidstrs = fmap (toStrict . tostr) names
    return (concatMap presenceEvents jidstrs)
 where
    presenceEvents jidstr =
      [ EventBeginElement "{jabber:client}presence" (("from",[ContentText jidstr]):typ stat) ] 
      ++ ( shw stat >>= jabberShow ) ++
      [ EventEndElement "{jabber:client}presence" ]
    typ Offline = [("type",[ContentText "unavailable"])]
    typ _       = []
    shw ExtendedAway = ["xa"]
    shw Chatty       = ["chat"]
    shw Away         = ["away"]
    shw DoNotDisturb = ["dnd"]
    shw _            = []
    jabberShow stat = 
      [ EventBeginElement "{jabber:client}show" []
      , EventContent (ContentText stat)
      , EventEndElement "{jabber:client}show" ]

prefix ## name = Name name Nothing (Just prefix)

streamP name = Name name (Just "http://etherx.jabber.org/streams") (Just "stream")
    
greet host =
    [ EventBeginDocument
    , EventBeginElement (streamP "stream")
        [("from",[ContentText host])
        ,("id",[ContentText "someid"])
        ,("xmlns",[ContentText "jabber:client"])
        ,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"])
        ,("version",[ContentText "1.0"])
        ]
    , EventBeginElement (streamP "features") []
    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" []
    , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}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> "
    -}

    , EventEndElement (streamP "features")
    ]


-- type Consumer i m r = forall o. ConduitM i o m r
mawait :: Monad m => MaybeT (ConduitM i o m) i
mawait = MaybeT await

-- Note: This function ignores name space qualification
elementAttrs expected (EventBeginElement name attrs)
    | nameLocalName name==expected 
    = return attrs
elementAttrs _ _ = mzero
     
eventIsBeginElement (EventBeginElement _ _) = True
eventIsBeginElement _                       = False

eventIsEndElement (EventEndElement _) = True
eventIsEndElement _                   = False

filterMapElement::
  (Monad m, MonadPlus mp) =>
  (Event -> mp a) -> Event -> mp a -> MaybeT (ConduitM Event o m) (mp a)
filterMapElement ret opentag empty = loop (empty `mplus` ret opentag) 1 
 where
    loop ts 0 = return ts
    loop ts cnt = do
        tag <- mawait
        let ts' = mplus ts (ret tag)
        case () of
         _ | eventIsEndElement tag   -> loop ts' (cnt-1)
         _ | eventIsBeginElement tag -> loop ts' (cnt+1)
         _                           -> loop ts' cnt

gatherElement ::
  (Monad m, MonadPlus mp) =>
  Event -> mp Event -> NestingXML o m (mp Event)
gatherElement opentag empty = loop (empty `mplus` return opentag) 1 
 where
    loop ts 0 = return ts
    loop ts cnt = do
        maybeXML (return ts) $ \tag -> do
        let ts' = mplus ts (return tag)
        case () of
         _ | eventIsEndElement tag   -> loop ts' (cnt-1)
         _ | eventIsBeginElement tag -> loop ts' (cnt+1)
         _                           -> loop ts' cnt


voidMaybeT body = (>> return ()) . runMaybeT $ body
fixMaybeT f = (>> return ()) . runMaybeT . fix $ f

iq_bind_reply id jid =
    [ EventBeginElement "{jabber:client}iq" [("type",[ContentText "result"]),("id",[ContentText id])]

    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
        [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])]
    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}jid" []
    , EventContent (ContentText jid)
    , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}jid"
    , EventEndElement  "{urn:ietf:params:xml:ns:xmpp-bind}bind"
    , EventEndElement "{jabber:client}iq"
    ]

uncontent cs = head $ map getText cs
 where
    getText (ContentText x) = x
    getText (ContentEntity x ) = x

tagAttrs (EventBeginElement _ xs) = xs
tagAttrs _                        = []

tagName (EventBeginElement n _) = n
tagName _                       = ""

handleIQSetBind session cmdChan stanza_id = do
    mchild <- nextElement
    rsc <- case mchild of
             Just child -> do
                let unhandledBind = do
                        liftIO $ debugStr $ "unhandled-bind: "++show child
                        return ""
                case tagName child of
                    "{urn:ietf:params:xml:ns:xmpp-bind}resource"
                      -> do
                        rsc <- lift content
                        return . textToByteString $ rsc
                    _ -> unhandledBind
             Nothing -> do
                liftIO $ debugStr $ "empty bind request!"
                return ""
    liftIO $ do
        debugL $ "iq-set-bind-resource " <++> rsc
        setResource session rsc
        jid <- getJID session
        atomically $ do
            writeTChan cmdChan (Send $ iq_bind_reply stanza_id (toStrict $ L.decodeUtf8 $ L.show jid) )
            writeTChan cmdChan BoundToResource
        forCachedPresence session $ \presence -> do
            xs <- xmlifyPresenceForClient presence
            atomically . writeTChan cmdChan . Send $ xs


iq_session_reply host stanza_id =
    [ EventBeginElement "{jabber:client}iq" 
        [("id",[ContentText stanza_id])
        ,("from",[ContentText host])
        ,("type",[ContentText "result"])
        ]
    , EventEndElement "{jabber:client}iq"
    ]

handleIQSetSession session cmdChan stanza_id = do
    host <- liftIO $ do
        jid <- getJID session
        names <- getNamesForPeer (peer jid)
        return (S.decodeUtf8 . head $ names)
    liftIO . atomically . writeTChan cmdChan . Send $ iq_session_reply host stanza_id

handleIQSet session cmdChan tag = do
    withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do
    whenJust nextElement $ \child -> do
    let unhandledSet = liftIO $ debugStr ("iq-set: "++show (stanza_id,child))
    case tagName child of
      "{urn:ietf:params:xml:ns:xmpp-bind}bind" 
        -> handleIQSetBind session cmdChan stanza_id
      "{urn:ietf:params:xml:ns:xmpp-session}session"
        -> handleIQSetSession session cmdChan stanza_id
      _ -> unhandledSet

matchAttrib name value attrs = 
    case find ( (==name) . fst) attrs of
        Just (_,[ContentText x])   | x==value -> True
        Just (_,[ContentEntity x]) | x==value -> True
        _                                     -> False

lookupAttrib name attrs =
    case find ( (==name) . fst) attrs of
        Just (_,[ContentText x])   -> Just x
        Just (_,[ContentEntity x]) -> Just x
        _                          -> Nothing
    
iqTypeSet    = "set"
iqTypeGet    = "get"
iqTypeResult = "result"
iqTypeError  = "error"

isIQOf (EventBeginElement name attrs) testType 
    | name=="{jabber:client}iq" 
    && matchAttrib "type" testType attrs
    = True
isIQOf _ _ = False

isServerIQOf (EventBeginElement name attrs) testType 
    | name=="{jabber:server}iq" 
    && matchAttrib "type" testType attrs
    = True
isServerIQOf _ _ = False

iq_service_unavailable host iq_id mjid req =
    [ EventBeginElement "{jabber:client}iq" 
        [("type",[ContentText "error"])
        ,("id",[ContentText iq_id])
        -- , TODO: set "from" if isJust mjid
        ]
    , EventBeginElement req []
    , EventEndElement req
    , EventBeginElement "{jabber:client}error" [("type",[ContentText "cancel"])]
    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable" []
    , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable"
    , EventEndElement "{jabber:client}error"
    , EventEndElement "{jabber:client}iq"
    ]

attr   name value = (name,[ContentText value])
attrbs name value = (name,[ContentText (toStrict . L.decodeUtf8 $ value)])


getRoster session iqid = do
    let getlist f = do
            bs <- f session
            -- js <- mapM parseHostNameJID bs
            return (Set.fromList bs) -- js)
    buddies     <- getlist getMyBuddies
    subscribers <- getlist getMySubscribers
    solicited   <- getlist getMySolicited
    subnone0     <- getlist getMyOthers
    let subnone = subnone0 \\ (Set.union buddies subscribers)
    let subto = buddies \\ subscribers
    let subfrom = subscribers \\ buddies
    let subboth = Set.intersection buddies subscribers
	-- solicited -> ask='subscribe'
    jid <- getJID session
    let dest = toStrict . L.decodeUtf8 . bshow $ jid
    let items= (xmlify solicited "to" subto) 
               ++(xmlify solicited "from" subfrom)
               ++(xmlify solicited "both" subboth)
               ++(xmlify solicited "none" subnone)
        openiq =  [EventBeginElement "{jabber:client}iq"
                    [ attr "id" iqid
                    , attr "to" dest
                    , attr "type" "result" ]
                  ,EventBeginElement "{jabber:iq:roster}query"
                    [] -- todo: ver? 
                  ]
        closeiq = [EventEndElement "{jabber:iq:roster}query"
                  ,EventEndElement "{jabber:client}iq"]
    return $ openiq ++ items ++ closeiq
 where
    xmlify solicited stype set = flip concatMap (Set.toList set) 
      $ \jid -> 
        [ EventBeginElement "item" 
            ([ attr "jid" (toStrict . L.decodeUtf8 $ jid)
             , attr "subscription" stype
             ]++if Set.member jid solicited 
                 then [attr "ask" "subscribe"]
                 else [] )
        , EventEndElement "item"
        ] 

handleIQGet session cmdChan tag = do
    withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do
    whenJust nextElement $ \child -> do
    host <- liftIO $ do
        jid <- getJID session
        names <- getNamesForPeer (peer jid)
        return (S.decodeUtf8 . head $ names)
    let unhandledGet req = do
            liftIO $ debugStr ("iq-get: "++show (stanza_id,child))
            liftIO . atomically . writeTChan cmdChan . Send $ iq_service_unavailable host stanza_id Nothing req
    case tagName child of
        -- "{http://jabber.org/protocol/disco#items}query" -> liftIO $ debugStr "iq-get-query-items"
        "{urn:xmpp:ping}ping" -> liftIO $ do
            let mjid = lookupAttrib "from" (tagAttrs tag)
            let pong = [ EventBeginElement "{jabber:client}iq" 
                         $ (case mjid of
                             Just jid -> (attr "to" jid :)
                             _        -> id               )
                             [ attr "type" "result"
                             , attr "id"   stanza_id
                             , attr "from" host
                             ]
                      , EventEndElement "{jabber:client}iq"
                      ]
            atomically . writeTChan cmdChan . Send $ pong
        "{jabber:iq:roster}query" -> liftIO $ do
            debugStr $ "REQUESTED ROSTER " ++ show tag
            roster <- getRoster session stanza_id
            atomically $ do
                writeTChan cmdChan InterestedInRoster
                writeTChan cmdChan . Send $ roster
            sendPending session
        req -> unhandledGet req
    

handleClientPresence session stanza = do
    -- online (Available or Away)
    let log  = liftIO . debugL . ("(C) " <++>)
    log $ "handleClientPresence "<++>bshow stanza
    jid <- liftIO $ getJID session
    -- cjid <- liftIO $ parseAddressJID (textToByteString jid)
    let parseChildren stat = do
            child <- nextElement
            log $ " child: "<++> bshow child
            case child of
                Just tag | tagName tag=="{jabber:client}show"
                                      -> fmap toStat (lift content)
                Just tag | otherwise  -> parseChildren stat
                Nothing -> return stat
        toStat "away" = Away
        toStat "xa"   = ExtendedAway
        toStat "dnd"  = DoNotDisturb
        toStat "chat" = Chatty

    stat' <- parseChildren Available
    liftIO $ setPresence session stat'
    log $ "requesting presence: "<++>bshow stat'
    return ()


fromClient :: (MonadThrow m,MonadIO m, JabberClientSession session) => 
    session -> TChan ClientCommands -> Sink XML.Event m ()
fromClient session cmdChan = doNestingXML $ do
    let log  = liftIO . debugL . ("(C) " <++>)
        send = liftIO . atomically . writeTChan cmdChan . Send
    withXML $ \begindoc -> do
    when (begindoc==EventBeginDocument) $ do
    log "begin-doc"
    withXML $ \xml -> do
    withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
    log $ "stream atributes: " <++> bshow stream_attrs
    host <- liftIO $ do
        jid <- getJID session
        names <- getNamesForPeer (peer jid)
        return (S.decodeUtf8 . head $ names)
    send $ greet host
    
    fix $ \loop -> do
        log "waiting for stanza."
        whenJust nextElement $ \stanza -> do
            stanza_lvl <- nesting

            liftIO . debugStr $ "stanza: "++show stanza

            let unhandledStanza = do
                    xs <- gatherElement stanza Seq.empty
                    prettyPrint "unhandled-C: " (toList xs)
            case () of
             _ | stanza `isIQOf` iqTypeSet -> handleIQSet session cmdChan stanza
             _ | stanza `isIQOf` iqTypeGet -> handleIQGet session cmdChan stanza
             _ | stanza `isClientPresenceOf` presenceTypeSubscribe 
                                           -> clientRequestsSubscription session cmdChan stanza
             _ | stanza `isClientPresenceOf` presenceTypeSubscribed
                                           -> clientApprovesSubscription session stanza
             _ | stanza `isClientPresenceOf` presenceTypeUnsubscribed
                                           -> clientRejectsSubscription session stanza
             _ | stanza `isClientPresenceOf` presenceTypeOnline
                                           -> handleClientPresence session stanza
             _ | isMessageStanza stanza    -> handleClientMessage session stanza
             _ | otherwise                 -> unhandledStanza

            awaitCloser stanza_lvl
            loop

    log $ "end of stream"
    withXML $ \xml -> do
    log $ "end-of-document: " <++> bshow xml


rosterPush to contact attrs = do
    let n   = name to
        rsc = resource to
    names <- getNamesForPeer (peer to)
    let tostr p = L.decodeUtf8 $ n <$++> "@" <?++> L.fromChunks [p] <++?>  "/" <++$> rsc
        jidstrs = fmap (toStrict . tostr) names
        tojid = head jidstrs
    return
      [ EventBeginElement "{jabber:client}iq" 
            [ attr "to"   tojid
            , attr "id"   "someid"
            , attr "type" "set"
            ]
      , EventBeginElement "{jabber:iq:roster}query" []
      , EventBeginElement "{jabber:iq:roster}item" (attr "jid" contact : attrs)
      , EventEndElement   "{jabber:iq:roster}item"
      , EventEndElement   "{jabber:iq:roster}query"
      , EventEndElement "{jabber:client}iq"
      ]

data EventsForClient = CmdChan ClientCommands 
                     | PChan   Presence
                     | RChan   RosterEvent

toClient :: (MonadIO m, JabberClientSession session ) => 
    session -> TChan Presence -> TChan ClientCommands -> TChan RosterEvent -> Source m [XML.Event]
toClient session pchan cmdChan rchan = toClient' False False 
 where
  toClient' isBound isInterested = do
    let loop = toClient' isBound isInterested
        send xs = yield xs >> prettyPrint ">C: " xs
    event <- liftIO . atomically $ 
              foldr1 orElse [fmap CmdChan $ readTChan cmdChan
                            ,fmap RChan   $ readTChan rchan
                            ,fmap PChan   $ readTChan pchan
                            ]
    case event of
      CmdChan QuitThread -> return ()
      CmdChan (Send xs)  -> send xs >> loop
      CmdChan BoundToResource    -> toClient' True    isInterested
      CmdChan InterestedInRoster -> do
        liftIO . debugStr $ "Roster: interested"
        toClient' isBound True
      CmdChan (Chat msg) -> do
        xs <- liftIO $ xmlifyMessageForClient msg
        send xs
        loop
      -- CmdChan cmd        -> liftIO (debugStr $ "unhandled event: "++show cmd) >> loop
      RChan   (RequestedSubscription who contact) ->  do
        jid <- liftIO $ getJID session
        when (isInterested && Just who==name jid) $ do
            r <- liftIO $ rosterPush jid (toStrict . L.decodeUtf8 $ contact) [attr "ask" "subscribe"]
            send r
        loop
      RChan   (NewBuddy who contact) ->  do
        liftIO . debugStr $ "Roster push: NewBuddy "++show (isInterested,who,contact)
        (jid,me) <- liftIO $ do
                        jid <- getJID session
                        me <- asHostNameJID jid
                        return (jid,me)
        withJust me $ \me -> do
        when (isInterested && Just who==name jid) $ do
            send [ EventBeginElement "{jabber:client}presence" 
                    [ attrbs "from" contact
                    , attrbs "to"   me
                    , attr   "type" "subscribed"
                    ]
                 , EventEndElement "{jabber:client}presence" ]
            let f True  = "both"
                f False = "to"
            subscription <- fmap f (liftIO $ isSubscribed session contact)
            r <- liftIO . handleIO (\e -> debugStr ("Roster NewBuddy error: "++show e) >> return []) $ do
                            rosterPush jid 
                                     (toStrict . L.decodeUtf8 $ contact) 
                                     [attr "subscription" subscription]
            send r
        loop
      RChan   (RemovedBuddy who contact) ->  do
        liftIO . debugStr $ "Roster push: RemovedBuddy "++show (isInterested,who,contact)
        (jid,me) <- liftIO $ do
                        jid <- getJID session
                        me <- asHostNameJID jid
                        return (jid,me)
        withJust me $ \me -> do
        when (isInterested && Just who==name jid) $ do
            send [ EventBeginElement "{jabber:client}presence" 
                    [ attrbs "from" contact
                    , attrbs "to"   me
                    , attr   "type" "unsubscribed"
                    ]
                 , EventEndElement "{jabber:client}presence" ]
            let f True  = "from"
                f False = "none"
            subscription <- fmap f (liftIO $ isSubscribed session contact)
            r <- liftIO . handleIO (\e -> debugStr ("Roster RemovedBuddy error: "++show e) >> return []) $ do
                            rosterPush jid 
                                     (toStrict . L.decodeUtf8 $ contact) 
                                     [attr "subscription" subscription]
            send r
        loop
      RChan   (NewSubscriber who contact) ->  do
        liftIO . debugStr $ "Roster push: NewSubscriber "++show (isInterested,who,contact)
        (jid,me) <- liftIO $ do
                        jid <- getJID session
                        me <- asHostNameJID jid
                        return (jid,me)
        withJust me $ \me -> do
        when (isInterested && Just who==name jid) $ do
            let f True  = "both"
                f False = "from"
            subscription <- fmap f (liftIO $ isBuddy session contact)
            r <- liftIO . handleIO (\e -> debugStr ("Roster NewSubscriber error: "++show e) >> return []) $ do
                            rosterPush jid 
                                     (toStrict . L.decodeUtf8 $ contact) 
                                     [attr "subscription" subscription]
            send r
        loop
      RChan   (RejectSubscriber who contact) ->  do
        liftIO . debugStr $ "Roster push: RejectSubscriber "++show (isInterested,who,contact)
        (jid,me) <- liftIO $ do
                        jid <- getJID session
                        me <- asHostNameJID jid
                        return (jid,me)
        withJust me $ \me -> do
        when (isInterested && Just who==name jid) $ do
            let f True  = "to"
                f False = "none"
            subscription <- fmap f (liftIO $ isBuddy session contact)
            r <- liftIO . handleIO (\e -> debugStr ("Roster RejectSubscriber error: "++show e) >> return []) $ do
                            rosterPush jid 
                                     (toStrict . L.decodeUtf8 $ contact) 
                                     [attr "subscription" subscription]
            send r
        loop
      RChan   (PendingSubscriber who contact) ->  do
        liftIO . debugStr $ "Roster: Pending buddy "++show (isInterested,who,contact)
        (jid,me) <- liftIO $ do
                        jid <- getJID session
                        me <- asHostNameJID jid
                        return (jid,me)
        withJust me $ \me -> do
        when (isInterested && Just who==name jid) $ do
            send [ EventBeginElement "{jabber:client}presence" 
                    [ attrbs "from" contact
                    , attrbs "to"   me
                    , attr   "type" "subscribe"
                    ]
                 , EventEndElement "{jabber:client}presence" ]
        loop
      PChan presence   -> do 
        when isBound $ do
            xs <- liftIO $ xmlifyPresenceForClient presence
            send xs
        loop


handleClient
  :: (SocketLike sock, HHead l (XMPPClass session),
      JabberClientSession session) =>
     HCons sock (HCons t l) -> Source IO ByteString -> Sink ByteString IO () -> IO ()
handleClient st src snk = do
    let HCons sock (HCons _ st') = st
        session_factory = hHead st'
    pname <- getPeerName sock
    session <- newSession session_factory sock
    debugStr $ "PEER NAME: "++Prelude.show pname
    pchan <- subscribe session Nothing
    rchan <- subscribeToRoster session
    let cmdChan = clientChannel session

    writer <- async ( toClient session pchan cmdChan rchan `xmlToByteStrings` snk ) 
    finally         ( src $= parseBytes def $$ fromClient session cmdChan )
        $ do
            atomically $ writeTChan cmdChan QuitThread
            wait writer
            closeSession session

listenForXmppClients ::
  (HList l, HHead l (XMPPClass session), HExtend e1 l2 l1,
   HExtend e l1 (HCons PortNumber l), JabberClientSession session) =>
  Family -> e1 -> e -> l2 -> IO ServerHandle
listenForXmppClients addr_family session_factory port st = do
    doServer (addr_family .*. port .*. session_factory .*. st) handleClient


listenForRemotePeers
  :: (HList l, HHead l (XMPPPeerClass session),
      HExtend e l1 (HCons PortNumber l), HExtend e1 l2 l1,
      JabberPeerSession session) =>
     Family -> e1 -> e -> l2 -> IO ServerHandle
listenForRemotePeers addrfamily session_factory port st = do
    doServer (addrfamily .*. port .*. session_factory .*. st) handlePeer

handlePeer
  :: (HHead l (XMPPPeerClass session),
      JabberPeerSession session) =>
     HCons RestrictedSocket (HCons t1 l) -> Source IO ByteString -> t -> IO ()
handlePeer st src snk = do
    let HCons sock (HCons _ st') = st
        session_factory = hHead st'
    name <- fmap bshow $ getPeerName sock
    debugL $ "(P) connected " <++> name
    session <- newPeerSession session_factory sock

    finally ( src $= parseBytes def $$ fromPeer sock session )
        $ do 
            debugL $ "(P) disconnected " <++> name
            closePeerSession session


handlePeerPresence session stanza False = do
    -- Offline
    liftIO . debugStr $ "PEER-OFFLINE: "++show stanza
    withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do
    peer_jid <- liftIO $ parseAddressJID (textToByteString jid)
    liftIO . debugStr $ "PEER-OFFLINE-JID: "++show peer_jid
    liftIO $ announcePresence session (Presence peer_jid Offline)
handlePeerPresence session stanza True = do
    -- online (Available or Away)
    let log  = liftIO . debugL . ("(P) " <++>)
    withJust (lookupAttrib "from" (tagAttrs stanza)) $ \jid -> do
    pjid <- liftIO $ parseAddressJID (textToByteString jid)
    -- stat <- show element content
    let parseChildren stat = do
            child <- nextElement
            case child of
                Just tag | tagName tag=="{jabber:server}show"
                                      -> fmap toStat (lift content)
                Just tag | otherwise  -> parseChildren stat
                Nothing -> return stat
        toStat "away" = Away
        toStat "xa"   = ExtendedAway
        toStat "dnd"  = DoNotDisturb
        toStat "chat" = Chatty

    stat' <- parseChildren Available
    liftIO . debugStr $ "announcing peer online: "++show (pjid,stat')
    liftIO $ announcePresence session (Presence pjid stat')
    log $ bshow (Presence pjid stat')

handlePeerMessage session stanza = do
    withJust (lookupAttrib "from" (tagAttrs stanza)) $ \fromstr-> do
    withJust (lookupAttrib "to" (tagAttrs stanza)) $ \tostr -> do
    fromjid <- liftIO $ parseAddressJID (textToByteString fromstr)
    tojid <- liftIO $ parseAddressJID (textToByteString tostr)
    let log  = liftIO . debugL . ("(P) " <++>)
    log $ "handlePeerMessage "<++>bshow stanza
    msg <- parseMessage ("{jabber:server}body"
                        ,"{jabber:server}subject"
                        ,"{jabber:server}thread"
                        )
                        log
                        fromjid
                        tojid
                        stanza
    liftIO $ sendChatToClient session msg

matchAttribMaybe name (Just value) attrs = 
    case find ( (==name) . fst) attrs of
        Just (_,[ContentText x])   | x==value -> True
        Just (_,[ContentEntity x]) | x==value -> True
        _                                     -> False
matchAttribMaybe name Nothing attrs  
    | find ( (==name) . fst) attrs==Nothing
    = True
matchAttribMaybe name Nothing attrs  
    | otherwise
    = False

presenceTypeOffline      = Just "unavailable"
presenceTypeOnline       = Nothing
presenceTypeProbe        = Just "probe"
presenceTypeSubscribe    = Just "subscribe"
presenceTypeSubscribed   = Just "subscribed"
presenceTypeUnsubscribed = Just "unsubscribed"

isPresenceOf (EventBeginElement name attrs) testType
    | name=="{jabber:server}presence"
    && matchAttribMaybe "type" testType attrs
    = True
isPresenceOf _ _ = False

isMessageStanza (EventBeginElement name attrs) 
    | name=="{jabber:client}message"
    = True
isMessageStanza (EventBeginElement name attrs) 
    | name=="{jabber:server}message"
    = True
isMessageStanza _ = False

isClientPresenceOf (EventBeginElement name attrs) testType
    | name=="{jabber:client}presence"
    && matchAttribMaybe "type" testType attrs
    = True
isClientPresenceOf _ _ = False


handlePresenceProbe session stanza = do
    withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to -> do
    -- withJust (lookupAttrib "from" (tagAttrs stanza)) $ \from -> do
    jid <- liftIO $ parseAddressJID $ textToByteString to
    withJust (name jid) $ \user -> do
    liftIO $ debugL $ "RECEIVED PROBE "<++>bshow (peerAddress session,to)
    liftIO $ do
        subs <- getSubscribers (peerSessionFactory session) user
        liftIO $ debugL $ "subscribers for "<++>bshow user<++>": " <++>bshow subs
        forM_ subs $ \jidstr -> do
            handleIO_ (return ()) $ do
                debugL $ "parsing " <++>jidstr
                sub <- parseHostNameJID jidstr
                debugStr $ "comparing " ++show (peer sub , peerAddress session)
                when (peer sub == discardPort (peerAddress session)) $ do
                ps <- userStatus session user
                -- todo: Consider making this a directed presence
                forM_ ps $ \p ->  do
                    debugStr ("PROBE-REPLY: "++show p)
                mapM_ (sendPeerMessage session . OutBoundPresence) ps
    return ()

subscribeToPresence subscribers peer_jid user = do
    pjid <- parseAddressJID peer_jid
    if Set.member pjid subscribers
        then return ()
        else return ()

bare (JID n host _) = JID n host Nothing

presenceErrorRemoteNotFound iqid from to = return
    [ EventBeginElement "{stream:client}presence" 
        ( case iqid of { Nothing -> id; Just iqid -> ( attr "id" iqid :) }
           $ [ attr "from" to
             , attr "type" "error"
             ] )
    , EventBeginElement "{stream:client}error"
        [ attr "type" "modify"]
    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}remote-server-not-found"
        []
    , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}remote-server-not-found"
    , EventEndElement "{stream:client}error"
    , EventEndElement "{stream:client}presence"
    ]

presenceSubscribed from = return
    [ EventBeginElement "{stream:client}presence" 
        [ attr "from" from
        , attr "type" "subscribed"
        ]
    , EventEndElement   "{stream:client}presence"
    ]

clientRequestsSubscription session cmdChan stanza = do
    liftIO $ do
        debugStr $ "CLIENT PRESENCE SUBSCRIBE " ++ show stanza
        withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str0 -> do
        let to_str = S.takeWhile (/='/') to_str0
            from = lookupAttrib "from" (tagAttrs stanza)
            iqid = lookupAttrib "id" (tagAttrs stanza)
        let handleError e | isDoesNotExistError e = do
                debugStr $ "remote-server-not-found"
                r <- presenceErrorRemoteNotFound iqid from to_str
                atomically $ writeTChan cmdChan (Send r)
            handleError e = do
                debugStr $ "ERROR: "++ show e
        handleIO handleError $ do
            let to_str' = textToByteString to_str
            to_jid <- fmap bare $ parseHostNameJID to_str'
            if (is_remote . peer) to_jid 
             then do
                addSolicited session to_str' to_jid
                debugStr $ "added to solicited: " ++ show to_jid
             else do
                -- addLocalSubscriber session to_str
                -- self <- getJID session
                r <- presenceSubscribed to_str -- self
                atomically $ writeTChan cmdChan (Send r)
    return ()


stanzaFromTo ::
  JabberPeerSession session =>
  session -> Event -> IO (Maybe (JID, JID))
stanzaFromTo session stanza = 
    let lookup key = fmap textToByteString (lookupAttrib key (tagAttrs stanza))
        parse jidstr =  handleIO_ (return Nothing) (fmap Just $ parseAddressJID jidstr)
    in case liftM2 (,) (lookup "from") (lookup "to") of
        Nothing -> return Nothing
        Just (from,to) ->  do
            mfrom <- parse from
            mto   <- parse to
            case liftM2 (,) mfrom mto of
                Nothing -> return Nothing
                Just (from,to) -> do
                    let fromjid = JID (name from) (peerAddress session) Nothing
                    return $ Just (fromjid,to)

peerRequestsSubsription session stanza = do
    liftIO $ debugStr $ "PEER PRESENCE SUBSCRIBE " ++ show stanza

    whenJust (liftIO . handleIO (\e -> debugStr ("peerRequestsSubsription: "++show e) >> return Nothing) 
                $ stanzaFromTo session stanza) $ \(fromjid,tojid) -> do
    withJust (name tojid) $ \user -> do

    subs <- liftIO $ do
             subs <- getSubscribers (peerSessionFactory session) user
             msubs <- flip mapM subs $ \str -> do
                        handleIO_ (return Nothing) 
                                  (fmap Just $ parseHostNameJID str)
             return (catMaybes msubs)
    if elem fromjid subs
      then do
        liftIO . debugL $ bshow fromjid <++> " already subscribed to " <++> user
        -- if already subscribed, reply
        liftIO $ do
             sendPeerMessage session (Approval tojid fromjid)
             ps <- userStatus session user
             -- todo: consider making this a directed presence
             mapM_ (sendPeerMessage session . OutBoundPresence) ps
      else
        liftIO $ processRequest session user fromjid

clientApprovesSubscription session stanza = do
    liftIO $ debugStr $ "CLIENT APPROVES SUBSCRIPTION"
    withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do
    liftIO $ approveSubscriber session (textToByteString to_str)

clientRejectsSubscription session stanza = do
    liftIO $ debugStr $ "CLIENT REJECTS SUBSCRIPTION"
    withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do
    liftIO $ rejectSubscriber session (textToByteString to_str)

peerApprovesSubscription session stanza = do
    liftIO $ debugStr $ "PEER APPROVES SUBSCRIPTION"
    whenJust (liftIO . handleIO (\e -> debugStr ("peerApprovesSubscription: "++show e) >> return Nothing) 
             $ stanzaFromTo session stanza) $ \(fromjid,tojid) -> do
    withJust (name tojid) $ \user -> do
    liftIO $ processApproval session user fromjid

peerRejectsSubscription session stanza = do
    liftIO $ debugStr $ "PEER REJECTS SUBSCRIPTION"
    whenJust (liftIO . handleIO (\e -> debugStr ("peerRejectsSubscription: "++show e) >> return Nothing) 
             $ stanzaFromTo session stanza) $ \(fromjid,tojid) -> do
    withJust (name tojid) $ \user -> do
    liftIO $ processRejection session user fromjid

handlePeerIQGet :: (JabberPeerSession session, MonadIO m) =>
                        session -> XML.Event -> NestingXML o m ()
handlePeerIQGet session tag = do
    -- TODO: Pings should not require an id field.
    withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do
    whenJust nextElement $ \child -> do
    let unhandledGet req = do
            liftIO $ debugStr ("iq-peer-get: "++show (stanza_id,child))
            liftIO $
              sendPeerMessage session (Unsupported (JID Nothing LocalHost Nothing)
                                                   (JID Nothing (peerAddress session) Nothing)
                                                   (Just (ContentText stanza_id))
                                                   req)
            -- Client equiv: liftIO . atomically . writeTChan cmdChan . Send $ iq_service_unavailable host stanza_id Nothing req
    case tagName child of
        -- "{http://jabber.org/protocol/disco#items}query" -> liftIO $ debugStr "iq-get-query-items"
        "{urn:xmpp:ping}ping" -> liftIO $ do
            sendPeerMessage session (Pong (JID Nothing LocalHost Nothing)
                                          (JID Nothing (peerAddress session) Nothing)
                                          (Just (ContentText stanza_id)))
            -- Client equiv: atomically . writeTChan cmdChan . Send $ pong
            return ()

        req -> unhandledGet req

fromPeer :: (MonadThrow m,MonadIO m, JabberPeerSession session) => 
    RestrictedSocket -> session -> Sink XML.Event m ()
fromPeer sock session = doNestingXML $ do
    let log  = liftIO . debugL . ("(P) " <++>)
    withXML $ \begindoc -> do
    when (begindoc==EventBeginDocument) $ do
    log "begin-doc"
    withXML $ \xml -> do
    withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
    log $ "stream atributes: " <++> bshow stream_attrs

    fix $ \loop -> do
        log "waiting for stanza."
        whenJust nextElement $ \stanza -> do
            stanza_lvl <- nesting

            liftIO $ sendPeerMessage session (ActivityBump sock) -- reset ping timer

            let unhandledStanza = do
                    xs <- gatherElement stanza Seq.empty
                    prettyPrint "P: " (toList xs)
            case () of
              _ | stanza `isServerIQOf` iqTypeGet -> handlePeerIQGet session stanza
              _ | stanza `isPresenceOf` presenceTypeOnline
                    -> handlePeerPresence session stanza True
              _ | stanza `isPresenceOf` presenceTypeOffline
                    -> handlePeerPresence session stanza False
              _ | stanza `isPresenceOf` presenceTypeProbe
                    -> handlePresenceProbe session stanza
              _ | stanza `isPresenceOf` presenceTypeSubscribe
                    -> peerRequestsSubsription session stanza
              _ | stanza `isPresenceOf` presenceTypeSubscribed
                    -> peerApprovesSubscription session stanza
              _ | stanza `isPresenceOf` presenceTypeUnsubscribed
                    -> peerRejectsSubscription session stanza
              _ | isMessageStanza stanza 
                    -> handlePeerMessage session stanza
              _ -> unhandledStanza

            awaitCloser stanza_lvl
            loop

    log $ "end of stream"
    withXML $ \xml -> do
    log $ "end-of-document: " <++> bshow xml




newServerConnections = newTVar Map.empty

data CachedMessages = CachedMessages 
    { presences :: Map JID JabberShow
    , probes :: Map JID (Set (Bool,JID)) -- False means solicitation rather than probe
    , approvals :: Map JID (Set (Bool,JID) ) -- False means rejection rather than approval
    }

instance CommandCache CachedMessages where
    type CacheableCommand CachedMessages = OutBoundMessage
    emptyCache = CachedMessages Map.empty Map.empty Map.empty

    updateCache (OutBoundPresence (Presence jid Offline)) cache = 
                cache { presences=Map.delete jid . presences $ cache }
    updateCache (OutBoundPresence p@(Presence jid st)) cache =
                cache { presences=Map.insert jid st . presences $ cache }
    updateCache (PresenceProbe from to) cache =
                cache { probes = mmInsert  (True,from) to $ probes cache }
    updateCache (Solicitation from to) cache =
                cache { probes= mmInsert (False,from) to $ probes cache }
    updateCache (Approval from to) cache =
                cache { approvals= mmInsert (True,from) to $ approvals cache }
    updateCache (Rejection from to) cache =
                cache { approvals= mmInsert (False,from) to $ approvals cache }
    updateCache (OutBoundMessage msg) cache = cache -- TODO: cache chat?
    updateCache (Pong _ _ _) cache = trace "(DISCARDING Pong)" cache          -- pings are not cached
    updateCache (Unsupported _ _ _ _) cache = cache -- error messages are not cached
    updateCache (ActivityBump sock) cache = cache

instance ThreadChannelCommand OutBoundMessage where
    isQuitCommand Disconnect = True
    isQuitCommand _          = False

mmInsert val key mm = Map.alter f key mm
 where 
    f Nothing    = Just $ Set.singleton val
    f (Just set) = Just $ Set.insert val set


greetPeer =
    [ EventBeginDocument
    , EventBeginElement (streamP "stream")
        [ attr "xmlns"   "jabber:server"
        , attr "version" "1.0"
        ]
    ]

goodbyePeer = 
    [ EventEndElement (streamP "stream")
    , EventEndDocument
    ]

peerJidTextLocal sock jid = do
    addr <- getSocketName sock
    return .  toStrict . L.decodeUtf8 
                       $ name jid <$++> "@" 
                        <?++> showPeer (RemotePeer addr) 
                        <++?>  "/" <++$> resource jid

peerJidTextRemote sock jid = do
    addr <- getPeerName sock
    return .  toStrict . L.decodeUtf8 
                       $ name jid <$++> "@" 
                        <?++> showPeer (RemotePeer addr) 
                        <++?>  "/" <++$> resource jid

presenceStanza sock fromjid tojid typ = do
    from <- peerJidTextLocal sock fromjid
    let to = toStrict . L.decodeUtf8
              $ name tojid <$++> "@"
                <?++> showPeer (peer tojid)
    return 
      [ EventBeginElement "{jabber:server}presence"
            [ attr "from" from
            , attr "to"   to
            , attr "type" typ
            ]
      , EventEndElement "{jabber:server}presence"
      ]


toPeer
  :: SocketLike sock =>
     sock
     -> CachedMessages
     -> TChan OutBoundMessage
     -> (Maybe OutBoundMessage -> IO ())
     -> ConduitM i [Event] IO ()
toPeer sock cache chan fail = do
    let -- log     = liftIO . debugL . ("(>P) " <++>)
        send xs = yield xs >> prettyPrint ">P: " xs -- >> return (3::Int)
        checkConnection cmd = do
            liftIO $ catchIO (getPeerName sock >> return ())
                           (\_ -> fail . Just $ cmd)
        sendOrFail getXML cmd = do
            checkConnection cmd
            r <- liftIO $ getXML
                    -- handleIO (\e -> debugStr ("ERROR: "++show e) >> return []) getXML
            yieldOr r (fail . Just $ cmd)
            prettyPrint ">P: " r
        sendPresence presence =
            sendOrFail (xmlifyPresenceForPeer sock presence)
                       (OutBoundPresence presence)
        sendProbe from to =
            sendOrFail (presenceStanza sock from to "probe")
                       (PresenceProbe from to)
        sendSolicitation from to = 
            sendOrFail (presenceStanza sock from to "subscribe")
                       (Solicitation from to)
        sendApproval approve from to = 
            sendOrFail (presenceStanza sock from to 
                          (if approve then "subscribed" else "unsubscribed"))
                       (if approve then Approval from to
                                   else Rejection from to)
        sendMessage msg =
            sendOrFail (xmlifyMessageForPeer sock msg)
                       (OutBoundMessage msg)

        sendPong from to mid = do
            liftIO . debugL $ "SEND PONG" 
            sendOrFail (xmlifyPong sock from to mid)
                       (Pong from to mid)
         where
            xmlifyPong sock from to mid = do
                fromjid <- peerJidTextLocal  sock to
                tojid   <- peerJidTextRemote sock to
                return $ [ EventBeginElement "{jabber:server}iq" 
                          $ (case mid of
                             Just c -> (("id",[c]):)
                             _      -> id               )
                             [ attr "type" "result"
                             , attr "to"   tojid
                             , attr "from" fromjid
                             ]
                      , EventEndElement "{jabber:server}iq"
                      ]
        sendUnsupported from to mid tag =
            sendOrFail (xmlifyUnsupported sock from to mid tag)
                       (Unsupported from to mid tag)
         where
            xmlifyUnsupported sock from to mid req = do
                fromjid <- peerJidTextLocal  sock to
                tojid   <- peerJidTextRemote sock to
                return $ 
                    [ EventBeginElement "{jabber:server}iq" 
                     $ (case mid of
                        Just c -> (("id",[c]):)
                        _      -> id               )
                        [("type",[ContentText "error"])
                        , attr "to"   tojid
                        , attr "from" fromjid
                        ]
                    , EventBeginElement req []
                    , EventEndElement req
                    , EventBeginElement "{jabber:server}error" [("type",[ContentText "cancel"])]
                    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable" []
                    , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable"
                    , EventEndElement "{jabber:server}error"
                    , EventEndElement "{jabber:server}iq"
                    ]


    send greetPeer
    forM_ (Map.assocs . approvals $ cache) $ \(to,froms) -> do
        forM_ (Set.toList froms) $ \(approve,from) -> do
            liftIO $ debugL "sending cached approval/rejection..."
            sendApproval approve from to
    forM_ (Map.assocs . presences $ cache) $ \(jid,st) -> do
        sendPresence (Presence jid st)
    forM_ (Map.assocs . probes $ cache) $ \(to,froms) -> do
        forM_ (Set.toList froms) $ \(got,from) -> do
            if got 
              then do
                    liftIO $ debugL "sending cached probe..."
                    sendProbe from to
              else do
                    liftIO $ debugL "sending cached solicitation..."
                    sendSolicitation from to


    let five_sec = 5 * 1000000 :: Int
    pingref <- liftIO $ do
                    ping_timer <- liftIO $ newDelay five_sec
                    newTVarIO (ping_timer,0::Int)

    sockref <- liftIO $ atomically newEmptyTMVar
    let bump fromsock = do
            remote <- liftIO $ catchIO (fmap Just $ getPeerName sock)
                                       (\_ -> return Nothing)
            debugL $ "PING BUMP" <++?> fmap (showPeer . RemotePeer) remote
            timer <- atomically $ do
                        tryTakeTMVar sockref
                        putTMVar sockref fromsock
                        (timer,v) <-  readTVar pingref
                        writeTVar pingref (timer,0)
                        return timer
            updateDelay timer five_sec
        waitPing = do
            (timer,v) <- readTVar pingref
            waitDelay timer
            return v

    fix $ \loop -> do
        liftIO . debugStr $ "LOOP waiting..."
        event <- lift . atomically $ orElse (Left `fmap` readTChan chan) 
                                            (Right `fmap` waitPing)
        liftIO . debugStr $ "LOOP event = " ++ show event
        let sendPing n = do
                case n of
                    0 -> do
                            ping <- liftIO makePing
                            yield ping 
                            liftIO . debugL $ "SEND PING"
                            prettyPrint ">P: " ping
                            ping_timer <- liftIO $ newDelay five_sec
                            liftIO . atomically $ writeTVar pingref (ping_timer,1)
                            loop
                    1 -> do
                            remote <- liftIO $ getPeerName sock
                            liftIO . debugL $ "PING TIMEOUT: " <++> showPeer (RemotePeer remote)
                            fromsock <- liftIO $ atomically $ readTMVar sockref
                            liftIO $ sClose fromsock
                            return () -- PING TIMEOUT (loop quits)
                    x -> error ("What? "++show x)
              where makePing = do
                        addr <- getSocketName sock
                        remote <- getPeerName sock
                        let from = toStrict . L.decodeUtf8 . showPeer $ RemotePeer addr
                            to   = toStrict . L.decodeUtf8 . showPeer $ RemotePeer remote
                            mid  = Just (ContentText "iduno")
                        return $
                           [ EventBeginElement "{jabber:server}iq"
                             $ (case mid of
                                Just c -> (("id",[c]):)
                                _      -> id               )
                                [ ("type",[ContentText "get"])
                                , attr "to"   to
                                , attr "from" from
                                ]
                           , EventBeginElement "{urn:xmpp:ping}ping" []
                           , EventEndElement "{urn:xmpp:ping}ping"
                           , EventEndElement "{jabber:server}iq" ]
            chanEvent event = do
             case event of
                  OutBoundPresence p    -> sendPresence p
                  PresenceProbe from to -> do
                    liftIO $ debugL "sending live probe..."
                    sendProbe from to
                  Solicitation from to -> do
                    liftIO $ debugL "sending live solicitation..."
                    sendSolicitation from to
                  Approval from to -> do
                    liftIO . debugL $ "sending approval "<++>bshow (from,to)
                    sendApproval True from to
                  Rejection from to -> do
                    liftIO . debugL $ "sending rejection "<++>bshow (from,to)
                    sendApproval False from to
                  OutBoundMessage msg -> sendMessage msg
                  Pong from to mid -> do
                    liftIO . debugL $ "sending pong "<++>bshow (from,to)
                    sendPong from to mid
                  Unsupported from to mid tag -> sendUnsupported from to mid tag
                  Disconnect -> return ()
                  ActivityBump fromsock -> liftIO (bump fromsock)
             when (not . isQuitCommand $ event) loop
        either chanEvent sendPing event
    return ()
    -- send goodbyePeer -- TODO: why does this cause an exception?
                        --   Text/XML/Stream/Render.hs:169:5-15: 
                        --      Irrefutable pattern failed for pattern (sl : s')




seekRemotePeers :: JabberPeerSession config =>
     XMPPPeerClass config -> TChan Presence -> OutgoingConnections CachedMessages -> IO b0
seekRemotePeers config chan server_connections = do
    fix $ \loop -> do
        event <- atomically $ readTChan chan
        case event of
            p@(Presence jid stat) | not (is_remote (peer jid)) -> do
              -- debugL $ "seekRemotePeers: " <++> L.show jid <++> " " <++> bshow stat
              runMaybeT $ do
                  u <- MaybeT . return $ name jid
                  subscribers <- liftIO $ do
                    subs <- getSubscribers config u
                    mapM parseHostNameJID subs
                  -- liftIO . debugL $ "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 

xmlifyPresenceForPeer sock (Presence jid stat) = do
    addr <- getSocketName sock
    let n = name jid
        rsc = resource jid
        jidstr = toStrict . L.decodeUtf8 
                  $ n <$++> "@" <?++> showPeer (RemotePeer addr) <++?>  "/" <++$> rsc 
    return $
      [ EventBeginElement "{jabber:server}presence" 
            (attr "from" jidstr:typ stat) ]
      ++ ( shw stat >>= jabberShow ) ++
      [ EventEndElement "{jabber:server}presence" ]
 where
    typ Offline = [attr "type" "unavailable"]
    typ _       = []

    shw ExtendedAway = ["xa"]
    shw Chatty       = ["chat"]
    shw Away         = ["away"]
    shw DoNotDisturb = ["dnd"]
    shw _            = []
    jabberShow stat = 
      [ EventBeginElement "{jabber:server}show" []
      , EventContent (ContentText stat)
      , EventEndElement "{jabber:server}show" ]

xmlifyMessageForClient msg = do
    let tojid = msgTo msg
        fromjid = msgFrom msg
    tonames <- getNamesForPeer (peer tojid)
    fromnames <- getNamesForPeer (peer fromjid)
    let mk_str ns jid = toStrict . L.decodeUtf8 $ name jid <$++> "@" <?++> L.fromChunks [head ns] <++?> "/" <++$> resource jid
        to_str   = mk_str tonames   tojid
        from_str = mk_str fromnames fromjid
        tags = ( "{jabber:client}subject"
               , "{jabber:client}body" 
               )
    return $
        [ EventBeginElement "{jabber:client}message" 
            [ attr "from" from_str
            , attr "to"   to_str
            ]
        ]
        ++ xmlifyMsgElements tags (msgLangMap msg) ++
        [ EventEndElement "{jabber:client}message" ]
    

xmlifyMessageForPeer sock msg = do
    addr <- getSocketName sock
    remote <- getPeerName sock
    let n = name (msgFrom msg)
        rsc = resource (msgFrom msg)
        jidstr = toStrict . L.decodeUtf8 
                  $ n <$++> "@" <?++> showPeer (RemotePeer addr) <++?>  "/" <++$> rsc 
        tostr = toStrict . L.decodeUtf8 
                  $ name (msgTo msg) <$++> "@" 
                    <?++> showPeer (RemotePeer remote) <++?> "/" 
                    <++$> resource (msgTo msg)
        tags = ( "{jabber:server}subject"
               , "{jabber:server}body" 
               )
    return $
        [ EventBeginElement "{jabber:server}message" 
            [ attr "from" jidstr
            , attr "to"   tostr
            ]
        ]
        ++ xmlifyMsgElements tags (msgLangMap msg) ++
        [ EventEndElement "{jabber:server}message" ]

xmlifyMsgElements tags langmap = concatMap (uncurry (langElements tags)) . Map.toList $ langmap

langElements (subjecttag,bodytag) lang msg = 
    ( maybeToList (msgSubject msg)
         >>= wrap subjecttag )
    ++ ( maybeToList (msgBody msg)
         >>= wrap bodytag )
    ++ ( Set.toList (msgElements msg)
         >>= wrapTriple )
 where
    wrap name content = 
        [ EventBeginElement name 
            ( if lang/="" then [attr "xml:lang" lang] 
                          else [] )
        , EventContent (ContentText content)
        , EventEndElement name
        ]
    wrapTriple (name,attrs,content) =
        [ EventBeginElement name attrs -- Note: we assume lang specified in attrs
        , EventContent (ContentText content)
        , EventEndElement name
        ]


handleClientMessage session stanza = do
    let log  = liftIO . debugL . ("(C) " <++>)
    log $ "handleClientMessage "<++>bshow stanza
    from <- liftIO $ getJID session
    withJust (lookupAttrib "to" (tagAttrs stanza)) $ \to_str -> do
    log $ "  to = "<++>bshow to_str
    tojid <- liftIO $ parseHostNameJID (textToByteString to_str)
    msg <- parseMessage ("{jabber:client}body"
                        ,"{jabber:client}subject"
                        ,"{jabber:client}thread"
                        )
                        log
                        from
                        tojid
                        stanza
    liftIO $ sendChat session msg

{-
unhandled-C: <message
unhandled-C:   type="chat"
unhandled-C:   id="purplea0a7fd24"
unhandled-C:   to="user@vm2"
unhandled-C:   xmlns="jabber:client">
unhandled-C:     <active xmlns="http://jabber.org/protocol/chatstates"/>
unhandled-C:     <body>
unhandled-C:         hello dude
unhandled-C:     </body>
unhandled-C: </message>
-}
parseMessage (bodytag,subjecttag,threadtag) log from tojid stanza = do
    let emptyMsg = LangSpecificMessage { msgBody=Nothing, msgSubject=Nothing, msgElements=Set.empty }
        parseChildren (th,cmap) = do
            child <- nextElement
            lvl <- nesting
            xmllang <- xmlLang 
            let lang = maybe "" id xmllang
            let c = maybe emptyMsg id (Map.lookup lang cmap)
            log $ " child: "<++> bshow child
            case child of
                Just tag | tagName tag==bodytag
                                    -> do
                                        txt <- lift content
                                        awaitCloser lvl
                                        parseChildren (th,Map.insert lang (c { msgBody=Just txt }) cmap)
                Just tag | tagName tag==subjecttag
                                    -> do
                                        txt <- lift content
                                        awaitCloser lvl
                                        parseChildren (th,Map.insert lang (c { msgSubject=Just txt }) cmap)
                Just tag | tagName tag==threadtag
                                    -> do
                                        txt <- lift content
                                        awaitCloser lvl
                                        parseChildren (th {msgThreadContent=txt},cmap)
                Just tag -> do
                            let nm    = tagName tag
                                attrs = tagAttrs tag
                                elems = msgElements c
                            txt <- lift content
                            awaitCloser lvl
                            parseChildren (th,Map.insert lang (c {msgElements=Set.insert (nm,attrs,txt) elems}) cmap)
                Nothing -> return (th,cmap)
    (th,langmap) <- parseChildren ( MessageThread {msgThreadParent=Nothing, msgThreadContent=""}
                                  , Map.empty )
    return Message { 
        msgTo = tojid,
        msgFrom = from,
        msgLangMap = langmap,
        msgThread = if msgThreadContent th/="" then Just th else Nothing
    }