WIP: Multiple identities/rosters for a single unix user.

5 files changed, 250 insertions, 171 deletions

diff --git a/Presence/ClientState.hs b/Presence/ClientState.hs
index 30a53131..08cc54ed 100644
--- a/Presence/ClientState.hs
+++ b/Presence/ClientState.hs
@@ -9,11 +9,18 @@ import UTmp       ( ProcessID )
 import XMPPServer ( Stanza )
 
 data ClientState = ClientState
+      -- | The unix tty or the jabber resource for this client.
     { clientResource :: Text
-    , clientUser :: Text
-    , clientPid :: Maybe ProcessID
-    , clientStatus :: TVar (Maybe Stanza)
-    , clientFlags :: TVar Int8
+      -- | Unix user that is running this client.
+    , clientUser     :: Text
+      -- | The specific roster/identity of the user that this client presenting.
+    , clientProfile  :: Text
+      -- | The unix process id of the client if we know it.
+    , clientPid      :: Maybe ProcessID
+      -- | The presence (away/available) stanza this client is indicating.
+    , clientStatus   :: TVar (Maybe Stanza)
+      -- | XMPP client flags (read access via 'clientIsAvailable' and 'clientIsInterested')
+    , clientFlags    :: TVar Int8
     }
 
 cf_available :: Int8
diff --git a/Presence/ConfigFiles.hs b/Presence/ConfigFiles.hs
index 808e6dd8..b745094f 100644
--- a/Presence/ConfigFiles.hs
+++ b/Presence/ConfigFiles.hs
@@ -18,32 +18,42 @@ import Data.List (partition)
 import Data.Maybe (catMaybes,isJust)
 
 type User = ByteString
+type Profile = String
 
-configDir = ".presence"
-buddyFile = "buddies"
+configDir, buddyFile, subscriberFile,
+  otherFile, pendingFile, solicitedFile,
+  secretsFile :: FilePath
+
+configDir      = ".presence"
+buddyFile      = "buddies"
 subscriberFile = "subscribers"
-otherFile = "others"
-pendingFile = "pending"
-solicitedFile = "solicited"
+otherFile      = "others"
+pendingFile    = "pending"
+solicitedFile  = "solicited"
+secretsFile    = "secrets"
 
 
-configPath :: User -> String -> IO String
-configPath user filename = do
+configPath :: User -> Profile -> String -> IO String
+configPath user "." filename = do
     ue <- getUserEntryForName (unpack user)
     return $ (++("/"++configDir++"/"++filename)) $ homeDirectory ue
+configPath user profile filename = do
+    ue <- getUserEntryForName (unpack user)
+    return $ (++("/"++configDir++"/"++profile++"/"++filename)) $ homeDirectory ue
 
-
+createConfigFile :: ByteString -> FilePath -> IO ()
 createConfigFile tag path = do
     let dir = dropFileName path
     doesDirectoryExist dir >>= flip unless (do
-            createDirectory dir 
+            createDirectory dir
         )
     withFile path WriteMode $ \h -> do
         L.hPutStrLn h tag
 
+addItem :: ByteString -> ByteString -> FilePath -> IO ()
 addItem item tag path =
     let doit = do
-         handle (\e -> when (isDoesNotExistError e) 
+         handle (\e -> when (isDoesNotExistError e)
                        (createConfigFile tag path >> doit))
            $ do exists <- fileExist path
                 if exists
@@ -55,16 +65,27 @@ addItem item tag path =
     in doit
 
 
+-- | Modify a presence configuration file.  This function will iterate over all
+-- items in the file and invoke a test function.  If the function returns
+-- Nothing, that item is removed from the file.  Otherwise, the function may
+-- rename the item by returning the new name.
+--
+-- If the last argument is populated, it is a new item to append to the end of
+-- the file.
+--
+-- Note that the entire file is read in, processed, and then rewritten from
+-- scratch.
 modifyFile ::
   (ByteString,FilePath)
-  -> ByteString
-  -> (ByteString -> IO (Maybe ByteString))
-  -> Maybe ByteString
+  -> User
+  -> Profile
+  -> (ByteString -> IO (Maybe ByteString)) -- Returns Just for each item you want to keep.
+  -> Maybe ByteString -- Optionally append this item.
   -> IO Bool -- Returns True if test function ever returned Nothing
-modifyFile (tag,file) user test appending = configPath user file >>= doit
+modifyFile (tag,file) user profile test appending = configPath user profile file >>= doit
     where
         doit path = do
-         handle (\e -> if (isDoesNotExistError e) 
+         handle (\e -> if (isDoesNotExistError e)
                         then (createConfigFile tag path >> doit path)
                         else return False)
            $ do exists <- fileExist path
@@ -85,46 +106,48 @@ modifyFile (tag,file) user test appending = configPath user file >>= doit
                     withFile path WriteMode $ \h -> do
                         L.hPutStrLn h tag
                         withJust appending (L.hPutStrLn h)
-                    return False 
-
+                    return False
 
-modifySolicited  = modifyFile ("<? solicited ?>" , solicitedFile)
-modifyBuddies    = modifyFile ("<? buddies ?>"   , buddyFile)
-modifyOthers     = modifyFile ("<? others ?>"    , otherFile)
-modifyPending    = modifyFile ("<? pending ?>"   , pendingFile)
-modifySubscribers = modifyFile ("<? subscribers ?>", subscriberFile)
+modifySolicited, modifyBuddies, modifyOthers, modifyPending, modifySubscribers
+  :: User -> Profile -> (ByteString -> IO (Maybe ByteString)) -> Maybe ByteString -> IO Bool
 
-addBuddy :: User -> ByteString -> IO ()
-addBuddy user buddy =
-    configPath user buddyFile >>= addItem buddy "<? buddies ?>"
+modifySolicited   = modifyFile ("<? solicited ?>"   , solicitedFile)
+modifyBuddies     = modifyFile ("<? buddies ?>"     , buddyFile)
+modifyOthers      = modifyFile ("<? others ?>"      , otherFile)
+modifyPending     = modifyFile ("<? pending ?>"     , pendingFile)
+modifySubscribers = modifyFile ("<? subscribers ?>" , subscriberFile)
 
-addSubscriber :: User -> ByteString -> IO ()
-addSubscriber user subscriber =
-    configPath user subscriberFile >>= addItem subscriber "<? subscribers ?>"
+addBuddy :: User -> Profile -> ByteString -> IO ()
+addBuddy user profile buddy =
+    configPath user profile buddyFile >>= addItem buddy "<? buddies ?>"
 
-addSolicited :: User -> ByteString -> IO ()
-addSolicited user solicited =
-    configPath user solicitedFile >>= addItem solicited "<? solicited ?>"
+addSubscriber :: User -> Profile -> ByteString -> IO ()
+addSubscriber user profile subscriber =
+    configPath user profile subscriberFile >>= addItem subscriber "<? subscribers ?>"
 
+addSolicited :: User -> Profile -> ByteString -> IO ()
+addSolicited user profile solicited =
+    configPath user profile solicitedFile >>= addItem solicited "<? solicited ?>"
 
-getConfigList path = 
+getConfigList :: FilePath -> IO [ByteString]
+getConfigList path =
   handle (\e -> if isDoesNotExistError e then (return []) else throw e)
     $ withFile path ReadMode $
-        L.hGetContents 
-        >=> return . Prelude.tail . L.lines 
+        L.hGetContents
+        >=> return . Prelude.tail . L.lines
         >=> (\a -> seq (rnf a) (return a))
 
-getBuddies :: User -> IO [ByteString]
-getBuddies user = configPath user buddyFile >>= getConfigList
+getBuddies :: User -> Profile -> IO [ByteString]
+getBuddies user profile = configPath user profile buddyFile >>= getConfigList
 
-getSubscribers :: User -> IO [ByteString]
-getSubscribers user = configPath user subscriberFile >>= getConfigList
+getSubscribers :: User -> Profile -> IO [ByteString]
+getSubscribers user profile = configPath user profile subscriberFile >>= getConfigList
 
-getOthers :: User -> IO [ByteString]
-getOthers user = configPath user otherFile >>= getConfigList
+getOthers :: User -> Profile -> IO [ByteString]
+getOthers user profile = configPath user profile otherFile >>= getConfigList
 
-getPending :: User -> IO [ByteString]
-getPending user = configPath user pendingFile >>= getConfigList
+getPending :: User -> Profile -> IO [ByteString]
+getPending user profile = configPath user profile pendingFile >>= getConfigList
 
-getSolicited :: User -> IO [ByteString]
-getSolicited user = configPath user solicitedFile >>= getConfigList
+getSolicited :: User -> Profile -> IO [ByteString]
+getSolicited user profile = configPath user profile solicitedFile >>= getConfigList
diff --git a/Presence/ConsoleWriter.hs b/Presence/ConsoleWriter.hs
index 986294f4..b80e477a 100644
--- a/Presence/ConsoleWriter.hs
+++ b/Presence/ConsoleWriter.hs
@@ -100,8 +100,8 @@ onLogin cs start = \e -> do
                 $ \tuvar -> do
             tu <- readTVar tuvar
             return (tty,tu)
-            
-    forM_ (Map.elems newborn) $ 
+
+    forM_ (Map.elems newborn) $
         forkIO . start getActive
     -- forM_ (Map.elems dead   ) $ putStrLn . ("gone: "++) . show
 
@@ -297,7 +297,7 @@ writeAllPty cw msg = do
                     && Text.all isDigit (Text.drop 4 k)
     bs <- forM (Map.toList ptys) $ \(tty,utmp) -> do
         deliverTerminalMessage cw ("/dev/" <> tty) utmp msg
-    return $ or bs 
+    return $ or bs
 
 resource :: UtmpRecord -> Text
 resource u =
@@ -341,10 +341,11 @@ newCon log cw activeTTY utmp = do
     statusv <- atomically $ newTVar (Just stanza)
     flgs <- atomically $ newTVar 0
     let client = ClientState { clientResource = r
-                             , clientUser = utmpUser u
-                             , clientPid = Nothing
-                             , clientStatus = statusv
-                             , clientFlags = flgs }
+                             , clientUser     = utmpUser u
+                             , clientProfile  = "."
+                             , clientPid      = Nothing
+                             , clientStatus   = statusv
+                             , clientFlags    = flgs }
     atomically $ do
         modifyTVar (cwClients cw) $ Map.insert r client
         putTMVar (cwPresenceChan cw) (client,stanza)
@@ -359,7 +360,7 @@ newCon log cw activeTTY utmp = do
                 guard (not $ Text.null $ utmpHost tu)
                 return tu
               match mtu = searchstr mtu `Text.isInfixOf` Text.dropWhile (/=':') r
-    jstatus r ttynum tu = 
+    jstatus r ttynum tu =
         if bstatus r ttynum tu
             then Available
             else Away
diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index 15775857..9b91dc1d 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -32,7 +32,7 @@ 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.Maybe
 import Data.Bits
 import Data.Int (Int8)
 import Data.XML.Types (Event)
@@ -56,10 +56,12 @@ 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
+localJID :: Text -> Text -> Text -> IO Text
+localJID user "." resource = do
     hostname <- textHostName
     return $ user <> "@" <> hostname <> "/" <> resource
+localJID user profile resource =
+    return $ user <> "@" <> profile <> "/" <> resource
 
 data PresenceState = forall status. PresenceState
     { clients         :: TVar (Map ConnectionKey ClientState)
@@ -72,6 +74,9 @@ data PresenceState = forall status. PresenceState
     }
 
 
+newPresenceState :: Maybe ConsoleWriter
+                 -> TMVar (XMPPServer, Connection.Manager status Text)
+                 -> IO PresenceState
 newPresenceState cw xmpp = atomically $ do
         clients <- newTVar Map.empty
         clientsByUser <- newTVar Map.empty
@@ -87,6 +92,7 @@ newPresenceState cw xmpp = atomically $ do
             }
 
 
+presenceHooks :: PresenceState -> Int -> XMPPServerParameters
 presenceHooks state verbosity = XMPPServerParameters
     { xmppChooseResourceName        = chooseResourceName state
     , xmppTellClientHisName         = tellClientHisName state
@@ -165,21 +171,25 @@ identifyTTY' ttypids uid inode = ttypid
        textify (tty,pid) = (fmap lazyByteStringToText tty, pid)
 
 chooseResourceName :: PresenceState
-                    -> ConnectionKey -> SockAddr -> t -> IO Text
-chooseResourceName state k addr desired = do
+                    -> ConnectionKey -> SockAddr -> Maybe Text -> Maybe Text -> IO Text
+chooseResourceName state k addr clientsNameForMe desired = do
     muid <- getLocalPeerCred' addr
     (mtty,pid) <- getTTYandPID muid
     user <- getJabberUserForId muid
     status <- atomically $ newTVar Nothing
     flgs <- atomically $ newTVar 0
+    profile <- fmap (fromMaybe ".") $ forM clientsNameForMe $ \wanted_profile -> do
+        -- TODO: allow user to select profile
+        return "."
     let client = ClientState { clientResource = maybe "fallback" id mtty
-                             , clientUser = user
-                             , clientPid = pid
-                             , clientStatus = status
-                             , clientFlags = flgs }
+                             , clientUser     = user
+                             , clientProfile  = profile
+                             , clientPid      = pid
+                             , clientStatus   = status
+                             , clientFlags    = flgs }
 
     do -- forward-lookup of the buddies so that it is cached for reversing.
-       buds <- configText ConfigFiles.getBuddies (clientUser client)
+       buds <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client)
        forM_ buds $ \bud -> do
             let (_,h,_) = splitJID bud
             forkIO $ void $ resolvePeer h
@@ -191,7 +201,7 @@ chooseResourceName state k addr desired = do
                                   (pcInsertNetworkClient k client)
                                   mb
 
-    localJID (clientUser client) (clientResource client)
+    localJID (clientUser client) (clientProfile client) (clientResource client)
 
   where
     getTTYandPID muid = do
@@ -226,8 +236,8 @@ forClient state k fallback f = do
 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)
+    fallback  = localJID "nobody" "." "fallback"
+    go client = localJID (clientUser client) (clientProfile client) (clientResource client)
 
 toMapUnit :: Ord k => [k] -> Map k ()
 toMapUnit xs = Map.fromList $ map (,()) xs
@@ -237,11 +247,11 @@ resolveAllPeers hosts = fmap (toMapUnit . concat) $ Prelude.mapM (fmap (take 1)
 
 
 rosterGetStuff
-  :: (L.ByteString -> IO [L.ByteString])
+  :: (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString])
      -> PresenceState -> ConnectionKey -> IO [Text]
 rosterGetStuff what state k = forClient state k (return [])
     $ \client -> do
-    jids <- configText what (clientUser client)
+    jids <- configText what (clientUser client) (clientProfile client)
     let hosts = map ((\(_,h,_)->h) . splitJID) jids
     case state of
       PresenceState { server = svVar } -> do
@@ -267,13 +277,16 @@ 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]
+            (ConfigFiles.User -> ConfigFiles.Profile -> f [L.ByteString])
+            -> Text     -- user
+            -> Text     -- profile
+            -> f [Text] -- items
+configText what u p = fmap (map lazyByteStringToText)
+                        $ what (textToLazyByteString u) (Text.unpack p)
+
+getBuddies' :: Text -> Text -> IO [Text]
 getBuddies' = configText ConfigFiles.getBuddies
-getSolicited' :: Text -> IO [Text]
+getSolicited' :: Text -> Text -> IO [Text]
 getSolicited' = configText ConfigFiles.getSolicited
 
 sendProbesAndSolicitations :: PresenceState
@@ -282,10 +295,11 @@ 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
+        (user,LocalPresence cmap) <- liftT $ Map.toList cbu
+        profile <- liftT $ nub $ map clientProfile $ Map.elems cmap
         (isbud,getter) <- liftT [(True ,getBuddies'  )
                                 ,(False,getSolicited')]
-        bud  <- liftMT $ getter user
+        bud  <- liftMT $ getter user profile
         let (u,h,r) = splitJID bud
         addr <- liftMT $ nub `fmap` resolvePeer h
         liftT $ guard (PeerKey addr == k)
@@ -294,10 +308,10 @@ sendProbesAndSolicitations state k laddr chan = do
         -- 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)
+        return (isbud,u,user,profile)
     -- XXX: The following O(n²) nub may be a little
     --      too onerous.
-    forM_ (nub xs) $ \(isbud,u,user) -> do
+    forM_ (nub xs) $ \(isbud,u,user,profile) -> do
         let make = if isbud then presenceProbe
                             else presenceSolicitation
             toh = peerKeyToText k
@@ -378,13 +392,17 @@ rewriteJIDForClient laddr jid buds = do
                   else peerKeyToResolvedName buds (PeerKey addr)
     return (mine,(n,h',r))
 
+-- This attempts to reverse resolve a peers address to give the human-friendly
+-- domain name as it appears in the roster.  It prefers host names that occur
+-- in the given list of JIDs, but will fall back to any reverse-resolved name
+-- and if it was unable to reverse the address, it will yield an ip address.
 peerKeyToResolvedName :: [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')
+    return $ fromMaybe (peerKeyToText pk) (listToMaybe ns')
 
 
 multiplyJIDForClient :: SockAddr -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)])
@@ -468,33 +486,46 @@ deliverMessage state fail msg =
         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
+        chans <- fmap (fromMaybe []) $ do
+            forM (n >>= flip Map.lookup cmap) $ \presence_container -> do
+            let ks = Map.keys (networkClients presence_container)
+                chans = do
+                    (k,client) <- Map.toList $ networkClients presence_container
+                    chan <- maybeToList $ Map.lookup k key_to_chan
+                    return (clientProfile client, chan)
+            forM chans $ \(profile,chan) -> do
+            buds <- configText ConfigFiles.getBuddies (fromJust n) profile
             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)
+            return (from',chan)
         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
+        if null chans then do
+            forM_ (stanzaFrom msg) $ \from -> do
+            from' <- do
+                -- Fallback to "." profile when no clients.
+                buds <- maybe (return [])
+                              (\n -> configText ConfigFiles.getBuddies n ".")
+                              n
+                (_,trip) <- rewriteJIDForClient laddr from buds
+                return . Just $ unsplitJID trip
+            let msg' = msg { stanzaTo=Just to'
+                           , stanzaFrom=from' }
+            deliverToConsole state fail msg'
+        else do
+            forM_ chans $ \(from',Conn { connChan=chan}) -> do
+            -- TODO: Cloning isn't really 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.
+            let msg' = msg { stanzaTo=Just to'
+                           , stanzaFrom=from' }
+            dup <- cloneStanza msg'
+            sendModifiedStanzaToClient dup
+                                      chan
 
 
 setClientFlag :: PresenceState -> ConnectionKey -> Int8 -> IO ()
@@ -513,9 +544,9 @@ informSentRoster state k = do
     setClientFlag state k cf_interested
 
 
-subscribedPeers :: Text -> IO [SockAddr]
-subscribedPeers user = do
-    jids <- configText ConfigFiles.getSubscribers user
+subscribedPeers :: Text -> Text -> IO [SockAddr]
+subscribedPeers user profile = do
+    jids <- configText ConfigFiles.getSubscribers user profile
     let hosts = map ((\(_,h,_)->h) . splitJID) jids
     fmap Map.keys $ resolveAllPeers hosts
 
@@ -546,7 +577,7 @@ informClientPresence0 state mbk client stanza = do
     when (not is_avail) $ do
         atomically $ setClientFlag0 client cf_available
         maybe (return ()) (sendCachedPresence state) mbk
-    addrs <- subscribedPeers (clientUser client)
+    addrs <- subscribedPeers (clientUser client) (clientProfile client)
     ktc <- atomically $ readTVar (keyToChan state)
     let connected = mapMaybe (flip Map.lookup ktc . PeerKey) addrs
     forM_ connected $ \con -> do
@@ -649,7 +680,7 @@ answerProbe state mto k chan = do
 
     flip (maybe $ return ()) muser $ \(u,conn,ch) -> do
 
-    resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u
+    resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u (_todo {- profile -})
     let gaddrs = groupBy (\a b -> snd a == snd b) (sort resolved_subs)
         whitelist = do
             xs <- gaddrs
@@ -693,7 +724,7 @@ 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)
+    jids <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client)
     let hosts = map ((\(_,h,_)->h) . splitJID) jids
     addrs <- resolveAllPeers hosts
     let onlines = rbp `Map.intersection` Map.mapKeys PeerKey addrs
@@ -714,7 +745,7 @@ sendCachedPresence state k = do
         sendModifiedStanzaToClient (dup { stanzaFrom=Just from' })
                                    (connChan con)
 
-    pending <- configText ConfigFiles.getPending (clientUser client)
+    pending <- configText ConfigFiles.getPending (clientUser client) (clientProfile client)
     hostname <- textHostName
     forM_ pending $ \pending_jid -> do
         let cjid = unsplitJID ( Just $ clientUser client
@@ -728,27 +759,39 @@ sendCachedPresence state k = do
     return ()
 
 addToRosterFile :: (MonadPlus t, Traversable t) =>
-                 (L.ByteString -> (L.ByteString -> IO (t L.ByteString))
+                 (ConfigFiles.User
+                  -> ConfigFiles.Profile
+                  -> (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
+                 -> Text -- user
+                 -> Text -- profile
+                 -> Text -> [SockAddr] -> t1
+addToRosterFile doit whose profile to addrs =
+    modifyRosterFile doit whose profile to addrs True
 
 removeFromRosterFile :: (MonadPlus t, Traversable t) =>
-                      (L.ByteString -> (L.ByteString -> IO (t L.ByteString))
+                      (ConfigFiles.User
+                       -> ConfigFiles.Profile
+                       -> (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
+                      -> Text -- user
+                      -> Text -- profile
+                      -> Text -> [SockAddr] -> t1
+removeFromRosterFile doit whose profile to addrs =
+    modifyRosterFile doit whose profile to addrs False
 
 modifyRosterFile :: (Traversable t, MonadPlus t) =>
-                  (L.ByteString -> (L.ByteString -> IO (t L.ByteString))
+                  (ConfigFiles.User
+                   -> ConfigFiles.Profile
+                   -> (L.ByteString -> IO (t L.ByteString))
                    -> Maybe L.ByteString
                    -> t1)
-                  -> Text -> Text -> [SockAddr] -> Bool -> t1
-modifyRosterFile doit whose to addrs bAdd = do
+                  -> Text -- user
+                  -> Text -- profile
+                  -> Text -> [SockAddr] -> Bool -> t1
+modifyRosterFile doit whose profile to addrs bAdd = do
     let (mu,_,_) = splitJID to
         cmp jid = runTraversableT $ do
             let (msu,stored_h,mr) = splitJID (lazyByteStringToText jid)
@@ -767,7 +810,7 @@ modifyRosterFile doit whose to addrs bAdd = do
             if null (stored_addrs \\ addrs) then mzero else do
             -- keep
             return jid
-    doit (textToLazyByteString whose)
+    doit (textToLazyByteString whose) (Text.unpack profile)
          cmp
          (guard bAdd >> Just (textToLazyByteString to))
 
@@ -781,9 +824,9 @@ clientSubscriptionRequest state fail k stanza chan = do
     flip (maybe fail) mu $ \u -> do
     -- add to-address to from's solicited
     addrs <- resolvePeer h
-    addToRosterFile ConfigFiles.modifySolicited (clientUser client) to addrs
-    removeFromRosterFile ConfigFiles.modifyBuddies (clientUser client) to addrs
-    resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers (clientUser client)
+    addToRosterFile ConfigFiles.modifySolicited (clientUser client) (clientProfile client) to addrs
+    removeFromRosterFile ConfigFiles.modifyBuddies (clientUser client) (clientProfile client) to addrs
+    resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers (clientUser client) (clientProfile client)
     let is_subscribed = not . null $ intersect (map ((mu,).PeerKey) addrs) resolved_subs
     -- subscribers: "from"
     -- buddies: "to"
@@ -831,10 +874,10 @@ clientSubscriptionRequest state fail k stanza chan = do
 
 
 resolvedFromRoster
-  :: (L.ByteString -> IO [L.ByteString])
-     -> UserName -> IO [(Maybe UserName, ConnectionKey)]
-resolvedFromRoster doit u = do
-    subs <- configText doit u
+  :: (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString])
+     -> UserName -> Text -> IO [(Maybe UserName, ConnectionKey)]
+resolvedFromRoster doit u profile = do
+    subs <- configText doit u profile
     runTraversableT $ do
             (mu,h,_) <- liftT $ splitJID `fmap` subs
             addr <- liftMT $ fmap nub $ resolvePeer h
@@ -870,7 +913,7 @@ peerSubscriptionRequest state fail k stanza chan = 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
+    resolved_subs <- resolvedFromRoster ConfigFiles.getSubscribers u (_todo {- profile -})
     let already_subscribed = elem (mfrom_u,k) resolved_subs
         is_wanted = case stanzaType stanza of
                       PresenceRequestSubscription b -> b
@@ -900,9 +943,9 @@ peerSubscriptionRequest state fail k stanza chan = do
 
     already_pending <-
       if is_wanted then
-        addToRosterFile ConfigFiles.modifyPending u from' addrs
+        addToRosterFile ConfigFiles.modifyPending u (_todo {- profile -}) from' addrs
       else do
-        removeFromRosterFile ConfigFiles.modifySubscribers u from' addrs
+        removeFromRosterFile ConfigFiles.modifySubscribers u (_todo {- profile -}) from' addrs
         reply <- makeInformSubscription "jabber:server" to from is_wanted
         sendModifiedStanzaToPeer reply chan
         return False
@@ -933,9 +976,9 @@ clientInformSubscription state fail k stanza = do
     let (mu,h,mr) = splitJID to
     addrs <- resolvePeer h
     -- remove from pending
-    buds <- resolvedFromRoster ConfigFiles.getBuddies (clientUser client)
+    buds <- resolvedFromRoster ConfigFiles.getBuddies (clientUser client) (clientProfile client)
     let is_buddy = not . null $ map ((mu,) . PeerKey) addrs `intersect` buds
-    removeFromRosterFile ConfigFiles.modifyPending (clientUser client) to addrs
+    removeFromRosterFile ConfigFiles.modifyPending (clientUser client) (clientProfile client) to addrs
     let (relationship,addf,remf) =
          case stanzaType stanza of
            PresenceInformSubscription True ->
@@ -947,8 +990,8 @@ clientInformSubscription state fail k stanza = do
                                                else "none" )
                 , ConfigFiles.modifyOthers
                 , ConfigFiles.modifySubscribers )
-    addToRosterFile      addf (clientUser client) to addrs
-    removeFromRosterFile remf (clientUser client) to addrs
+    addToRosterFile      addf (clientUser client) (clientProfile client) to addrs
+    removeFromRosterFile remf (clientUser client) (clientProfile client) to addrs
 
     do
         cbu <- atomically $ readTVar (clientsByUser state)
@@ -1009,8 +1052,8 @@ peerInformSubscription state fail k stanza = do
     -- 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
+    was_solicited <- removeFromRosterFile ConfigFiles.modifySolicited user (_todo {- profile -}) from'' addrs
+    subs <- resolvedFromRoster ConfigFiles.getSubscribers user (_todo {- profile -})
     let is_sub = not . null $ map ((from_u,) . PeerKey) addrs `intersect` subs
     let (relationship,addf,remf) =
          case stanzaType stanza of
@@ -1023,8 +1066,8 @@ peerInformSubscription state fail k stanza = do
                                              else "none")
                 , ConfigFiles.modifyOthers
                 , ConfigFiles.modifyBuddies )
-    addToRosterFile      addf user from'' addrs
-    removeFromRosterFile remf user from'' addrs
+    addToRosterFile      addf user (_todo {- profile -}) from'' addrs
+    removeFromRosterFile remf user (_todo {- profile -}) from'' addrs
 
     hostname <- textHostName
     let to' = unsplitJID (Just user, hostname, Nothing)
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 5a0ed20e..6f4a191b 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -134,7 +134,7 @@ data StanzaType
     = Unrecognized
     | Ping
     | Pong
-    | RequestResource (Maybe Text)
+    | RequestResource (Maybe Text) (Maybe Text) -- ^ Client's name for this host followed by client's requested resource id.
     | SetResource
     | SessionRequest
     | UnrecognizedQuery Name
@@ -179,39 +179,40 @@ type Stanza = StanzaWrap (LockedChan XML.Event)
 
 data XMPPServerParameters =
     XMPPServerParameters
-    { -- | Called when a client requests a resource id.  The Maybe value is the
-      -- client's preference.
-      xmppChooseResourceName :: ConnectionKey -> SockAddr -> Maybe Text -> IO Text
+    { -- | Called when a client requests a resource id.  The first Maybe indicates
+      --   the name the client referred to this server by.  The second Maybe is the
+      --   client's preferred resource name.
+      xmppChooseResourceName :: ConnectionKey -> SockAddr -> Maybe Text -> Maybe Text -> IO Text
     , -- | This should indicate the server's hostname that all client's see.
       xmppTellMyNameToClient :: IO Text
-    , xmppTellMyNameToPeer :: SockAddr -> IO Text
-    , xmppTellClientHisName :: ConnectionKey -> IO Text
-    , xmppTellPeerHisName :: ConnectionKey -> IO Text
-    , xmppNewConnection :: ConnectionKey -> SockAddr -> TChan Stanza -> IO ()
-    , xmppEOF :: ConnectionKey -> IO ()
+    , xmppTellMyNameToPeer   :: SockAddr -> IO Text
+    , xmppTellClientHisName  :: ConnectionKey -> IO Text
+    , xmppTellPeerHisName    :: ConnectionKey -> IO Text
+    , xmppNewConnection      :: ConnectionKey -> SockAddr -> TChan Stanza -> IO ()
+    , xmppEOF                :: ConnectionKey -> IO ()
     , xmppRosterBuddies      :: ConnectionKey -> IO [Text]
     , xmppRosterSubscribers  :: ConnectionKey -> IO [Text]
     , xmppRosterSolicited    :: ConnectionKey -> IO [Text]
     , xmppRosterOthers       :: ConnectionKey -> IO [Text]
     , -- | Called when after sending a roster to a client.  Usually this  means
       -- the client status should change from "available" to "interested".
-      xmppSubscribeToRoster :: ConnectionKey -> IO ()
+      xmppSubscribeToRoster  :: ConnectionKey -> IO ()
     -- , xmppLookupClientJID :: ConnectionKey -> IO Text
     , xmppTellClientNameOfPeer :: ConnectionKey -> [Text] -> IO Text
-    , xmppDeliverMessage :: (IO ()) -> Stanza -> IO ()
+    , xmppDeliverMessage     :: (IO ()) -> Stanza -> IO ()
       -- | Called whenever a local client's presence changes.
     , xmppInformClientPresence :: ConnectionKey -> Stanza -> IO ()
       -- | Called whenever a remote peer's presence changes.
     , xmppInformPeerPresence :: ConnectionKey -> Stanza -> IO ()
     , -- | Called when a remote peer requests our status.
-      xmppAnswerProbe :: ConnectionKey -> Stanza -> TChan Stanza -> IO ()
+      xmppAnswerProbe        :: ConnectionKey -> Stanza -> TChan Stanza -> IO ()
     , xmppClientSubscriptionRequest :: IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO ()
     , -- | Called when a remote peer sends subscription request.
       xmppPeerSubscriptionRequest :: IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO ()
     , xmppClientInformSubscription :: IO () -> ConnectionKey -> Stanza -> IO ()
     , -- | Called when a remote peer informs us of our subscription status.
       xmppPeerInformSubscription :: IO () -> ConnectionKey -> Stanza -> IO ()
-    , xmppVerbosity :: IO Int
+    , xmppVerbosity          :: IO Int
     }
 
 
@@ -584,9 +585,9 @@ grokStanzaIQSet stanza = do
             case fmap tagName mchild of
                 Just "{urn:ietf:params:xml:ns:xmpp-bind}resource" -> do
                     rsc <- XML.content -- TODO: MonadThrow???
-                    return . Just $ RequestResource (Just rsc)
+                    return . Just $ RequestResource Nothing (Just rsc)
                 Just _ -> return Nothing
-                Nothing -> return . Just $ RequestResource Nothing
+                Nothing -> return . Just $ RequestResource Nothing Nothing
         "{urn:ietf:params:xml:ns:xmpp-session}session" -> do
             return $ Just SessionRequest
         _ -> return Nothing
@@ -886,10 +887,10 @@ xmppInbound :: Server ConnectionKey SockAddr ReleaseKey XML.Event
                 -> XMPPServerParameters
                 -> ConnectionKey
                 -> SockAddr
-                -> FlagCommand -- ^ action to check whether the connection needs a ping
-                -> TChan Stanza -- ^ channel to announce incomming stanzas on
+                -> FlagCommand  -- ^ action to check whether the connection needs a ping
+                -> TChan Stanza -- ^ channel to announce incoming stanzas on
                 -> TChan Stanza -- ^ channel used to send stanzas
-                -> TMVar () -- ^ mvar that is filled when the connection quits
+                -> TMVar ()     -- ^ mvar that is filled when the connection quits
                 -> Sink XML.Event IO ()
 xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do
     let (namespace,tellmyname,tellyourname) = case k of
@@ -906,6 +907,9 @@ xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do
     when (begindoc==EventBeginDocument) $ do
     whenJust nextElement $ \xml -> do
     withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
+    -- liftIO $ hPutStrLn stderr $ "STREAM ATTRS "++show stream_attrs
+    let stream_name  = lookupAttrib "to"      stream_attrs
+     -- xmpp_version = lookupAttrib "version" stream_attrs
     fix $ \loop -> do
     -- liftIO . wlog $ "waiting for stanza."
     (chan,clsrs) <- liftIO . atomically $
@@ -916,9 +920,9 @@ xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do
             writeLChan chan stanzaTag
             modifyTVar' clsrs (fmap (closerFor stanzaTag:))
         copyToChannel id chan clsrs =$= do
-          let mid   = lookupAttrib "id" (tagAttrs stanzaTag)
-              mfrom = lookupAttrib "from" (tagAttrs stanzaTag)
-              mto = lookupAttrib "to" (tagAttrs stanzaTag)
+          let mid   = lookupAttrib "id"   $ tagAttrs stanzaTag
+              mfrom = lookupAttrib "from" $ tagAttrs stanzaTag
+              mto   = lookupAttrib "to"   $ tagAttrs stanzaTag
           dispatch <- grokStanza namespace stanzaTag
           let unrecog = do
                 let stype = Unrecognized
@@ -960,14 +964,15 @@ xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do
                             }
 #endif
               stype -> ioWriteChan stanzas Stanza
-                            { stanzaType = stype
-                            , stanzaId = mid
-                            , stanzaTo = mto
-                            , stanzaFrom = mfrom
-                            , stanzaChan = chan
-                            , stanzaClosers = clsrs
+                            { stanzaType      = case stype of
+                                RequestResource _ rsc -> RequestResource stream_name rsc
+                            , stanzaId        = mid
+                            , stanzaTo        = mto
+                            , stanzaFrom      = mfrom
+                            , stanzaChan      = chan
+                            , stanzaClosers   = clsrs
                             , stanzaInterrupt = donevar
-                            , stanzaOrigin = NetworkOrigin k output
+                            , stanzaOrigin    = NetworkOrigin k output
                             }
           awaitCloser stanza_lvl
         liftIO . atomically $ writeTVar clsrs Nothing
@@ -1670,9 +1675,9 @@ monitor sv params xmpp = do
             case stanzaOrigin stanza of
                 NetworkOrigin k@(ClientKey {}) replyto ->
                     case stanzaType stanza of
-                        RequestResource wanted -> do
+                        RequestResource clientsNameForMe wanted -> do
                             sockaddr <- socketFromKey sv k
-                            rsc <- xmppChooseResourceName xmpp k sockaddr wanted
+                            rsc <- xmppChooseResourceName xmpp k sockaddr clientsNameForMe wanted
                             let reply = iq_bind_reply (stanzaId stanza) rsc
                             -- sendReply quitVar SetResource reply replyto
                             hostname <- xmppTellMyNameToClient xmpp