4 files changed, 1117 insertions, 1040 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
diff --git a/Presence/Util.hs b/Presence/Util.hs
new file mode 100644
index 00000000..8d9a9494
--- /dev/null
+++ b/Presence/Util.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Util where
+import qualified Data.ByteString.Lazy as L
+import Data.Monoid
+import qualified Data.Text            as Text
+         ;import Data.Text            (Text)
+import qualified Data.Text.Encoding   as Text
+import qualified Network.BSD          as BSD
+import Network.Socket
+import Network.Address (setPort)
+type UserName = Text
+type ResourceName = Text
+unsplitJID :: (Maybe UserName,Text,Maybe ResourceName) -> Text
+unsplitJID (n,h,r) = username <> h <> resource
+ where
+    username = maybe "" (<>"@") n
+    resource = maybe "" ("/"<>) r
+splitJID :: Text -> (Maybe UserName,Text,Maybe ResourceName)
+splitJID bjid =
+    let xs = splitAll '@' bjid
+        ys = splitAll '/' (last xs)
+        splitAll c bjid = take 1 xs0 ++ map (Text.drop 1) (drop 1 xs0)
+            where xs0 = Text.groupBy (\x y-> y/=c) bjid
+        server = head ys
+        name = case xs of
+                (n:s:_) -> Just n
+                (s:_)   -> Nothing
+        rsrc = case ys of
+                (s:_:_) -> Just $ last ys
+                _       -> Nothing
+    in (name,server,rsrc)
+textHostName :: IO Text
+textHostName = fmap Text.pack BSD.getHostName
+textToLazyByteString :: Text -> L.ByteString
+textToLazyByteString s = L.fromChunks [Text.encodeUtf8 s]
+lazyByteStringToText :: L.ByteString -> Text
+lazyByteStringToText = (foldr1 (<>) . map Text.decodeUtf8 . L.toChunks)
+-- | for example:  2001-db8-85a3-8d3-1319-8a2e-370-7348.ipv6-literal.net
+ip6literal :: Text -> Text
+ip6literal addr = Text.map dash addr <> ".ipv6-literal.net"
+ where
+    dash ':' = '-'
+    dash x   = x
+sameAddress :: SockAddr -> SockAddr -> Bool
+sameAddress laddr addr = setPort 0 laddr == setPort 0 addr
diff --git a/g b/g
index 736b2463..cab1b16e 100755
--- a/g
+++ b/g
@@ -1,5 +1,8 @@
 #!/bin/bash
-args="-fwarn-unused-imports -O2"
+warn="-freverse-errors -fwarn-unused-imports -Wmissing-signatures -fdefer-typed-holes"
+exts="-XOverloadedStrings -XRecordWildCards"
+defs="-DBENCODE_AESON -DTHREAD_DEBUG"
+hide="-hide-package crypto-random -hide-package crypto-api -hide-package crypto-numbers -hide-package cryptohash -hide-package prettyclass"
 root=${0%/*}
 cd "$root"
@@ -7,9 +10,13 @@ cd "$root"
 me=${0##*/}
 me=${me%.*}
 ghc                                  \
+    $hide                            \
+    $exts                            \
+    $defs                            \
    -hidir build/$me -odir build/$me \
    -iPresence                       \
    -iArchive                        \
+    -isrc                            \
    build/b/Presence/monitortty.o    \
-    $args                            \
+    $warn                            \
    "$@"
diff --git a/xmppServer.hs b/xmppServer.hs
index 803b4324..01246f64 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -44,1002 +44,7 @@ import XMPPServer
 import PeerResolve
 import ConsoleWriter
 import ClientState
+import Presence
-type UserName = Text
-type ResourceName = Text
-unsplitJID :: (Maybe UserName,Text,Maybe ResourceName) -> Text
-unsplitJID (n,h,r) = username <> h <> resource
- where
-    username = maybe "" (<>"@") n
-    resource = maybe "" ("/"<>) r
-splitJID :: Text -> (Maybe UserName,Text,Maybe ResourceName)
-splitJID bjid = 
-    let xs = splitAll '@' bjid
-        ys = splitAll '/' (last xs)
-        splitAll c bjid = take 1 xs0 ++ map (Text.drop 1) (drop 1 xs0)
-            where xs0 = Text.groupBy (\x y-> y/=c) bjid
-        server = head ys
-        name = case xs of
-                (n:s:_) -> Just n
-                (s:_)   -> Nothing
-        rsrc = case ys of
-                (s:_:_) -> Just $ last ys
-                _       -> Nothing
-    in (name,server,rsrc)
-isPeerKey :: ConnectionKey -> Bool
-isPeerKey k = case k of { PeerKey {} -> True ; _ -> False }
-isClientKey :: ConnectionKey -> Bool
-isClientKey k = case k of { ClientKey {} -> True ; _ -> False }
-textHostName :: IO Text
-textHostName = fmap Text.pack BSD.getHostName
-localJID :: Text -> Text -> IO Text
-localJID user resource = do
-    hostname <- textHostName
-    return $ user <> "@" <> hostname <> "/" <> resource
-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
-lazyByteStringToText :: L.ByteString -> Text
-lazyByteStringToText = (foldr1 (<>) . map Text.decodeUtf8 . L.toChunks)
-textToLazyByteString :: Text -> L.ByteString
-textToLazyByteString s = L.fromChunks [Text.encodeUtf8 s]
-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)
-}
-- | for example:  2001-db8-85a3-8d3-1319-8a2e-370-7348.ipv6-literal.net
-ip6literal :: Text -> Text
-ip6literal addr = Text.map dash addr <> ".ipv6-literal.net"
- where
-    dash ':' = '-'
-    dash x   = x
-- | 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))
-sameAddress :: SockAddr -> SockAddr -> Bool
-sameAddress laddr addr = laddr `withPort` 0  == addr `withPort` 0
-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
 main :: IO ()
 main = runResourceT $ do
@@ -1047,48 +52,9 @@ main = runResourceT $ do
    let verbosity = getSum $ flip foldMap args $ \case
            ('-':xs) -> Sum $ length (filter (=='-') xs)
            _        -> mempty
-    cw <- liftIO newConsoleWriter
+    cw    <- liftIO newConsoleWriter
-    state <- liftIO . atomically $ do
+    state <- liftIO $ newPresenceState cw
-        clients <- newTVar Map.empty
+    sv    <- xmppServer (presenceHooks state verbosity)
-        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
-            }
-    sv <- xmppServer
-        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
-        }
    liftIO $ do
    atomically $ putTMVar (server state) sv