path: root/dht/Presence/Presence.hs

{-# LANGUAGE CPP                       #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE LambdaCase                #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE TupleSections             #-}
module Presence where

import System.Directory
import System.IO.Error
#ifndef THREAD_DEBUG
import Control.Concurrent
#else
import Control.Concurrent.Lifted.Instrument
#endif

import Control.Arrow
import Control.Concurrent.STM
import Control.Monad.Trans
import Network.Socket ( SockAddr(..) )
import Data.Char
import Data.List (nub, (\\), intersect, groupBy, sort, sortBy, isSuffixOf )
import Data.Ord (comparing )
import Data.Monoid ((<>))
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Control.Monad
import Data.Text (Text)
import qualified Data.Map as Map
import Data.Map (Map)
import Control.Exception ({-evaluate,-}handle,SomeException(..))
import System.Posix.User (getUserEntryForID,userName)
import qualified Data.ByteString.Lazy.Char8 as L
import qualified ConfigFiles
import Data.Maybe
import Data.Bits
import Data.Int (Int8)
import Data.XML.Types as XML (Event, Name)
import System.Posix.Types (UserID,CPid)
import Control.Applicative
import Crypto.PubKey.Curve25519 (SecretKey,toPublic)

import ControlMaybe
import DNSCache (parseAddress, strip_brackets, withPort)
import LockedChan (LockedChan)
import Text.Read (readMaybe)
import UTmp (ProcessID,users)
import LocalPeerCred
import XMPPServer
import ConsoleWriter
import ClientState
import Util
import qualified Connection
         ;import Connection (PeerAddress (..), resolvePeer, reverseAddress)
import Network.Tox.NodeId (key2id,parseNoSpamId,nospam64,NoSpamId(..),ToxProgress,ToxContact(..))
import Crypto.Tox (decodeSecret,encodeSecret, generateSecretKey, stripSuffix)
import DPut
import DebugTag

{-
isPeerKey :: ClientAddress -> Bool
isPeerKey k = case k of { PeerKey {} -> True ; _ -> False }

isClientKey :: ClientAddress -> Bool
isClientKey k = case k of { ClientKey {} -> True ; _ -> False }
-}

localJID :: Text -> Text -> Text -> IO Text
localJID user "." resource = do
    hostname <- textHostName
    return $ user <> "@" <> hostname <> "/" <> resource
localJID user profile resource =
    return $ user <> "@" <> profile <> "/" <> resource

-- | These hooks will be invoked in order to connect to *.tox hosts in the
-- user's roster.
--
-- The parameter k is a lookup key corresponding to an XMPP client.  Each
-- unique value should be able to hold a reference to the ToxID identity which
-- should stay online until all interested keys have run 'deactivateAccount'.
data ToxManager k = ToxManager
    { -- | Put the given ToxID online.
      activateAccount        :: k -> Text -> SecretKey -> IO ()
      -- | Take the given ToxID offline (assuming no other /k/ has a claim).
    , deactivateAccount      :: k -> Text -> IO ()
    , toxConnections :: Connection.Manager ToxProgress ToxContact
      -- | Given a remote Tox key, return the address of a connected peer.
      --
      -- The arguments are our public key (in base64 format) followed by
      -- their public key (in base64 format).
    , resolveToxPeer         :: Text -> Text -> IO (Maybe PeerAddress)
    }

type ClientProfile = Text

data PresenceState status = PresenceState
    { clients         :: TVar (Map ClientAddress ClientState)
    , clientsByUser   :: TVar (Map Text LocalPresence)
    , clientsByProfile :: TVar (Map Text LocalPresence)
    , remotesByPeer   :: TVar (Map PeerAddress
                                   (Map UserName RemotePresence))
    , server          :: XMPPServer
    , manager         :: ClientProfile -> Connection.Manager status Text
    , ckeyToChan       :: TVar (Map ClientAddress Conn)
    , pkeyToChan       :: TVar (Map PeerAddress Conn)
    , consoleWriter   :: Maybe ConsoleWriter
    , toxManager      :: Maybe (ToxManager ClientAddress)
    }


newPresenceState :: Maybe ConsoleWriter
                 -> Maybe (PresenceState status -> ToxManager ClientAddress)
                 -> XMPPServer
                 -> (ClientProfile -> Connection.Manager status Text)
                 -> IO (PresenceState status)
newPresenceState cw toxman sv man = atomically $ do
        clients          <- newTVar Map.empty
        clientsByUser    <- newTVar Map.empty
        clientsByProfile <- newTVar Map.empty
        remotesByPeer    <- newTVar Map.empty
        ckeyToChan       <- newTVar Map.empty
        pkeyToChan       <- newTVar Map.empty
        let st = PresenceState
                    { clients          = clients
                    , clientsByUser    = clientsByUser
                    , clientsByProfile = clientsByProfile
                    , remotesByPeer    = remotesByPeer
                    , ckeyToChan       = ckeyToChan
                    , pkeyToChan       = pkeyToChan
                    , server           = sv
                    , manager          = man
                    , consoleWriter    = cw
                    , toxManager       = Nothing
                    }
        return $ st { toxManager = fmap ($ st) toxman }


nameForClient' :: PresenceState stat -> Maybe Text -> Maybe Text -> ClientAddress -> IO Text
nameForClient' state mbNameForMe mbTheirName k = do
    mc <- atomically $ do
        cmap <- readTVar (clients state)
        return $ Map.lookup k cmap
    case mc of
        Nothing -> textHostName -- TODO: We can use mbNameForMe to initialize the clientProfile
        Just client -> case clientProfile client of
            "."     -> textHostName
            profile -> return profile

nameForClient :: PresenceState stat -> ClientAddress -> IO Text
nameForClient state k = nameForClient' state Nothing Nothing k


presenceHooks :: PresenceState stat -> Map Text MUC
                                      -> Int
                                      -> Maybe SockAddr -- ^ client-to-server bind address
                                      -> Maybe SockAddr -- ^ server-to-server bind address
                                      -> XMPPServerParameters
presenceHooks state chats verbosity mclient mpeer = XMPPServerParameters
    { xmppChooseResourceName        = chooseResourceName state
    , xmppTellClientHisName         = tellClientHisName state
    , xmppTellMyNameToClient        = nameForClient' state
    , xmppTellMyNameToPeer          = \(Local addr) -> return $ addrToText addr
    , xmppTellPeerHisName           = return . peerKeyToText
    , 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
    , xmppGroupChat                 = chats {- Map.singleton "chat" chat
        { mucRoomList      = return [("testroom",Just "testroom")]
        , mucRoomOccupants = \case
            "testroom" -> return [("fakeperson",Nothing)]
            _          -> return []
        , mucReservedNick = \case
            "testroom" -> return $ Just (return . Just)
            _          -> return Nothing
        , mucJoinRoom = \room nick caddr stanza -> do
            who <- tellClientHisName state caddr
            dput XJabber $ Text.unpack who ++ " joined " ++ Text.unpack room
                            ++ " with nick: " ++ Text.unpack nick
            -- TODO: broadcast presence to all participants.
            -- See 7.2.3 of XEP-0045
        -}
    , xmppClientBind                = mclient
    , xmppPeerBind                  = mpeer
    }


data LocalPresence = LocalPresence
    { networkClients :: Map ClientAddress ClientState
    -- TODO: loginClients
    }

data RemotePresence = RemotePresence
    { resources :: Map ResourceName Stanza
    -- , localSubscribers :: Map Text ()
    -- ^ subset of clientsByUser who should be
    -- notified about this presence.
    }



pcSingletonNetworkClient :: ClientAddress -> ClientState -> LocalPresence
pcSingletonNetworkClient key client =
    LocalPresence
    { networkClients = Map.singleton key client
    }

pcInsertNetworkClient :: ClientAddress -> ClientState -> LocalPresence -> LocalPresence
pcInsertNetworkClient key client pc =
    pc { networkClients = Map.insert key client (networkClients pc) }

pcRemoveNewtworkClient :: ClientAddress
                        -> 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)



getConsolePids :: PresenceState stat -> 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)


generateToxProfile :: Text -> IO ConfigFiles.Profile
generateToxProfile user0 = do
    secret <- generateSecretKey
    let pubkey = show $ key2id $ toPublic secret
        Just s = L.fromStrict <$> encodeSecret secret
        profile = pubkey ++ ".tox"
        user = L.fromChunks [Text.encodeUtf8 user0]
    ConfigFiles.configPath user profile ConfigFiles.secretsFile >>= ConfigFiles.addItem s "<? secret ?>"
    dput XMisc $ "Generated new Tox key " ++ profile
    return profile


autoSelectToxProfile :: Text -> IO (Maybe ConfigFiles.Profile)
autoSelectToxProfile user = do
    ps <- filter (isSuffixOf ".tox") <$> ConfigFiles.getProfiles (L.fromChunks [Text.encodeUtf8 user])
    case ps of
        [profile] -> return $ Just profile
        []        -> Just <$> generateToxProfile user
        _         -> return Nothing

chooseProfile :: Text -> Bool -> ClientAddress -> Maybe (Text, ToxManager ClientAddress) -> IO (Either Text ConfigFiles.Profile)
chooseProfile user allowNonTox k wanted_profile0 = do
        let doAuto = do
                p <- autoSelectToxProfile user
                case p of Nothing -> return $ Left "Tox user-id is ambiguous."
                          Just pr -> chooseProfile user allowNonTox k
                                        (Just (Text.pack pr, snd $ fromJust wanted_profile0))
        case stripSuffix ".tox" =<< fmap fst wanted_profile0 of
            Just "auto" -> doAuto
            Just pub -> do
                cdir <- ConfigFiles.configPath (L.fromChunks [Text.encodeUtf8 user]) "." ""
                cfs  <- map Text.pack <$> listDirectory cdir `catchIOError` (\e -> return [])
                let Just (wanted_profile1,toxman) = wanted_profile0
                    profiles = filter (\f -> Text.toLower f == Text.toLower wanted_profile1) cfs
                -- dput XMisc $ "Toxmpp profile " ++ show (user,wanted_profile0,profiles,cfs)
                let wanted_profile = head $ profiles ++ [wanted_profile1]
                secs <- configText ConfigFiles.getSecrets user wanted_profile
                case secs of
                    sec:_ | Just s <- decodeSecret (Text.encodeUtf8 sec)
                          , map toLower (show $ key2id $ toPublic s) == map toLower (Text.unpack pub)
                          -> do activateAccount toxman k wanted_profile s
                                dput XMisc $ "loaded tox secret " ++ show sec
                                return $ Right $ Text.unpack wanted_profile
                    _     -> do
                            -- XXX: We should probably fail to connect when an
                            -- invalid Tox profile is used.  For now, we'll
                            -- fall back to the Unix account login.
                            dput XMisc "failed to find tox secret"
                            return $ Left $ "Missing secret key for " <> pub
            Nothing | allowNonTox -> return $ Right "."
                    | otherwise   -> doAuto

chooseResourceName :: PresenceState stat
                    -> ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO (Either Text Text)
chooseResourceName state k (Remote addr) clientsNameForMe desired = do
    muid <- getLocalPeerCred' addr
    (mtty,pid) <- getTTYandPID muid
    user <- getJabberUserForId muid
    status <- atomically $ newTVar Nothing
    flgs <- atomically $ newTVar 0
    let mprofspec = (,) <$> clientsNameForMe <*> toxManager state
    eprofile <- chooseProfile user False k mprofspec
    case eprofile of

        Right profile -> do
            let client = ClientState { clientResource = maybe "fallback" id mtty
                                     , clientUser     = user
                                     , clientProfile  = Text.pack profile
                                     , 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) (clientProfile client)
               forM_ buds $ \bud -> do
                    let (_,h,_) = splitJID bud
                    forkLabeled "XMPP.buddies.resolvePeer" $ do
                        void $ resolvePeer (manager state $ clientProfile client) h

            atomically $ do
                modifyTVar' (clients state) $ Map.insert k client
                let add mb = Just $ maybe (pcSingletonNetworkClient k client)
                                          (pcInsertNetworkClient k client)
                                          mb
                modifyTVar' (clientsByUser    state) $ Map.alter add (clientUser client)
                modifyTVar' (clientsByProfile state) $ Map.alter add (clientProfile client)

            Right <$> localJID (clientUser client) (clientProfile client) (clientResource client)

        Left e -> return $ Left e

  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

-- Perform action with 'ClientState' associated with the given 'ClientAddress'.
-- If there is no associated 'ClientState', then perform the supplied fallback
-- action.
forClient :: PresenceState stat -> ClientAddress -> 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 stat -> ClientAddress -> IO Text
tellClientHisName state k = forClient state k fallback go
 where
    fallback  = localJID "nobody" "." "fallback"
    go client = localJID (clientUser client) (clientProfile client) (clientResource client)

toMapUnit :: Ord k => [k] -> Map k ()
toMapUnit xs = Map.fromList $ map (,()) xs

resolveAllPeers :: Connection.Manager stat Text -> [Text] -> IO (Map PeerAddress ())
resolveAllPeers man hosts = fmap (toMapUnit . concat) $ Prelude.mapM (fmap (take 1) . resolvePeer man) hosts


-- Read a roster file and start trying to connect to all relevent peers.
rosterGetStuff
  :: (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString])
     -> PresenceState stat -> ClientAddress -> IO [Text]
rosterGetStuff what state k = forClient state k (return [])
    $ \client -> do
    jids0 <- configText what (clientUser client) (clientProfile client)
    let jids = map splitJID jids0
    -- Using case to bring 'status' type variable to Connection.Manager into scope.
    case state of
      PresenceState { server = sv } -> do
        let conns = manager state $ clientProfile client
        -- Grok peers to associate with from the roster:
        let isTox = do me <- stripSuffix ".tox" (clientProfile client)
                       return me
            noToxUsers (u,h,r)
                | Text.isSuffixOf ".tox" h = unsplitJID (Nothing,h,r)
                | otherwise                = unsplitJID (u,h,r)
        forM_ jids $ \(_,host,_) -> do
            -- We need either conns  :: Connection.Manager TCPStatus Text
            --             or toxman :: ToxManager ClientAddress
            -- It is decided by checking hostnames for .tox ending.
            let policySetter = fromMaybe (Connection.setPolicy conns host) $ do
                    isTox
                    toxman <- toxManager state
                    them <- stripSuffix ".tox" host
                    prof <- stripSuffix ".tox" (clientProfile client)
                    meid   <- readMaybe $ Text.unpack prof
                    themid <- readMaybe $ Text.unpack them
                    return $ Connection.setPolicy (toxConnections toxman)
                                                  (ToxContact meid themid)
            policySetter Connection.TryingToConnect
        return $ fromMaybe jids0 $ do isTox
                                      Just $ map noToxUsers jids

rosterGetBuddies :: PresenceState stat -> ClientAddress -> IO [Text]
rosterGetBuddies state k = rosterGetStuff ConfigFiles.getBuddies state k

rosterGetSolicited :: PresenceState stat -> ClientAddress -> IO [Text]
rosterGetSolicited = rosterGetStuff ConfigFiles.getSolicited

-- XXX: Should we be connecting to these peers?
rosterGetOthers :: PresenceState stat -> ClientAddress -> IO [Text]
rosterGetOthers = rosterGetStuff ConfigFiles.getOthers

rosterGetSubscribers :: PresenceState stat -> ClientAddress -> IO [Text]
rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers

data Conn = Conn { connChan :: TChan Stanza
                 , auxData  :: ConnectionData }

-- Read config file as Text content rather than UTF8 bytestrings.
configText :: Functor f =>
            (ConfigFiles.User -> ConfigFiles.Profile -> f [L.ByteString])
            -> Text     -- user
            -> Text     -- profile
            -> f [Text] -- items
configText what u p = fmap (map lazyByteStringToText)
                        $ what (textToLazyByteString u) (Text.unpack p)

getBuddies' :: Text -> Text -> IO [Text]
getBuddies' = configText ConfigFiles.getBuddies
getSolicited' :: Text -> Text -> IO [Text]
getSolicited' = configText ConfigFiles.getSolicited

-- | Obtain from roster all buddies and pending buddies (called solicited
-- regardless of whether we've yet delivered a friend-request) matching the
-- supplied side-effecting predicate.
--
-- Returned tuple:
--
--   * Bool - True if buddy (should send probe).
--            False if solicited (should send friend-request).
--
--   * Maybe Username - Username field of contact.
--
--   * Text - Unix user who owns this roster entry.
--
--   * Text - Hostname as it appears in roster.
--
getBuddiesAndSolicited :: PresenceState stat
                         -> Text              -- ^ Config profile: "." or tox host.
                         -> (Text -> IO Bool) -- ^ Return True if you want this hostname.
                         -> IO [(Bool, Maybe UserName, Text, Text)]
getBuddiesAndSolicited state profile pred
    -- XXX: The following O(n²) nub may be a little
    --      too onerous.
    = fmap nub $ do
        cbu <- atomically $ readTVar $ clientsByUser state
        fmap concat $ sequence $ do
            (user,LocalPresence cmap) <- Map.toList cbu
            (isbud, getter) <- [(True ,getBuddies'  )
                               ,(False,getSolicited')]
            return $ do
                buds <- map splitJID <$> getter user profile
                fmap concat $ forM buds $ \(u,h,r) -> do
                interested <- pred h
                if interested
                    then return [(isbud,u,user,h)]
                    else return []

sendProbesAndSolicitations :: PresenceState stat -> PeerAddress -> Local SockAddr -> TChan Stanza -> IO ()
sendProbesAndSolicitations state k (Local laddr) chan = do
    prof <- atomically $ do
        pktc <- readTVar (pkeyToChan state)
        return $ maybe "." (cdProfile . auxData) $  Map.lookup k pktc
    -- get all buddies & solicited matching k for all users
    xs <- getBuddiesAndSolicited state prof $ \case
        h | ".tox" `Text.isSuffixOf` h -> return False -- Tox probes/solicitations are handled in ToxToXMPP module.
        h -> do
            addrs <- nub <$> resolvePeer (manager state $ prof) h
            return $ k `elem` addrs -- Roster item resolves to /k/ peer.
    forM_ xs $ \(isbud,u,user,h) -> do
        let make = if isbud then presenceProbe
                            else presenceSolicitation
            toh = peerKeyToText k
            jid = unsplitJID (u,toh,Nothing)
            me = addrToText laddr -- xmppTellMyNameToPeer
            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.
        dput XJabber $ "probing "++show k++" for: " ++ show (isbud,jid)
        atomically $ writeTChan chan stanza
    -- reverse xs `seq` return ()


newConn :: PresenceState stat -> SockAddr -> ConnectionData -> TChan Stanza -> IO ()
newConn state saddr cdta outchan =
    case classifyConnection saddr cdta of
        Left (pkey,laddr) -> do
            atomically $ modifyTVar' (pkeyToChan state)
                $ Map.insert pkey Conn { connChan = outchan
                                       , auxData  = cdta }
            sendProbesAndSolicitations state pkey laddr outchan
        Right (ckey,_) -> do
            atomically $ modifyTVar' (ckeyToChan state)
                $ Map.insert ckey Conn { connChan = outchan
                                       , auxData  = cdta }

delclient :: (Alternative m, Monad m) =>
           ClientAddress -> 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 stat -> SockAddr -> ConnectionData -> IO ()
eofConn state saddr cdta = do
    case classifyConnection saddr cdta of
        Left (k,_) -> do
            h <- case cdType cdta of
                -- TODO: This should be cached (perhaps by rewriteJIDForClient?) so that we
                -- guarantee that the OFFLINE message matches the ONLINE message.
                -- For now, we reverse-resolve the peer key.
                XMPP -> -- For XMPP peers, informPeerPresence expects a textual
                        -- representation of the IP address to reverse-resolve.
                        return $ peerKeyToText k
                Tox  -> do
                    -- For Tox peers, informPeerPresence expects the actual hostname
                    -- so we will use the one that the peer told us at greeting time.
                    m <- atomically $ swapTVar (cdRemoteName cdta) Nothing
                    case m of
                        Nothing -> do
                            dput XJabber $ "BUG: Tox peer didn't inform us of its name."
                            -- The following fallback behavior is probably wrong.
                            return $ peerKeyToText k
                        Just toxname -> return toxname
            -- ioToSource terminated.
            --
            -- dhtd: Network.Socket.getAddrInfo
            --   (called with preferred socket type/protocol: AddrInfo
            --      { addrFlags = [AI_NUMERICHOST], addrFamily = AF_UNSPEC
            --      , addrSocketType = NoSocketType, addrProtocol = 0
            --      , addrAddress = <assumed to be undefined>
            --      , addrCanonName = <assumed to be undefined>}
            --      , host name: Just "DdhbLjiwaV0GAiGKgesNPbvj2TbhrBHEWEEc5icfvQN.tox"
            --      , service name: Just "0")
            --      : does not exist (Name or service not known)

            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)
                    let excludeEmpty "" = Nothing
                        excludeEmpty x  = Just x
                    return $ unsplitJID (excludeEmpty u, h, excludeEmpty r)
            -- EOF PEER PeerAddress [d768:82dd:3e86:a6ba:8fb3:6f9c:6327:75d8%4236342772]:0:
            --   ["@[d768:82dd:3e86:a6ba:8fb3:6f9c:6327:75d8%4236342772]/"]
            -- dput XJabber $ "EOF PEER "++show k++": "++show jids
            forM_ jids $ \jid -> do
            stanza <- makePresenceStanza "jabber:client" (Just jid) Offline
            informPeerPresence state k stanza
        Right (k,_) -> do
            forClient state k (return ()) $ \client -> do
            forM_ (toxManager state) $ \toxman -> do
                case stripSuffix ".tox" (clientProfile client) of
                    Just pub -> deactivateAccount toxman k (clientProfile client)
                    _        -> return ()
            stanza <- makePresenceStanza "jabber:server" Nothing Offline
            informClientPresence state k stanza
            atomically $ do
                modifyTVar' (clientsByUser    state) $ Map.alter (delclient k) (clientUser    client)
                modifyTVar' (clientsByProfile state) $ Map.alter (delclient k) (clientProfile client)
    atomically $ case classifyConnection saddr cdta of
                    Left  (pkey,_) -> modifyTVar' (pkeyToChan state) $ Map.delete pkey
                    Right (ckey,_) -> modifyTVar' (ckeyToChan state) $ Map.delete ckey

{-
parseRemoteAddress :: Text -> IO (Maybe (Remote SockAddr))
parseRemoteAddress s = fmap Remote <$> parseAddress s
-}

-- This attempts to reverse resolve a peers address to give the human-friendly
-- domain name as it appears in the roster.  It prefers host names that occur
-- in the given list of JIDs, but will fall back to any reverse-resolved name
-- and if it was unable to reverse the address, it will yield an ip address.
peerKeyToResolvedName :: Connection.Manager s Text -> [Text] -> PeerAddress -> IO Text
peerKeyToResolvedName man buds pk = do
    ns <- reverseAddress man pk
    let hs = map (\jid -> let (_,h,_)=splitJID jid in h) buds
        ns' = sortBy (comparing $ not . flip elem hs) ns
    return $ fromMaybe (peerKeyToText pk) (listToMaybe ns')


-- | 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 :: Connection.Manager s Text -> Local SockAddr -> Text -> [Text] -> IO (Bool,(Maybe Text,Text,Maybe Text))
rewriteJIDForClient man (Local laddr) jid buds = do
    let (n,h,r) = splitJID jid
    -- dput XJabber $ "rewriteJIDForClient parsing " ++ show h
    maddr <- parseAddress (strip_brackets h)
    fromMaybe (return (False,(n,ip6literal h,r))) $ maddr <&> \saddr -> do
    let mine =  sameAddress laddr saddr
    h' <- if mine then textHostName
                  else peerKeyToResolvedName man buds (addrToPeerKey $ Remote saddr)
    return (mine,(n,h',r))

-- Given a local address and an IP-address JID, we return True if the JID is
-- local, False otherwise.  Additionally, a list of equivalent hostname JIDS
-- are returned.
multiplyJIDForClient :: Connection.Manager s Text -> ClientAddress -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)])
multiplyJIDForClient man k jid = do
    let (n,h,r) = splitJID jid
    -- dput XJabber $ "multiplyJIDForClient parsing " ++ show h
    maddr <- parseAddress (strip_brackets h)
    fromMaybe (return (False,[(n,ip6literal h,r)])) $ maddr <&> \saddr -> do
    let Local laddr = addrFromClientKey k
        mine        = sameAddress laddr saddr
    names <- if mine then fmap (:[]) textHostName
                     else reverseAddress man (addrToPeerKey $ Remote saddr)
    return (mine,map (\h' -> (n,h',r)) names)


guardPortStrippedAddress :: Text -> Local SockAddr -> IO (Maybe ())
guardPortStrippedAddress h (Local laddr) = do
    -- dput XJabber $ "guardPortStrippedAddress parsing " ++ show h
    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 PeerAddress 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 :: Connection.Manager s Text -> Text -> IO (Maybe (Text,PeerAddress))
rewriteJIDForPeer man jid = do
    let (n,h,r) = splitJID jid
    maddr <- fmap listToMaybe $ resolvePeer man h
    return $ flip fmap maddr $ \addr ->
        let h' = peerKeyToText addr
            to' = unsplitJID (n,h',r)
        in (to',addr)

deliverToConsole :: PresenceState stat -> IO () -> Stanza -> IO ()
deliverToConsole PresenceState{ consoleWriter = Just cw } fail msg = do
    did1 <- writeActiveTTY cw msg
    did2 <- writeAllPty cw msg
    if not (did1 || did2) then fail else return ()
deliverToConsole _ fail _ = fail

-- | deliver <message/> or error stanza
deliverMessage :: PresenceState stat
                -> IO ()
                -> StanzaWrap (LockedChan Event)
                -> IO ()
deliverMessage state fail msg =
    case stanzaOrigin msg of
      ClientOrigin senderk _ -> do
        -- Case 1.  Client -> Peer
        mto <- join $ atomically $ do
            mclient <- Map.lookup senderk <$> readTVar (clients state)
            return $ do
              dput XJabber $ "deliverMessage: to="++show (stanzaTo msg,fmap clientProfile mclient)
              fromMaybe -- Resolve XMPP peer.
                          (fmap join $ mapM (uncurry $ rewriteJIDForPeer . manager state)
                                     $ (,) <$> (clientProfile <$> mclient) <*> stanzaTo msg)
                $ do
                     client <- mclient
                     to <- stanzaTo msg
                     let (mu,th,rsc) = splitJID to
                     (toxman,me,_) <- weAreTox state client th
                     return $ do
                         dput XJabber $ "deliverMessage: weAreTox="++show me
                         -- In case the client sends us a lower-cased version of the base64
                         -- tox key hostname, we resolve it by comparing it with roster entries.
                         xs <- getBuddiesAndSolicited state (clientProfile client) $ \case
                            rh | Just _ <- stripSuffix ".tox" rh
                               , Text.toLower rh == Text.toLower th
                               -> return True
                            _ -> return False
                         fmap join $ forM (listToMaybe xs) $ \(_,rmu,_,h) -> do
                             let them = fromMaybe h $ stripSuffix ".tox" h
                             maddr <- resolveToxPeer toxman me them
                             let to' = unsplitJID (mu,h,rsc)
                             return $ fmap (to',) maddr
        fromMaybe (do dput XJabber $ "Unable to resolve "++show (stanzaTo msg)
                      fail {- reverse lookup failure -})
                $ mto <&> \(to',k) -> do
        chans <- atomically $ readTVar (pkeyToChan state)
        fromMaybe (do dput XJabber $ "Peer unavailable: "++ show k
                      fail)
                $ (Map.lookup k chans) <&> \conn -> do
        -- original 'from' address is discarded.
        from' <- forClient state senderk (return Nothing)
                        $ return . Just . clientJID conn
        -- dup <- atomically $ cloneStanza (msg { stanzaTo=Just to', stanzaFrom=Just from' })
        let dup = (msg { stanzaTo=Just to', stanzaFrom=from' })
        sendModifiedStanzaToPeer dup (connChan conn)
      PeerOrigin senderk _ -> do
        (pchans,cchans) <- atomically $ do
            pc <- readTVar (pkeyToChan state)
            cc <- readTVar (ckeyToChan state)
            return (pc,cc)
        fromMaybe (do dput XJabber $ "Unknown peer " ++ show senderk
                      fail)
                $ Map.lookup senderk pchans
            <&> \Conn { connChan = sender_chan
                      , auxData  = ConnectionData { cdAddr    = Left laddr
                                                  , cdType    = ctyp
                                                  , cdProfile = cprof
                                                  }
                      } -> do
        fromMaybe (do dput XJabber $ "Message missing \"to\" attribute."
                      fail)
                $ (stanzaTo msg) <&> \to -> do
        (mine,(n,h,r)) <- case (ctyp,cprof) of
            (Tox,prof) -> let (n,h,r) = splitJID to
                          in return ( h==prof, (n,h,r) )
            _          -> rewriteJIDForClient (manager state cprof) laddr to []
        if not mine then do dput XJabber $ "Address mis-match " ++ show (laddr,to)
                            fail
                    else do
        let to' = unsplitJID (n,h,r)
        let (cmapVar,ckey) = case ctyp of
                Tox  -> (clientsByProfile state , Just cprof )
                XMPP -> (clientsByUser    state , n          )
        cmap <- atomically . readTVar $ cmapVar
        chans <- fmap (fromMaybe []) $ do
            forM (ckey >>= flip Map.lookup cmap) $ \presence_container -> do
            let ks = Map.keys (networkClients presence_container)
                chans = do
                    (k,client) <- Map.toList $ networkClients presence_container
                    chan <- maybeToList $ Map.lookup k cchans
                    return (clientProfile client, clientUser client, chan)
            forM chans $ \(profile,user,chan) -> do
            buds <- configText ConfigFiles.getBuddies user profile
            from' <- case ctyp of
              Tox  -> return $ stanzaFrom msg
              XMPP -> do
                forM (stanzaFrom msg) $ \from -> do
                (_,trip) <- rewriteJIDForClient (manager state cprof) laddr from buds
                return $ unsplitJID trip
            to' <- case ctyp of
                XMPP -> return $ stanzaTo msg
                Tox  -> return $ Just $ unsplitJID (Just user, profile, Nothing)
            return (from',chan)
        dput XJabber $ "chan count: " ++ show (length chans)
        if null chans then when (ctyp == XMPP) $ do
            forM_ (stanzaFrom msg) $ \from -> do
            from' <- do
                -- Fallback to "." profile when no clients.
                buds <- maybe (return [])
                              (\n -> configText ConfigFiles.getBuddies n ".")
                              n
                (_,trip) <- rewriteJIDForClient (manager state cprof) laddr from buds
                return . Just $ unsplitJID trip
            let msg' = msg { stanzaTo=Just to'
                           , stanzaFrom=from' }
            deliverToConsole state fail msg'
        else do
            forM_ chans $ \(from',Conn { connChan=chan}) -> do
            -- TODO: Cloning isn't really necessary 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.
            let msg' = msg { stanzaTo=Just to'
                           , stanzaFrom=from' }
            dup <- cloneStanza msg'
            sendModifiedStanzaToClient dup
                                      chan


setClientFlag :: PresenceState stat -> ClientAddress -> Int8 -> IO ()
setClientFlag state k flag =
    atomically $ do
        cmap <- readTVar (clients state)
        forM_ (Map.lookup k cmap) $ \client -> do
        setClientFlag0 client flag

setClientFlag0 :: ClientState -> Int8 -> STM ()
setClientFlag0 client flag =
    modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag)

informSentRoster :: PresenceState stat -> ClientAddress -> IO ()
informSentRoster state k = do
    setClientFlag state k cf_interested


subscribedPeers :: Connection.Manager s Text -> Text -> Text -> IO [PeerAddress]
subscribedPeers man user profile = do
    jids <- configText ConfigFiles.getSubscribers user profile
    let hosts = map ((\(_,h,_)->h) . splitJID) jids
    fmap Map.keys $ resolveAllPeers man hosts

-- | this JID is suitable for peers, not clients.
clientJID :: Conn -> ClientState -> Text
clientJID con client = unsplitJID ( Just $ clientUser client
                                  , either (\(Local a) -> addrToText a) -- my host name, for peers
                                           (error $ unlines [ "clientJID wrongly used for client connection!"
                                                            , "TODO: my host name for clients? nameForClient? localJID?"])
                                           $ cdAddr $ auxData 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 stat
                        -> ClientAddress -> StanzaWrap (LockedChan Event) -> IO ()
informClientPresence state k stanza = do
    forClient state k (return ()) $ \client -> do
    informClientPresence0 state (Just k) client stanza

informClientPresence0 :: PresenceState stat
                       -> Maybe ClientAddress
                       -> 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 (manager state $ clientProfile client) (clientUser client) (clientProfile client)
    dput XJabber $ "informClientPresence(subscribedPeers) "++show (clientProfile client,addrs)
    ktc <- atomically $ readTVar (pkeyToChan state)
    let connected = mapMaybe (flip Map.lookup ktc) addrs
    forM_ connected $ \con -> do
    let from' = clientJID con client
    mto <- maybe (return Nothing)
                 (fmap (fmap fst) . rewriteJIDForPeer (manager state $ clientProfile client))
                 (stanzaTo stanza)
    dup <- cloneStanza stanza
    sendModifiedStanzaToPeer dup { stanzaFrom = Just from'
                                 , stanzaTo = mto }
                             (connChan con)

informPeerPresence :: PresenceState stat
                    -> PeerAddress
                    -> StanzaWrap (LockedChan Event)
                    -> IO ()
informPeerPresence state k stanza = do
    -- Presence must indicate full JID with resource...
    dput XJabber $ "xmppInformPeerPresence checking from address..."
    forM_ (stanzaFrom stanza) $ \from -> do
    let (muser0,h,mresource0) = splitJID from
        -- We'll allow the case that user and resource are simultaneously
        -- absent.  They will be stored in the remotesByPeer map using the
        -- empty string.  This is to accommodate the tox protocol which didn't
        -- anticipate a single peer would have multiple users or front-ends.
        (muser,mresource) = case (muser0,mresource0) of
            (Nothing,Nothing) -> (Just "", Just "")
            _                 -> (muser0,mresource0)
    dput XJabber $ "xmppInformPeerPresence from  = " ++ show from
    -- forM_ mresource       $ \resource -> do
    forM_ 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

        fromMaybe (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 (ckeyToChan state)
        cmap <- readTVar (clients state)
        return $ do
            (ck,client) <- Map.toList cmap
            con <- maybeToList $ Map.lookup ck ktc
            return (ck,con,client)
    dput XJabber $ "xmppInformPeerPresence (length clients="++show (length clients)++")"
    (ctyp,cprof) <- atomically $ do
        mconn <- Map.lookup k <$> readTVar (pkeyToChan state)
        return $ fromMaybe (XMPP,".") $ (cdType &&& cdProfile) . auxData <$> mconn
    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
        -- reversing for client: ("DdhbLjiwaV0GAiGKgesNPbvj2TbhrBHEWEEc5icfvQN.tox"
        --                       ,XMPP,"OrjBG.GyWuQhGc1pb0KssgmYAocohFh35Vx8mREC9Nu.tox",".")
        dput XJabber $ "reversing for client: " ++ show (from,ctyp,clientProfile client,cprof)
        froms <- case ctyp of
            Tox | clientProfile client == cprof -> return [from]
            _ -> do -- flip (maybe $ return [from]) k . const $ do
                (_,trip) <- multiplyJIDForClient (manager state $ clientProfile client) ck from
                return (map unsplitJID trip)

        dput XJabber $ "sending to client: " ++ show (stanzaType stanza,froms)
        forM_ froms $ \from' -> do
        dup <- cloneStanza stanza
        sendModifiedStanzaToClient (dup { stanzaFrom=Just from' })
                                   (connChan con)

consoleClients :: PresenceState stat -> STM (Map Text ClientState)
consoleClients PresenceState{ consoleWriter = Just cw } = readTVar (cwClients cw)
consoleClients _                                        = return Map.empty


answerProbe :: PresenceState stat -> Maybe Text -> PeerAddress -> TChan Stanza -> IO ()
answerProbe state mto k chan = do
    -- dput XJabber $ "answerProbe! " ++ show (stanzaType stanza)
    ktc <- atomically $ readTVar (pkeyToChan state)
    muser <- fmap join $ sequence $ do
        to <- mto
        conn <- Map.lookup k ktc
        let (mu,h,_)   = splitJID to -- TODO: currently resource-id is ignored on presence
                                     --  probes.  Is this correct? Check the spec.
            Left laddr = cdAddr $ auxData conn
            ch         = addrToText a where Local a = laddr
        u <- mu
        Just $ do
            guardPortStrippedAddress h laddr
             <&> maybe Nothing (\_ -> Just (u,conn,ch))

    forM_ muser $ \(u,conn,ch) -> do

    profiles <- releventProfiles (cdType $ auxData conn) u
    forM_ profiles $ \profile -> do

    -- only subscribed peers should get probe replies
    let man = manager state $ cdProfile $ auxData conn
    resolved_subs <- resolvedFromRoster man ConfigFiles.getSubscribers u profile
    let gaddrs = groupBy sameHost (sort resolved_subs)
        sameHost a b = (snd a == snd b) -- (==) `on` snd
        whitelist = do
            xs <- gaddrs     -- group of subscribed jids on the same host
            x <- take 1 xs   -- the host from the group
            guard $ snd x==k -- only hosts matching the key /k/
            mapMaybe fst xs  -- all users subscribed at the remote peer /k/

    -- TODO: notify remote peer that they are unsubscribed?
    --   reply <- makeInformSubscription "jabber:server" to from False
    when (not $ null whitelist) $ do

    replies <- catMaybes <$> do -- runTraversableT $ do
        cbu <- atomically $ readTVar (clientsByUser state) -- Map Text LocalPresence
        let lpres = maybeToList $ Map.lookup u cbu
        cw <- atomically $ consoleClients state -- Map Text ClientState
        forM ((lpres >>= Map.elems . networkClients) ++ Map.elems cw) $ \clientState -> do
            -- liftIOMaybe :: IO (Maybe a) -> TraversableT [] IO a
            mstanza <- atomically $ readTVar (clientStatus clientState)
            forM mstanza $ \stanza0 -> do
                stanza <- cloneStanza stanza0
                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

-- Send friend requests and remote presences stored in remotesByPeer to XMPP
-- clients.
sendCachedPresence :: PresenceState stat -> ClientAddress -> IO ()
sendCachedPresence state k = do
    forClient state k (return ()) $ \client -> do
    rbp <- atomically $ readTVar (remotesByPeer state)
    jids <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client)
    let hosts = map ((\(_,h,_)->h) . splitJID) jids
    addrs <- resolveAllPeers (manager state $ clientProfile client) hosts
    let onlines = rbp `Map.intersection` addrs
    mcon <- atomically $ do ktc <- readTVar (ckeyToChan state)
                            return $ Map.lookup k ktc
    forM_ mcon $ \con -> do
    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 (manager state $ clientProfile client) k 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) (clientProfile client)
    hostname <- nameForClient state k
    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 ::
                 Connection.Manager s Text
                 -> (ConfigFiles.User
                      -> ConfigFiles.Profile
                      -> (L.ByteString -> IO (Maybe L.ByteString))
                      -> Maybe L.ByteString
                      -> t1)
                 -> Text -- user
                 -> Text -- profile
                 -> Text -> [PeerAddress] -> t1
addToRosterFile man doit whose profile to addrs =
    modifyRosterFile man doit whose profile to addrs True False

removeFromRosterFile ::
                      Connection.Manager s Text
                      -> (ConfigFiles.User
                           -> ConfigFiles.Profile
                           -> (L.ByteString -> IO (Maybe L.ByteString))
                           -> Maybe L.ByteString
                           -> t1)
                      -> Text -- user
                      -> Text -- profile
                      -> Text -> [PeerAddress] -> t1
removeFromRosterFile man doit whose profile to addrs =
    modifyRosterFile man doit whose profile to addrs False False

-- | Sanity-checked roster file manipulation.  Primarily, this function handles
-- hostname aliases.
modifyRosterFile ::
                  Connection.Manager s Text
                   -> (ConfigFiles.User
                       -> ConfigFiles.Profile
                       -> (L.ByteString -> IO (Maybe L.ByteString))
                       -> Maybe L.ByteString
                       -> t1)   -- ^ Lower-level modification function
                                --   indicating which file is being modified.
                                --   Valid choices from ConfigFiles module:
                                --
                                --     * modifySolicited
                                --
                                --     * modifyBuddies
                                --
                                --     * modifyPending
                                --
                                --     * modifySubscribers
                  -> Text       -- ^ user
                  -> Text       -- ^ profile
                  -> Text       -- ^ JID that will be added or removed a hostname
                  -> [PeerAddress] -- ^ Alias addresses for hostname in the JID.
                  -> Bool       -- ^ True if adding, otherwise False
                  -> Bool       -- ^ True to allow deleting all users at a host.
                  -> t1
modifyRosterFile man doit whose profile to addrs bAdd bWildCard = do
    let (mu,_,_) = splitJID to
        -- For each jid in the file, this function will decide whether to keep
        -- it (possibly modified) which is indicated by Just _ or to remove the
        -- item from the file which is indicated by Nothing.
        cmp :: L.ByteString -> IO (Maybe L.ByteString)
        cmp jid = do
            let (msu,stored_h,mr) = splitJID (lazyByteStringToText jid)
                keep   = return (Just jid) :: IO (Maybe L.ByteString)
                delete = return Nothing    :: IO (Maybe L.ByteString)
                iocheck  = do
                    stored_addrs <- resolvePeer man stored_h -- TODO: don't resolve .tox peers.
                    case stored_addrs of
                        []                      -> keep   -- do not delete if failed to resolve
                        xs | null (xs \\ addrs) -> delete -- hostname alias, delete
                        _                       -> keep
            fmap join $ sequence $ do
                guard $ isNothing mr -- delete if resource specified in file.
                if mu == msu || bWildCard
                    then Just iocheck -- do not delete unless hostname alias
                    else Just keep    -- do not delete if user field doesn't match.
    doit (textToLazyByteString whose) (Text.unpack profile)
         cmp
         (guard bAdd >> Just (textToLazyByteString to))


clientSubscriptionRequest :: PresenceState stat -> IO () -> ClientAddress -> Stanza -> TChan Stanza -> IO ()
clientSubscriptionRequest state fail k stanza chan = do
    forClient state k fail $ \client -> do
    fromMaybe fail $ (splitJID <$> stanzaTo stanza) <&> \(mu,h,_) -> do
    dput XJabber $ "Forwarding solicitation to peer"
    let to0   = unsplitJID (mu,h,Nothing) -- deleted resource
        cuser = clientUser client
        cprof = clientProfile client
        man = manager state cprof
        mto = if ".tox" `Text.isSuffixOf` cprof
          then case parseNoSpamId to0 of
            Right toxjid@(NoSpamId nspam _)   -> Just ( Text.pack $ '$' : nospam64 nspam
                                                      , Text.pack $ show toxjid
                                                      , return [] )
            Left _ | Text.isSuffixOf ".tox" h -> Nothing
            Left _ | Text.all isHexDigit h
                     && Text.length h == 76   -> Nothing
            Left _ -> fmap (\u -> (u, to0 ,resolvePeer man h)) mu
          else fmap (\u -> (u, to0 ,resolvePeer man h)) mu
    fromMaybe fail $ mto <&> \(u,to,resolv) -> do
    -- add to-address to from's solicited
    dput XJabber $ unlines [ "to0=" ++ Text.unpack to0
                           , "to=" ++ show (Text.unpack to) ]
    addrs <- resolv
    addToRosterFile      man ConfigFiles.modifySolicited cuser cprof to addrs
    removeFromRosterFile man ConfigFiles.modifyBuddies   cuser cprof to addrs
    resolved_subs <- resolvedFromRoster man ConfigFiles.getSubscribers cuser cprof
    let is_subscribed = not . null $ [ (mu, a) | a <- addrs ]
                                     `intersect` resolved_subs
    -- subscribers: "from"
    -- buddies: "to"

    case state of
      PresenceState { server = svVar } -> do

        (cktc,pktc,(sv,conns)) <- atomically $ do
            cktc <- readTVar $ ckeyToChan state
            pktc <- readTVar $ pkeyToChan state
            return (cktc,pktc,(server state,man))

        -- Update roster for each client.
        case stanzaType stanza of
         PresenceRequestSubscription True -> do
            hostname <- nameForClient state k
            let cjid = unsplitJID (Just $ clientUser client, hostname,Nothing)
            chans <- clientCons state cktc (clientUser client)
            forM_ chans $ \( Conn { connChan=chan }, client ) -> do
                -- roster update ask="subscribe"
                update <- myMakeRosterUpdate (clientProfile client) cjid to
                    [ ("ask","subscribe")
                    , if is_subscribed then ("subscription","from")
                                       else ("subscription","none")
                    ]
                sendModifiedStanzaToClient update chan
                when (to /= to0) $ do
                    removal <- myMakeRosterUpdate (clientProfile client) cjid to0
                        [ ("subscription","remove") ]
                    sendModifiedStanzaToClient removal chan
         _ -> return ()

        -- Send friend request to peer.
        let dsts = pktc `Map.intersection` toMapUnit addrs
        forM_ (Map.toList dsts) $ \(pk,con) -> do
            -- if already connected, send solicitation ...
            -- let from = clientJID con client
            let Left laddr = cdAddr $ auxData con
                from = unsplitJID ( Just $ clientUser client
                                  , (\(Local a) -> addrToText a) $ laddr
                                  , Nothing )
            mb <- rewriteJIDForPeer (manager state $ cdProfile $ auxData con) to
            forM_ mb $ \(to',addr) -> do
            dup <- cloneStanza stanza
            sendModifiedStanzaToPeer (dup { stanzaTo = Just to'
                                          , stanzaFrom = Just from })
                                     (connChan con)
        let policySetter = fromMaybe (Connection.setPolicy conns h) $ do
                (toxman,_,_) <- weAreTox state client h
                meid <- readMaybe $ Text.unpack $ case stripSuffix ".tox" (clientProfile client) of
                            Just h -> h
                            _      -> clientProfile client
                themid <- readMaybe $ Text.unpack h
                Just $ Connection.setPolicy (toxConnections toxman) (ToxContact meid themid)
        -- Add peer if we are not already associated ...
        policySetter Connection.TryingToConnect

weAreTox :: PresenceState stat -> ClientState -> Text -> Maybe (ToxManager ClientAddress,Text{- me -},Text{- them -})
weAreTox state client h = do
    toxman <- toxManager state
    me   <- stripSuffix ".tox" (clientProfile client)
    them <- stripSuffix ".tox" h
    return (toxman,me,them)

resolvedFromRoster
  :: Connection.Manager s Text
     -> (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString])
     -> UserName -> Text -> IO [(Maybe UserName, PeerAddress)]
resolvedFromRoster man doit u profile = concat <$> do
    subs <- configText doit u profile
    forM (splitJID `fmap` subs) $ \(mu,h,_) -> do
        addrs <- fmap nub $ resolvePeer man h
        return $ map (mu,) addrs

clientCons :: PresenceState stat
            -> Map ClientAddress t -> Text -> IO [(t, ClientState)]
clientCons state ktc u = map snd <$> clientCons' state ktc u

clientCons' :: PresenceState stat
            -> Map ClientAddress t -> Text -> IO [(ClientAddress,(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 (k,(con,client))
    return $ mapMaybe doit ks

releventProfiles :: ConnectionType -> Text -> IO [Text]
releventProfiles XMPP _    = return ["."]
releventProfiles ctyp user = do
    -- TODO: Return all the ".tox" profiles that a user has under his
    -- .presence/ directory.
    return []

peerSubscriptionRequest :: PresenceState stat -> IO () -> PeerAddress -> Stanza -> TChan Stanza -> IO ()
peerSubscriptionRequest state fail k stanza chan = do
    dput XJabber $ "Handling pending subscription from remote"
    fromMaybe fail $ (stanzaFrom stanza) <&> \from -> do
    fromMaybe 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
    (pktc,cktc,cmap) <- atomically $ do
        cktc <- readTVar (ckeyToChan state)
        pktc <- readTVar (pkeyToChan state)
        cmap <- readTVar (clients state)
        return (pktc,cktc,cmap)
    fromMaybe fail $ (Map.lookup k pktc)
        <&> \Conn { auxData = ConnectionData { cdAddr    = Left laddr
                                             , cdType    = ctyp
                                             , cdProfile = profile
                                             }
                  } -> do
    (mine,totup) <- case (ctyp,profile) of
        (Tox,p) -> let (u,h,r) = splitJID to
                   in return ( h == p, (u,h,r) )
        _       -> rewriteJIDForClient (manager state profile) laddr to []
    if not mine then fail else do
    (_,fromtup) <- rewriteJIDForClient (manager state profile) laddr from []
    fromMaybe fail $ mto_u <&> \u -> do
    fromMaybe fail $ mfrom_u <&> \from_u -> do
    resolved_subs <- resolvedFromRoster (manager state profile) ConfigFiles.getSubscribers u profile
    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 (manager state profile) from_h

    -- Catch exception in case the user does not exist
    if null addrs then fail else do

    let from' = unsplitJID fromtup

    -- Update roster files (subscribe: add to pending, unsubscribe: remove from subscribers).
    already_pending <-
      if is_wanted then
        addToRosterFile (manager state profile) ConfigFiles.modifyPending u profile from' addrs
      else do
        removeFromRosterFile (manager state profile) ConfigFiles.modifySubscribers u profile 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 cktc 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

myMakeRosterUpdate :: Text -> Text -> Text -> [(XML.Name, Text)] -> IO Stanza
myMakeRosterUpdate prf tojid contact as
    | ".tox" `Text.isSuffixOf` prf
    , (Just u,h,r) <- splitJID contact
    , ".tox" `Text.isSuffixOf` u      = XMPPServer.makeRosterUpdate tojid (unsplitJID (Nothing,h,r)) as
myMakeRosterUpdate _ tojid contact as = XMPPServer.makeRosterUpdate tojid contact as


clientInformSubscription :: PresenceState stat
                          -> IO ()
                          -> ClientAddress
                          -> StanzaWrap (LockedChan Event)
                          -> IO ()
clientInformSubscription state fail k stanza = do
    forClient state k fail $ \client -> do
    fromMaybe fail $ (stanzaTo stanza) <&> \to -> do
    dput XJabber $ "clientInformSubscription"
    let (mu,h,mr) = splitJID to
        man = manager state $ clientProfile client
    addrs <- resolvePeer man h
    -- remove from pending
    buds <- resolvedFromRoster man ConfigFiles.getBuddies (clientUser client) (clientProfile client)
    let is_buddy = not . null $ map (mu,) addrs `intersect` buds
    removeFromRosterFile man ConfigFiles.modifyPending (clientUser client) (clientProfile 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      man addf (clientUser client) (clientProfile client) to addrs
    removeFromRosterFile man remf (clientUser client) (clientProfile client) to addrs

    do
        cbu <- atomically $ readTVar (clientsByUser state)
        dput XJabber $ "cbu = " ++ show (fmap (fmap clientPid . networkClients) cbu)

    -- send roster update to clients
    (clients,ktc,pktc) <- atomically $ do
        cbu <- readTVar (clientsByUser state)
        let mlp = Map.lookup (clientUser client) cbu
        let cs = maybe [] (Map.toList . networkClients) mlp
        ktc <- readTVar (ckeyToChan state)
        pktc <- readTVar (pkeyToChan state)
        return (cs,ktc,pktc)
    forM_ clients $ \(ck, client) -> do
        is_intereseted <- atomically $ clientIsInterested client
        dput XJabber $ "clientIsInterested: "++show is_intereseted
        is_intereseted <- atomically $ clientIsInterested client
        when is_intereseted $ do
        forM_ (Map.lookup ck ktc) $ \con -> do
        hostname <- nameForClient state ck
        -- TODO: Should cjid include the resource?
        let cjid = unsplitJID (mu, hostname, Nothing)
        update <- myMakeRosterUpdate (clientProfile client) cjid to [relationship]
        sendModifiedStanzaToClient update (connChan con)

    -- notify peer
    let dsts = toMapUnit addrs
        cdsts = pktc `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 stat
                        -> IO ()
                        -> PeerAddress
                        -> StanzaWrap (LockedChan Event)
                        -> IO ()
peerInformSubscription state fail k stanza = do
    dput XJabber $ "TODO: peerInformSubscription"
    -- remove from solicited
    fromMaybe fail $ (stanzaFrom stanza) <&> \from -> do
    (ktc,cktc,cmap) <- atomically $ do
        pktc <- readTVar (pkeyToChan state)
        cktc <- readTVar (ckeyToChan state)
        cmap <- readTVar (clients state)
        return (pktc,cktc,cmap)
    fromMaybe fail $ Map.lookup k ktc
        <&> \Conn { connChan = sender_chan
                  , auxData = ConnectionData { cdAddr    = Left laddr
                                             , cdType    = ctyp
                                             , cdProfile = profile }
                  } -> do

    let man = manager state profile
    (from_u,from_h,_) <- case ctyp of
        Tox  -> return $ splitJID from
        XMPP -> snd <$> rewriteJIDForClient man 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'.
    fromMaybe fail $ muser <&> \user -> do

    addrs <- resolvePeer man from_h
    was_solicited <- removeFromRosterFile man ConfigFiles.modifySolicited user profile from'' addrs

    subs <- resolvedFromRoster man ConfigFiles.getSubscribers user profile
    let is_sub = not . null $ map (from_u,) addrs `intersect` subs
    dput XJabber $ "DEBUG peerInformSubscription (is_sub,typ)=" ++ show (is_sub,stanzaType stanza)
    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      man addf user profile from'' addrs
    removeFromRosterFile man remf user profile from'' addrs

    chans <- clientCons' state cktc user
    forM_ chans $ \(ckey,(Conn { connChan=chan }, client)) -> do
    hostname <- nameForClient state ckey
    let to' = unsplitJID (Just user, hostname, Nothing)
    update <- myMakeRosterUpdate (clientProfile client) 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