Factored out Presence.hs from main module xmppServer.hs.

1 files changed, 1045 insertions, 0 deletions

diff --git a/Presence/Presence.hs b/Presence/Presence.hs
new file mode 100644
index 00000000..2344fb75
--- /dev/null
+++ b/Presence/Presence.hs
@@ -0,0 +1,1045 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE LambdaCase #-}
+module Presence where
+
+import System.Environment
+import System.Posix.Signals
+import Control.Concurrent (threadDelay,forkIO,forkOS,killThread,throwTo)
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TMVar
+import Control.Monad.Trans.Resource (runResourceT)
+import Control.Monad.Trans
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Network.Socket ( SockAddr(..) )
+import System.Endian (fromBE32)
+import Data.List (nub, (\\), intersect, groupBy, sort, sortBy )
+import Data.Ord (comparing )
+import Data.Monoid ( (<>), Sum(..), getSum )
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+import qualified Data.Text.Encoding as Text
+import Control.Monad
+import Control.Monad.Fix
+import qualified Network.BSD as BSD
+import qualified Data.Text as Text
+import Data.Text (Text)
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Control.Exception ({-evaluate,-}handle,SomeException(..),bracketOnError,ErrorCall(..))
+import System.IO.Error (isDoesNotExistError)
+import System.Posix.User (getUserEntryForID,userName)
+import qualified Data.ByteString.Lazy.Char8 as L
+import qualified ConfigFiles
+import Data.Maybe (maybeToList,listToMaybe,mapMaybe)
+import Data.Bits
+import Data.Int (Int8)
+import Data.XML.Types (Event)
+import System.Posix.Types (UserID,CPid)
+import Control.Applicative
+
+import LockedChan (LockedChan)
+import TraversableT
+import UTmp (ProcessID,users)
+import LocalPeerCred
+import XMPPServer
+import PeerResolve
+import ConsoleWriter
+import ClientState
+import Util
+
+isPeerKey :: ConnectionKey -> Bool
+isPeerKey k = case k of { PeerKey {} -> True ; _ -> False }
+
+isClientKey :: ConnectionKey -> Bool
+isClientKey k = case k of { ClientKey {} -> True ; _ -> False }
+
+localJID :: Text -> Text -> IO Text
+localJID user resource = do
+    hostname <- textHostName
+    return $ user <> "@" <> hostname <> "/" <> resource
+
+newPresenceState cw = atomically $ do
+        clients <- newTVar Map.empty
+        clientsByUser <- newTVar Map.empty
+        remotesByPeer <- newTVar Map.empty
+        associatedPeers <- newTVar Map.empty
+        xmpp <- newEmptyTMVar
+        keyToChan <- newTVar Map.empty
+        return PresenceState
+            { clients = clients
+            , clientsByUser = clientsByUser
+            , remotesByPeer = remotesByPeer
+            , associatedPeers = associatedPeers
+            , keyToChan = keyToChan
+            , server = xmpp
+            , consoleWriter = cw
+            }
+
+
+presenceHooks state verbosity = XMPPServerParameters
+    { xmppChooseResourceName        = chooseResourceName state
+    , xmppTellClientHisName         = tellClientHisName state
+    , xmppTellMyNameToClient        = textHostName
+    , xmppTellMyNameToPeer          = \addr -> return $ addrToText addr
+    , xmppTellPeerHisName           = return . peerKeyToText
+    , xmppTellClientNameOfPeer      = flip peerKeyToResolvedName
+    , xmppNewConnection             = newConn state
+    , xmppEOF                       = eofConn state
+    , xmppRosterBuddies             = rosterGetBuddies state
+    , xmppRosterSubscribers         = rosterGetSubscribers state
+    , xmppRosterSolicited           = rosterGetSolicited state
+    , xmppRosterOthers              = rosterGetOthers state
+    , xmppSubscribeToRoster         = informSentRoster state
+    , xmppDeliverMessage            = deliverMessage state
+    , xmppInformClientPresence      = informClientPresence state
+    , xmppInformPeerPresence        = informPeerPresence state
+    , xmppAnswerProbe               = \k stanza chan -> answerProbe state (stanzaTo stanza) k chan
+    , xmppClientSubscriptionRequest = clientSubscriptionRequest state
+    , xmppPeerSubscriptionRequest   = peerSubscriptionRequest state
+    , xmppClientInformSubscription  = clientInformSubscription state
+    , xmppPeerInformSubscription    = peerInformSubscription state
+    , xmppVerbosity                 = return verbosity
+    }
+
+
+data LocalPresence = LocalPresence
+    { networkClients :: Map ConnectionKey ClientState
+    -- TODO: loginClients
+    }
+
+data RemotePresence = RemotePresence
+    { resources :: Map Text Stanza
+    -- , localSubscribers :: Map Text ()
+    -- ^ subset of clientsByUser who should be
+    -- notified about this presence.
+    }
+
+
+
+pcSingletonNetworkClient :: ConnectionKey
+                          -> ClientState -> LocalPresence
+pcSingletonNetworkClient key client =
+    LocalPresence
+    { networkClients = Map.singleton key client
+    } 
+
+pcInsertNetworkClient :: ConnectionKey -> ClientState -> LocalPresence -> LocalPresence
+pcInsertNetworkClient key client pc =
+    pc { networkClients = Map.insert key client (networkClients pc) }
+
+pcRemoveNewtworkClient :: ConnectionKey
+                        -> LocalPresence -> Maybe LocalPresence
+pcRemoveNewtworkClient key pc = if pcIsEmpty pc' then Nothing
+                                                 else Just pc'
+ where
+    pc' = pc { networkClients = Map.delete key (networkClients pc) }
+
+pcIsEmpty :: LocalPresence -> Bool
+pcIsEmpty pc = Map.null (networkClients pc)
+
+
+data PresenceState = PresenceState
+    { clients :: TVar (Map ConnectionKey ClientState)
+    , clientsByUser :: TVar (Map Text LocalPresence)
+    , remotesByPeer :: TVar (Map ConnectionKey
+                                 (Map UserName
+                                      RemotePresence))
+    , associatedPeers :: TVar (Map SockAddr ())
+    , server :: TMVar XMPPServer
+    , keyToChan :: TVar (Map ConnectionKey Conn)
+    , consoleWriter :: ConsoleWriter
+    }
+
+
+
+getConsolePids :: PresenceState -> IO [(Text,ProcessID)]
+getConsolePids state = do
+    us <- UTmp.users
+    return $ map (\(_,tty,pid)->(lazyByteStringToText tty,pid)) us
+
+identifyTTY' :: [(Text, ProcessID)]
+              -> System.Posix.Types.UserID
+              -> L.ByteString
+              -> IO (Maybe Text, Maybe System.Posix.Types.CPid)
+identifyTTY' ttypids uid inode = ttypid
+ where ttypids' = map (\(tty,pid)->(L.fromChunks [Text.encodeUtf8 tty], pid)) ttypids
+       ttypid = fmap textify $ identifyTTY ttypids' uid inode
+       textify (tty,pid) = (fmap lazyByteStringToText tty, pid)
+
+chooseResourceName :: PresenceState
+                    -> ConnectionKey -> SockAddr -> t -> IO Text
+chooseResourceName state k addr desired = do
+    muid <- getLocalPeerCred' addr
+    (mtty,pid) <- getTTYandPID muid
+    user <- getJabberUserForId muid
+    status <- atomically $ newTVar Nothing
+    flgs <- atomically $ newTVar 0
+    let client = ClientState { clientResource = maybe "fallback" id mtty
+                             , clientUser = user
+                             , clientPid = pid
+                             , clientStatus = status
+                             , clientFlags = flgs }
+
+    do -- forward-lookup of the buddies so that it is cached for reversing.
+       buds <- configText ConfigFiles.getBuddies (clientUser client)
+       forM_ buds $ \bud -> do
+            let (_,h,_) = splitJID bud
+            forkIO $ void $ resolvePeer h
+
+    atomically $ do
+        modifyTVar' (clients state) $ Map.insert k client
+        modifyTVar' (clientsByUser state) $ flip Map.alter (clientUser client)
+            $ \mb -> Just $ maybe (pcSingletonNetworkClient k client)
+                                  (pcInsertNetworkClient k client)
+                                  mb
+
+    localJID (clientUser client) (clientResource client)
+    
+  where
+    getTTYandPID muid = do
+        -- us <- fmap (map (second fst) . Map.toList) . readTVarIO $ activeUsers state
+        ttypids <- getConsolePids state
+        -- let tailOf3 ((_,a),b) = (a,b)
+        (t,pid) <- case muid of
+                      Just (uid,inode) -> identifyTTY' ttypids uid inode
+                      Nothing          -> return (Nothing,Nothing)
+        let rsc = t `mplus` fmap ( ("pid."<>) . Text.pack . show ) pid
+        return (rsc,pid)
+
+    getJabberUserForId muid =
+             maybe (return "nobody") 
+                   (\(uid,_) -> 
+                        handle (\(SomeException _) -> 
+                                return . (<> "uid.") . Text.pack . show $ uid)
+                          $ do
+                             user <- fmap userName $ getUserEntryForID uid
+                             return (Text.pack user)
+                        )
+                   muid
+
+forClient :: PresenceState
+           -> ConnectionKey -> IO b -> (ClientState -> IO b) -> IO b
+forClient state k fallback f = do
+    mclient <- atomically $ do
+        cs <- readTVar (clients state)
+        return $ Map.lookup k cs
+    maybe fallback f mclient
+
+tellClientHisName :: PresenceState -> ConnectionKey -> IO Text
+tellClientHisName state k = forClient state k fallback go
+ where
+    fallback  = localJID "nobody" "fallback"
+    go client = localJID (clientUser client) (clientResource client)
+
+toMapUnit :: Ord k => [k] -> Map k ()
+toMapUnit xs = Map.fromList $ map (,()) xs
+
+resolveAllPeers :: [Text] -> IO (Map SockAddr ())
+resolveAllPeers hosts = fmap (toMapUnit . concat) $ Prelude.mapM (fmap (take 1) . resolvePeer) hosts
+
+
+rosterGetStuff
+  :: (L.ByteString -> IO [L.ByteString])
+     -> PresenceState -> ConnectionKey -> IO [Text]
+rosterGetStuff what state k = forClient state k (return [])
+    $ \client -> do
+    jids <- configText what (clientUser client)
+    let hosts = map ((\(_,h,_)->h) . splitJID) jids
+    addrs <- resolveAllPeers hosts 
+    peers <- atomically $ readTVar (associatedPeers state)
+    addrs <- return $ addrs `Map.difference` peers
+    sv <- atomically $ takeTMVar $ server state
+    -- Grok peers to associate with from the roster:
+    forM_ (Map.keys addrs) $ \addr -> do
+        putStrLn $ "new addr: "++show addr
+        addPeer sv addr
+    -- Update local set of associated peers
+    atomically $ do
+        writeTVar (associatedPeers state) (addrs `Map.union` peers)
+        putTMVar (server state) sv
+    return jids
+
+rosterGetBuddies :: PresenceState -> ConnectionKey -> IO [Text]
+rosterGetBuddies state k = rosterGetStuff ConfigFiles.getBuddies state k
+
+rosterGetSolicited :: PresenceState -> ConnectionKey -> IO [Text]
+rosterGetSolicited = rosterGetStuff ConfigFiles.getSolicited
+
+rosterGetOthers :: PresenceState -> ConnectionKey -> IO [Text]
+rosterGetOthers = rosterGetStuff ConfigFiles.getOthers
+
+rosterGetSubscribers :: PresenceState -> ConnectionKey -> IO [Text]
+rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers
+
+data Conn = Conn { connChan :: TChan Stanza
+                 , auxAddr :: SockAddr }
+
+configText :: Functor f =>
+            (L.ByteString -> f [L.ByteString]) -> Text -> f [Text]
+configText what u = fmap (map lazyByteStringToText)
+                        $ what (textToLazyByteString u)
+
+getBuddies' :: Text -> IO [Text]
+getBuddies' = configText ConfigFiles.getBuddies
+getSolicited' :: Text -> IO [Text]
+getSolicited' = configText ConfigFiles.getSolicited
+
+sendProbesAndSolicitations :: PresenceState
+                            -> ConnectionKey -> SockAddr -> TChan Stanza -> IO ()
+sendProbesAndSolicitations state k laddr chan = do
+    -- get all buddies & solicited matching k for all users
+    xs <- runTraversableT $ do
+        cbu <- lift $ atomically $ readTVar $ clientsByUser state
+        user <- liftT $ Map.keys cbu
+        (isbud,getter) <- liftT [(True ,getBuddies'  )
+                                ,(False,getSolicited')]
+        bud  <- liftMT $ getter user
+        let (u,h,r) = splitJID bud
+        addr <- liftMT $ nub `fmap` resolvePeer h
+        liftT $ guard (PeerKey addr == k)
+        -- Note: Earlier I was tempted to do all the IO
+        -- within the TraversableT monad.  That apparently
+        -- is a bad idea.  Perhaps due to laziness and an
+        -- unforced list?  Instead, we will return a list
+        -- of (Bool,Text) for processing outside.
+        return (isbud,u,if isbud then "" else user)
+    -- XXX: The following O(n²) nub may be a little
+    --      too onerous.
+    forM_ (nub xs) $ \(isbud,u,user) -> do
+        let make = if isbud then presenceProbe 
+                            else presenceSolicitation
+            toh = peerKeyToText k
+            jid = unsplitJID (u,toh,Nothing)
+            me = addrToText laddr
+            from = if isbud then me -- probe from server
+                            else -- solicitation from particular user
+                                 unsplitJID (Just user,me,Nothing)
+        stanza <- make from jid
+        -- send probes for buddies, solicitations for solicited.
+        putStrLn $ "probing "++show k++" for: " ++ show (isbud,jid)
+        atomically $ writeTChan chan stanza
+    -- reverse xs `seq` return ()
+
+newConn :: PresenceState -> ConnectionKey -> SockAddr -> TChan Stanza -> IO ()
+newConn state k addr outchan = do
+    atomically $ modifyTVar' (keyToChan state)
+        $ Map.insert k Conn { connChan = outchan
+                            , auxAddr  = addr }
+    when (isPeerKey k)
+        $ sendProbesAndSolicitations state k addr outchan
+
+delclient :: (Alternative m, Monad m) =>
+           ConnectionKey -> m LocalPresence -> m LocalPresence
+delclient k mlp = do
+    lp <- mlp
+    let nc = Map.delete k $ networkClients lp
+    guard $ not (Map.null nc)
+    return $ lp { networkClients = nc }
+
+eofConn :: PresenceState -> ConnectionKey -> IO ()
+eofConn state k = do
+    atomically $ modifyTVar' (keyToChan state) $ Map.delete k
+    case k of
+        ClientKey {} -> do
+            forClient state k (return ()) $ \client -> do
+            stanza <- makePresenceStanza "jabber:server" Nothing Offline
+            informClientPresence state k stanza
+            atomically $ do
+                modifyTVar' (clientsByUser state)
+                    $ Map.alter (delclient k) (clientUser client)
+        PeerKey {} -> do
+            let h = peerKeyToText k
+            jids <- atomically $ do
+                rbp <- readTVar (remotesByPeer state)
+                return $ do
+                    umap <- maybeToList $ Map.lookup k rbp
+                    (u,rp) <- Map.toList umap
+                    r <- Map.keys (resources rp)
+                    return $ unsplitJID (Just u, h, Just r)
+            forM_ jids $ \jid -> do
+            stanza <- makePresenceStanza "jabber:client" (Just jid) Offline
+            informPeerPresence state k stanza
+
+{-
+rewriteJIDForClient1:: Text -> IO (Maybe ((Maybe Text,Text,Maybe Text),SockAddr))
+rewriteJIDForClient1 jid = do
+    let (n,h,r) = splitJID jid
+    maddr <- fmap listToMaybe $ resolvePeer h
+    flip (maybe $ return Nothing) maddr $ \addr -> do
+        h' <- peerKeyToResolvedName (PeerKey addr)
+        return $ Just ((n,h',r), addr)
+-}
+
+-- | The given address is taken to be the local address for the socket this JID
+-- came in on.  The returned JID parts are suitable for unsplitJID to create a
+-- valid JID for communicating to a client.  The returned Bool is True when the
+-- host part refers to this local host (i.e. it equals the given SockAddr).
+-- If there are multiple results, it will prefer one which is a member of the
+-- given list in the last argument.
+rewriteJIDForClient :: SockAddr -> Text -> [Text] -> IO (Bool,(Maybe Text,Text,Maybe Text))
+rewriteJIDForClient laddr jid buds = do
+    let (n,h,r) = splitJID jid
+    maddr <- parseAddress (strip_brackets h)
+    flip (maybe $ return (False,(n,ip6literal h,r))) maddr $ \addr -> do
+    let mine =  laddr `withPort` 0  == addr `withPort` 0
+    h' <- if mine then textHostName
+                  else peerKeyToResolvedName buds (PeerKey addr)
+    return (mine,(n,h',r))
+
+peerKeyToResolvedName :: [Text] -> ConnectionKey -> IO Text
+peerKeyToResolvedName buds k@(ClientKey { localAddress=addr }) = return "ErrorClIeNt1"
+peerKeyToResolvedName buds pk = do
+    ns <- peerKeyToResolvedNames pk
+    let hs = map (\jid -> let (_,h,_)=splitJID jid in h) buds
+        ns' = sortBy (comparing $ not . flip elem hs) ns
+    return $ maybe (peerKeyToText pk) id (listToMaybe ns')
+
+
+multiplyJIDForClient :: SockAddr -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)])
+multiplyJIDForClient laddr jid = do
+    let (n,h,r) = splitJID jid
+    maddr <- parseAddress (strip_brackets h)
+    flip (maybe $ return (False,[(n,ip6literal h,r)])) maddr $ \addr -> do
+    let mine =  sameAddress laddr addr
+    names <- if mine then fmap (:[]) textHostName
+                     else peerKeyToResolvedNames (PeerKey addr)
+    return (mine,map (\h' -> (n,h',r)) names)
+
+
+addrTextToKey :: Text -> IO (Maybe ConnectionKey)
+addrTextToKey h = do
+    maddr <- parseAddress (strip_brackets h)
+    return (fmap PeerKey maddr)
+
+guardPortStrippedAddress :: Text -> SockAddr -> IO (Maybe ())
+guardPortStrippedAddress h laddr = do
+    maddr <- fmap (fmap (`withPort` 0)) $ parseAddress (strip_brackets h)
+    let laddr' = laddr `withPort` 0
+    return $ maddr >>= guard . (==laddr')
+
+
+-- | Accepts a textual representation of a domainname
+-- JID suitable for client connections, and returns the
+-- coresponding ipv6 address JID suitable for peers paired
+-- with a SockAddr with the address part of that JID in
+-- binary form.  If no suitable address could be resolved
+-- for the given name, Nothing is returned.
+rewriteJIDForPeer :: Text -> IO (Maybe (Text,SockAddr))
+rewriteJIDForPeer jid = do
+    let (n,h,r) = splitJID jid
+    maddr <- fmap listToMaybe $ resolvePeer h
+    return $ flip fmap maddr $ \addr ->
+        let h' = addrToText addr
+            to' = unsplitJID (n,h',r)
+        in (to',addr)
+
+deliverToConsole :: PresenceState -> IO () -> Stanza -> IO ()
+deliverToConsole state fail msg = do
+    putStrLn $ "TODO: deliver to console"
+    did1 <- writeActiveTTY (consoleWriter state) msg
+    did2 <- writeAllPty (consoleWriter state) msg
+    if not (did1 || did2) then fail else return ()
+
+-- | deliver <message/> or error stanza
+deliverMessage :: PresenceState
+                -> IO ()
+                -> StanzaWrap (LockedChan Event)
+                -> IO ()
+deliverMessage state fail msg = 
+    case stanzaOrigin msg of
+      NetworkOrigin senderk@(ClientKey {}) _ -> do
+        -- Case 1.  Client -> Peer
+        mto <- do
+            flip (maybe $ return Nothing) (stanzaTo msg) $ \to -> do
+            rewriteJIDForPeer to
+        flip (maybe fail {- reverse lookup failure -})
+             mto
+            $ \(to',addr) -> do
+        let k = PeerKey addr
+        chans <- atomically $ readTVar (keyToChan state)
+        flip (maybe fail) (Map.lookup k chans) $ \(Conn { connChan=chan
+                                                        , auxAddr=laddr }) -> do
+        (n,r) <- forClient state senderk (return (Nothing,Nothing))
+                        $ \c -> return (Just (clientUser c), Just (clientResource c))
+        -- original 'from' address is discarded.
+        let from' = unsplitJID (n,addrToText laddr,r)
+        -- dup <- atomically $ cloneStanza (msg { stanzaTo=Just to', stanzaFrom=Just from' })
+        let dup = (msg { stanzaTo=Just to', stanzaFrom=Just from' })
+        sendModifiedStanzaToPeer dup chan
+      NetworkOrigin senderk@(PeerKey {}) _ -> do
+        key_to_chan <- atomically $ readTVar (keyToChan state)
+        flip (maybe fail) (Map.lookup senderk key_to_chan)
+            $ \(Conn { connChan=sender_chan
+                     , auxAddr=laddr }) -> do
+        flip (maybe fail) (stanzaTo msg) $ \to -> do
+        (mine,(n,h,r)) <- rewriteJIDForClient laddr to []
+        if not mine then fail else do
+        let to' = unsplitJID (n,h,r)
+        cmap <- atomically . readTVar $ clientsByUser state
+        (from',chans,ks) <- do
+            flip (maybe $ return (Nothing,[],[])) n $ \n -> do
+            buds <- configText ConfigFiles.getBuddies n
+            from' <- do
+                flip (maybe $ return Nothing) (stanzaFrom msg) $ \from -> do
+                (_,trip) <- rewriteJIDForClient laddr from buds
+                return . Just $ unsplitJID trip
+            let nope = return (from',[],[])
+            flip (maybe nope) (Map.lookup n cmap) $ \presence_container -> do
+            let ks = Map.keys (networkClients presence_container)
+                chans = mapMaybe (flip Map.lookup key_to_chan) ks
+            return (from',chans,ks)
+        putStrLn $ "chan count: " ++ show (length chans)
+        let msg' = msg { stanzaTo=Just to'
+                       , stanzaFrom=from' }
+        if null chans then deliverToConsole state fail msg' else do
+        forM_ chans $ \Conn { connChan=chan} -> do
+        putStrLn $ "sending "++show (stanzaId msg)++" to clients "++show ks
+        -- TODO: Cloning isn't really neccessary unless there are multiple
+        -- destinations and we should probably transition to minimal cloning,
+        -- or else we should distinguish between announcable stanzas and
+        -- consumable stanzas and announcables use write-only broadcast
+        -- channels that must be cloned in order to be consumed.
+        -- For now, we are doing redundant cloning.
+        dup <- cloneStanza msg'
+        sendModifiedStanzaToClient dup
+                                  chan
+
+
+setClientFlag :: PresenceState -> ConnectionKey -> Int8 -> IO ()
+setClientFlag state k flag = 
+    atomically $ do
+        cmap <- readTVar (clients state)
+        flip (maybe $ return ()) (Map.lookup k cmap) $ \client -> do
+        setClientFlag0 client flag
+
+setClientFlag0 :: ClientState -> Int8 -> STM ()
+setClientFlag0 client flag = 
+    modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag)
+
+informSentRoster :: PresenceState -> ConnectionKey -> IO ()
+informSentRoster state k = do
+    setClientFlag state k cf_interested
+
+
+subscribedPeers :: Text -> IO [SockAddr]
+subscribedPeers user = do
+    jids <- configText ConfigFiles.getSubscribers user
+    let hosts = map ((\(_,h,_)->h) . splitJID) jids
+    fmap Map.keys $ resolveAllPeers hosts 
+
+-- | this JID is suitable for peers, not clients.
+clientJID :: Conn -> ClientState -> Text
+clientJID con client = unsplitJID ( Just $ clientUser client
+                                  , addrToText $ auxAddr con
+                                  , Just $ clientResource client)
+
+-- | Send presence notification to subscribed peers.
+-- Note that a full JID from address will be added to the
+-- stanza if it is not present.
+informClientPresence :: PresenceState
+                        -> ConnectionKey -> StanzaWrap (LockedChan Event) -> IO ()
+informClientPresence state k stanza = do
+    forClient state k (return ()) $ \client -> do
+    informClientPresence0 state (Just k) client stanza
+
+informClientPresence0 :: PresenceState
+                       -> Maybe ConnectionKey
+                       -> ClientState
+                       -> StanzaWrap (LockedChan Event)
+                       -> IO ()
+informClientPresence0 state mbk client stanza = do
+    dup <- cloneStanza stanza
+    atomically $ writeTVar (clientStatus client) $ Just dup
+    is_avail <- atomically $ clientIsAvailable client
+    when (not is_avail) $ do
+        atomically $ setClientFlag0 client cf_available
+        maybe (return ()) (sendCachedPresence state) mbk
+    addrs <- subscribedPeers (clientUser client)
+    ktc <- atomically $ readTVar (keyToChan state)
+    let connected = mapMaybe (flip Map.lookup ktc . PeerKey) addrs
+    forM_ connected $ \con -> do
+    let from' = clientJID con client
+    mto <- runTraversableT $ do
+            to <- liftT $ stanzaTo stanza
+            (to',_) <- liftMT $ rewriteJIDForPeer to
+            return to'
+    dup <- cloneStanza stanza
+    sendModifiedStanzaToPeer dup { stanzaFrom = Just from'
+                                 , stanzaTo = mto }
+                             (connChan con)
+
+informPeerPresence :: PresenceState
+                    -> ConnectionKey
+                    -> StanzaWrap (LockedChan Event)
+                    -> IO ()
+informPeerPresence state k stanza = do
+    -- Presence must indicate full JID with resource...
+    putStrLn $ "xmppInformPeerPresence checking from address..." 
+    flip (maybe $ return ()) (stanzaFrom stanza) $ \from -> do
+    let (muser,h,mresource) = splitJID from
+    putStrLn $ "xmppInformPeerPresence from  = " ++ show from
+    -- flip (maybe $ return ()) mresource       $ \resource -> do
+    flip (maybe $ return ()) muser           $ \user -> do
+    
+    clients <- atomically $ do
+
+        -- Update remotesByPeer...
+        rbp <- readTVar (remotesByPeer state)
+        let umap = maybe Map.empty id $ Map.lookup k rbp
+            rp = case (presenceShow $ stanzaType stanza) of
+                    Offline ->
+                        maybe Map.empty
+                              (\resource -> 
+                                  maybe (Map.empty)
+                                     (Map.delete resource . resources)
+                                   $ Map.lookup user umap)
+                              mresource
+                    
+                    _ ->maybe Map.empty
+                              (\resource ->
+                                  maybe (Map.singleton resource stanza) 
+                                     (Map.insert resource stanza . resources )
+                                    $ Map.lookup user umap)
+                              mresource
+            umap' = Map.insert user (RemotePresence rp) umap
+        
+        flip (maybe $ return []) (case presenceShow $ stanzaType stanza of
+                                     Offline -> Just ()
+                                     _ -> mresource >> Just ())
+            $ \_ -> do
+        writeTVar (remotesByPeer state) $ Map.insert k umap' rbp
+        -- TODO: Store or delete the stanza (remotesByPeer)
+        
+        -- all clients, we'll filter available/authorized later
+
+        ktc <- readTVar (keyToChan state)
+        runTraversableT $ do
+        (ck,client) <- liftMT $ fmap Map.toList $ readTVar (clients state)
+        con <- liftMaybe $ Map.lookup ck ktc 
+        return (ck,con,client)
+    putStrLn $ "xmppInformPeerPresence (length clients="++show (length clients)++")"
+    forM_ clients $ \(ck,con,client) -> do
+        -- (TODO: appropriately authorized clients only.)
+        -- For now, all "available" clients (available = sent initial presence)
+        is_avail <- atomically $ clientIsAvailable client
+        when is_avail $ do
+        putStrLn $ "reversing for client: " ++ show from
+        froms <- do -- flip (maybe $ return [from]) k . const $ do
+            let ClientKey laddr = ck
+            (_,trip) <- multiplyJIDForClient laddr from
+            return (map unsplitJID trip)
+                    
+        putStrLn $ "sending to client: " ++ show (stanzaType stanza,froms)
+        forM_ froms $ \from' -> do
+        dup <- cloneStanza stanza
+        sendModifiedStanzaToClient (dup { stanzaFrom=Just from' })
+                                   (connChan con)
+
+answerProbe :: PresenceState
+             -> Maybe Text -> ConnectionKey -> TChan Stanza -> IO ()
+answerProbe state mto k chan = do
+    -- putStrLn $ "answerProbe! " ++ show (stanzaType stanza)
+    ktc <- atomically $ readTVar (keyToChan state)
+    muser <- runTraversableT $ do
+        to <- liftT $ mto
+        conn <- liftT $ Map.lookup k ktc
+        let (mu,h,_) = splitJID to -- TODO: currently resource-id is ignored on presence
+                                   --  probes.  Is this correct? Check the spec.
+        liftMT $ guardPortStrippedAddress h (auxAddr conn)
+        u <- liftT mu
+        let ch = addrToText (auxAddr conn)
+        return (u,conn,ch)
+
+    flip (maybe $ return ()) muser $ \(u,conn,ch) -> do
+
+    resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u
+    let gaddrs = groupBy (\a b -> snd a == snd b) (sort resolved_subs)
+        whitelist = do
+            xs <- gaddrs
+            x <- take 1 xs
+            guard $ snd x==k
+            mapMaybe fst xs
+
+    -- -- only subscribed peers should get probe replies
+    -- addrs <- subscribedPeers u
+
+    -- TODO: notify remote peer that they are unsubscribed?
+    --   reply <- makeInformSubscription "jabber:server" to from False
+    when (not $ null whitelist) $ do
+
+    replies <- runTraversableT $ do
+        cbu <- lift . atomically $ readTVar (clientsByUser state)
+        let lpres = maybeToList $ Map.lookup u cbu
+        cw <- lift . atomically $ readTVar (cwClients $ consoleWriter state)
+        clientState <- liftT $ (lpres >>= Map.elems . networkClients)
+                                ++ Map.elems cw
+        stanza <- liftIOMaybe $ atomically (readTVar (clientStatus clientState))
+        stanza <- lift $ cloneStanza stanza
+        let jid = unsplitJID (Just $ clientUser clientState
+                             , ch
+                             ,Just $ clientResource clientState)
+        return stanza { stanzaFrom = Just jid
+                      , stanzaType = (stanzaType stanza)
+                        { presenceWhiteList = whitelist }
+                      }
+
+    forM_ replies $ \reply -> do
+        sendModifiedStanzaToPeer reply chan
+
+    -- if no presence, send offline message
+    when (null replies) $ do
+        let jid = unsplitJID (Just u,ch,Nothing)
+        pstanza <- makePresenceStanza "jabber:server" (Just jid) Offline
+        atomically $ writeTChan (connChan conn) pstanza
+
+sendCachedPresence :: PresenceState -> ConnectionKey -> IO ()
+sendCachedPresence state k = do
+    forClient state k (return ()) $ \client -> do
+    rbp <- atomically $ readTVar (remotesByPeer state)
+    jids <- configText ConfigFiles.getBuddies (clientUser client)
+    let hosts = map ((\(_,h,_)->h) . splitJID) jids
+    addrs <- resolveAllPeers hosts 
+    let onlines = rbp `Map.intersection` Map.mapKeys PeerKey addrs
+        ClientKey laddr = k
+    mcon <- atomically $ do ktc <- readTVar (keyToChan state)
+                            return $ Map.lookup k ktc
+    flip (maybe $ return ()) mcon $ \con -> do
+    -- me <- textHostName
+    forM_ (Map.toList onlines) $ \(pk, umap) -> do
+        forM_ (Map.toList umap) $ \(user,rp) -> do
+        let h = peerKeyToText pk
+        forM_ (Map.toList $ resources rp) $ \(resource,stanza) -> do
+        let jid = unsplitJID (Just user,h,Just resource)
+        (mine,js) <- multiplyJIDForClient laddr jid
+        forM_ js $ \jid -> do
+        let from' = unsplitJID jid
+        dup <- cloneStanza stanza
+        sendModifiedStanzaToClient (dup { stanzaFrom=Just from' })
+                                   (connChan con)
+
+    pending <- configText ConfigFiles.getPending (clientUser client)
+    hostname <- textHostName
+    forM_ pending $ \pending_jid -> do
+        let cjid = unsplitJID ( Just $ clientUser client
+                              , hostname
+                              , Nothing )
+        ask <- presenceSolicitation pending_jid cjid
+        sendModifiedStanzaToClient ask (connChan con)
+
+    -- Note: relying on self peer connection to send
+    -- send local buddies.
+    return ()
+
+addToRosterFile :: (MonadPlus t, Traversable t) =>
+                 (L.ByteString -> (L.ByteString -> IO (t L.ByteString))
+                  -> Maybe L.ByteString
+                  -> t1)
+                 -> Text -> Text -> [SockAddr] -> t1
+addToRosterFile doit whose to addrs =
+    modifyRosterFile doit whose to addrs True
+
+removeFromRosterFile :: (MonadPlus t, Traversable t) =>
+                      (L.ByteString -> (L.ByteString -> IO (t L.ByteString))
+                       -> Maybe L.ByteString
+                       -> t1)
+                      -> Text -> Text -> [SockAddr] -> t1
+removeFromRosterFile doit whose to addrs =
+    modifyRosterFile doit whose to addrs False
+
+modifyRosterFile :: (Traversable t, MonadPlus t) =>
+                  (L.ByteString -> (L.ByteString -> IO (t L.ByteString))
+                   -> Maybe L.ByteString
+                   -> t1)
+                  -> Text -> Text -> [SockAddr] -> Bool -> t1
+modifyRosterFile doit whose to addrs bAdd = do
+    let (mu,_,_) = splitJID to
+        cmp jid = runTraversableT $ do
+            let (msu,stored_h,mr) = splitJID (lazyByteStringToText jid)
+            -- Delete from file if a resource is present in file
+            (\f -> maybe f (const mzero) mr) $ do
+            -- Delete from file if no user is present in file
+            flip (maybe mzero) msu $ \stored_u -> do
+            -- do not delete anything if no user was specified
+            flip (maybe $ return jid) mu $ \u -> do
+            -- do not delete if stored user is same as specified
+            if stored_u /= u then return jid else do
+            stored_addrs <- lift $ resolvePeer stored_h
+            -- do not delete if failed to resolve
+            if null stored_addrs then return jid else do
+            -- delete if specified address matches stored
+            if null (stored_addrs \\ addrs) then mzero else do
+            -- keep
+            return jid
+    doit (textToLazyByteString whose)
+         cmp
+         (guard bAdd >> Just (textToLazyByteString to))
+
+clientSubscriptionRequest :: PresenceState -> IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO ()
+clientSubscriptionRequest state fail k stanza chan = do
+    forClient state k fail $ \client -> do
+    flip (maybe fail) (stanzaTo stanza) $ \to -> do
+    putStrLn $ "Forwarding solictation to peer"
+    let (mu,h,_) = splitJID to
+    to <- return $ unsplitJID (mu,h,Nothing) -- delete resource
+    flip (maybe fail) mu $ \u -> do
+    addrs <- resolvePeer h
+    if null addrs then fail else do
+    -- add to-address to from's solicited
+    addToRosterFile ConfigFiles.modifySolicited (clientUser client) to addrs
+    removeFromRosterFile ConfigFiles.modifyBuddies (clientUser client) to addrs
+    resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers (clientUser client)
+    let is_subscribed = not . null $ intersect (map ((mu,).PeerKey) addrs) resolved_subs
+    -- subscribers: "from"
+    -- buddies: "to"
+
+    (ktc,ap) <- atomically $ 
+        liftM2 (,) (readTVar $ keyToChan state)
+                   (readTVar $ associatedPeers state)
+    
+    case stanzaType stanza of
+     PresenceRequestSubscription True -> do
+        hostname <- textHostName
+        let cjid = unsplitJID (Just $ clientUser client, hostname,Nothing)
+        chans <- clientCons state ktc (clientUser client)
+        forM_ chans $ \( Conn { connChan=chan }, client ) -> do
+            -- roster update ask="subscribe"
+            update <- makeRosterUpdate cjid to
+                [ ("ask","subscribe")
+                , if is_subscribed then ("subscription","from")
+                                   else ("subscription","none")
+                ]
+            sendModifiedStanzaToClient update chan
+     _ -> return ()
+
+    let dsts = Map.fromList $ map ((,()) . PeerKey) addrs
+        cdsts = ktc `Map.intersection` dsts
+    forM_ (Map.toList cdsts) $ \(pk,con) -> do
+        -- if already connected, send solicitation ...
+        -- let from = clientJID con client
+        let from = unsplitJID ( Just $ clientUser client
+                              , addrToText $ auxAddr con
+                              , Nothing )
+        mb <- rewriteJIDForPeer to
+        flip (maybe $ return ()) mb $ \(to',addr) -> do
+        dup <- cloneStanza stanza
+        sendModifiedStanzaToPeer (dup { stanzaTo = Just to'
+                                      , stanzaFrom = Just from })
+                                 (connChan con)
+    let addrm = Map.fromList (map (,()) addrs)
+    when (not . Map.null $ addrm Map.\\ ap) $ do
+        -- Add peer if we are not already associated ...
+        sv <- atomically $ takeTMVar $ server state
+        addPeer sv (head addrs)
+        atomically $ putTMVar (server state) sv
+
+
+resolvedFromRoster
+  :: (L.ByteString -> IO [L.ByteString])
+     -> UserName -> IO [(Maybe UserName, ConnectionKey)]
+resolvedFromRoster doit u = do
+    subs <- configText doit u
+    runTraversableT $ do
+            (mu,h,_) <- liftT $ splitJID `fmap` subs
+            addr <- liftMT $ fmap nub $ resolvePeer h
+            return (mu,PeerKey addr)
+
+clientCons :: PresenceState
+            -> Map ConnectionKey t -> Text -> IO [(t, ClientState)]
+clientCons state ktc u = do
+    mlp <- atomically $ do
+            cmap <- readTVar $ clientsByUser state
+            return $ Map.lookup u cmap
+    let ks = do lp <- maybeToList mlp
+                Map.toList (networkClients lp)
+        doit (k,client) = do
+            con <- Map.lookup k ktc
+            return (con,client)
+    return $ mapMaybe doit ks
+
+peerSubscriptionRequest :: PresenceState -> IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO ()
+peerSubscriptionRequest state fail k stanza chan = do
+    putStrLn $ "Handling pending subscription from remote"
+    flip (maybe fail) (stanzaFrom stanza) $ \from -> do
+    flip (maybe fail) (stanzaTo stanza) $ \to -> do
+    let (mto_u,h,_) = splitJID to
+        (mfrom_u,from_h,_) = splitJID from
+    to <- return $ unsplitJID (mto_u,h,Nothing) -- delete resource
+    from <- return $ unsplitJID (mfrom_u,from_h,Nothing) -- delete resource
+    ktc <- atomically . readTVar $ keyToChan state
+    flip (maybe fail) (Map.lookup k ktc)
+         $ \Conn { auxAddr=laddr } -> do
+    (mine,totup) <- rewriteJIDForClient laddr to []
+    if not mine then fail else do
+    (_,fromtup) <- rewriteJIDForClient laddr from []
+    flip (maybe fail) mto_u $ \u -> do
+    flip (maybe fail) mfrom_u $ \from_u -> do
+    resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u
+    let already_subscribed = elem (mfrom_u,k) resolved_subs
+        is_wanted = case stanzaType stanza of
+                      PresenceRequestSubscription b -> b
+                      _ -> False -- Shouldn't happen.
+    --    Section 8 says (for presence of type "subscribe", the server MUST
+    --    adhere to the rules defined under Section 3 and summarized under
+    --    see Appendix A. (pariticularly Appendex A.3.1)
+    if already_subscribed == is_wanted
+     then do
+        -- contact ∈ subscribers --> SHOULD NOT, already handled
+        -- already subscribed, reply and quit
+        -- (note: swapping to and from for reply)
+        reply <- makeInformSubscription "jabber:server" to from is_wanted
+        sendModifiedStanzaToPeer reply chan
+        answerProbe state (Just to) k chan
+     else do
+
+    -- TODO: if peer-connection is to self, then auto-approve local user.
+    
+    -- add from-address to to's pending
+    addrs <- resolvePeer from_h
+
+    -- Catch exception in case the user does not exist
+    if null addrs then fail else do
+
+    let from' = unsplitJID fromtup
+
+    already_pending <-
+      if is_wanted then
+        addToRosterFile ConfigFiles.modifyPending u from' addrs
+      else do
+        removeFromRosterFile ConfigFiles.modifySubscribers u from' addrs
+        reply <- makeInformSubscription "jabber:server" to from is_wanted
+        sendModifiedStanzaToPeer reply chan
+        return False
+
+    -- contact ∉ subscribers & contact ∈ pending --> SHOULD NOT
+    when (not already_pending) $ do
+    -- contact ∉ subscribers & contact ∉ pending --> MUST
+
+    chans <- clientCons state ktc u
+    forM_ chans $ \( Conn { connChan=chan }, client ) -> do
+    -- send to clients
+    -- TODO: interested/available clients only?
+    dup <- cloneStanza stanza
+    sendModifiedStanzaToClient dup { stanzaFrom = Just $ from'
+                                   , stanzaTo = Just $ unsplitJID totup }
+                               chan
+
+
+clientInformSubscription :: PresenceState
+                          -> IO ()
+                          -> ConnectionKey
+                          -> StanzaWrap (LockedChan Event)
+                          -> IO ()
+clientInformSubscription state fail k stanza = do
+    forClient state k fail $ \client -> do
+    flip (maybe fail) (stanzaTo stanza) $ \to -> do
+    putStrLn $ "clientInformSubscription"
+    let (mu,h,mr) = splitJID to
+    addrs <- resolvePeer h
+    -- remove from pending
+    buds <- resolvedFromRoster ConfigFiles.getBuddies (clientUser client)
+    let is_buddy = not . null $ map ((mu,) . PeerKey) addrs `intersect` buds
+    removeFromRosterFile ConfigFiles.modifyPending (clientUser client) to addrs
+    let (relationship,addf,remf) =
+         case stanzaType stanza of
+           PresenceInformSubscription True ->
+                ( ("subscription", if is_buddy then "both"
+                                               else "from" )
+                , ConfigFiles.modifySubscribers
+                , ConfigFiles.modifyOthers )
+           _ -> ( ("subscription", if is_buddy then "to"
+                                               else "none" )
+                , ConfigFiles.modifyOthers
+                , ConfigFiles.modifySubscribers )
+    addToRosterFile      addf (clientUser client) to addrs
+    removeFromRosterFile remf (clientUser client) to addrs
+
+    do
+        cbu <- atomically $ readTVar (clientsByUser state)
+        putStrLn $ "cbu = " ++ show (fmap (fmap clientPid . networkClients) cbu)
+
+    -- send roster update to clients
+    (clients,ktc) <- atomically $ do
+        cbu <- readTVar (clientsByUser state)
+        let mlp = Map.lookup (clientUser client) cbu
+        let cs = maybe [] (Map.toList . networkClients) mlp
+        ktc <- readTVar (keyToChan state)
+        return (cs,ktc)
+    forM_ clients $ \(ck, client) -> do
+        is_intereseted <- atomically $ clientIsInterested client
+        putStrLn $ "clientIsInterested: "++show is_intereseted
+        is_intereseted <- atomically $ clientIsInterested client
+        when is_intereseted $ do
+        flip (maybe $ return ()) (Map.lookup ck ktc) $ \con -> do
+        hostname <- textHostName
+        -- TODO: Should cjid include the resource?
+        let cjid = unsplitJID (mu, hostname, Nothing)
+        update <- makeRosterUpdate cjid to [relationship]
+        sendModifiedStanzaToClient update (connChan con)
+
+    -- notify peer
+    let dsts = Map.fromList $ map ((,()) . PeerKey) addrs
+        cdsts = ktc `Map.intersection` dsts
+    forM_ (Map.toList cdsts) $ \(pk,con) -> do
+        let from = clientJID con client
+            to' = unsplitJID (mu, peerKeyToText pk, Nothing)
+        dup <- cloneStanza stanza
+        sendModifiedStanzaToPeer (dup { stanzaTo = Just $ to'
+                                      , stanzaFrom = Just from })
+                                 (connChan con)
+        answerProbe state (Just from) pk (connChan con)
+    
+peerInformSubscription :: PresenceState
+                        -> IO ()
+                        -> ConnectionKey
+                        -> StanzaWrap (LockedChan Event)
+                        -> IO ()
+peerInformSubscription state fail k stanza = do
+    putStrLn $ "TODO: peerInformSubscription"
+    -- remove from solicited
+    flip (maybe fail) (stanzaFrom stanza) $ \from -> do
+    ktc <- atomically $ readTVar (keyToChan state)
+    flip (maybe fail) (Map.lookup k ktc)
+        $ \(Conn { connChan=sender_chan
+                 , auxAddr=laddr }) -> do
+    (_,(from_u,from_h,_)) <- rewriteJIDForClient laddr from []
+    let from'' = unsplitJID (from_u,from_h,Nothing)
+        muser = do
+            to <- stanzaTo stanza
+            let (mu,to_h,to_r) = splitJID to
+            mu
+    -- TODO muser = Nothing when wanted=False
+    -- should probably mean unsubscribed for all users.
+    -- This would allow us to answer anonymous probes with 'unsubscribed'.
+    flip (maybe fail) muser $ \user -> do
+    addrs <- resolvePeer from_h
+    was_solicited <- removeFromRosterFile ConfigFiles.modifySolicited user from'' addrs
+    subs <- resolvedFromRoster ConfigFiles.getSubscribers user
+    let is_sub = not . null $ map ((from_u,) . PeerKey) addrs `intersect` subs
+    let (relationship,addf,remf) =
+         case stanzaType stanza of
+           PresenceInformSubscription True ->
+                ( ("subscription", if is_sub then "both"
+                                             else "to" )
+                , ConfigFiles.modifyBuddies
+                , ConfigFiles.modifyOthers )
+           _ -> ( ("subscription", if is_sub then "from"
+                                             else "none")
+                , ConfigFiles.modifyOthers
+                , ConfigFiles.modifyBuddies )
+    addToRosterFile      addf user from'' addrs
+    removeFromRosterFile remf user from'' addrs
+
+    hostname <- textHostName
+    let to' = unsplitJID (Just user, hostname, Nothing)
+    chans <- clientCons state ktc user
+    forM_ chans $ \(Conn { connChan=chan }, client) -> do
+    update <- makeRosterUpdate to' from'' [relationship]
+    is_intereseted <- atomically $ clientIsInterested client
+    when is_intereseted $ do
+        sendModifiedStanzaToClient update chan
+    -- TODO: interested/availabe clients only?
+    dup <- cloneStanza stanza
+    sendModifiedStanzaToClient dup { stanzaFrom = Just $ from''
+                                   , stanzaTo = Just to' }
+                               chan