1 files changed, 128 insertions, 85 deletions

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)