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

1 files changed, 4 insertions, 1038 deletions

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
-
-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
+import Presence
 
 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
-    state <- liftIO . 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
-            }
-    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
-        }
+    cw    <- liftIO newConsoleWriter
+    state <- liftIO $ newPresenceState cw
+    sv    <- xmppServer (presenceHooks state verbosity)
     liftIO $ do
     atomically $ putTMVar (server state) sv