Get username and tty for jid

1 files changed, 96 insertions, 6 deletions

diff --git a/xmppServer.hs b/xmppServer.hs
index 3a16aca5..ec3a618d 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -13,21 +13,111 @@ import Network.Socket
 import Data.Monoid ( (<>) )
 import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
+import qualified Data.Text.Encoding as Text
 import Control.Monad
 import qualified Network.BSD as BSD
+import qualified Data.Text as Text
+import Data.Text (Text)
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Control.Exception ({-evaluate,-}handle,SomeException(..),bracketOnError,ErrorCall(..))
+import System.Posix.User (getUserEntryForID,userName)
+import qualified Data.ByteString.Lazy.Char8 as L
 
-
+import UTmp (ProcessID,users)
+import LocalPeerCred
 import XMPPServer
 import Server
 
+textHostName = fmap Text.pack BSD.getHostName
+
+localJID user resource = do
+    hostname <- textHostName
+    return $ user <> "@" <> hostname <> "/" <> resource
+
+data ClientState = ClientState
+    { clientResource :: Text
+    , clientUser :: Text
+    , clientPid :: Maybe ProcessID
+    }
+
+data PresenceState = PresenceState
+    { clients :: TVar (Map ConnectionKey ClientState)
+    }
+
+getConsolePids :: PresenceState -> IO [(Text,ProcessID)]
+getConsolePids state = do --  return [("tty7", 23)] -- todo
+    us <- UTmp.users
+    return $ map (\(_,tty,pid)->(lazyByteStringToText tty,pid)) us
+
+lazyByteStringToText = (foldr1 (<>) . map Text.decodeUtf8 . L.toChunks)
+
+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 state k addr desired = do
+    muid <- getLocalPeerCred' addr
+    (mtty,pid) <- getTTYandPID muid
+    user <- getJabberUserForId muid
+    let client = ClientState { clientResource = maybe "fallback" id mtty
+                             , clientUser = user
+                             , clientPid = pid }
+
+    atomically $
+        modifyTVar' (clients state) $ Map.insert k client
+    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 state k fallback f = do
+    mclient <- atomically $ do
+        cs <- readTVar (clients state)
+        return $ Map.lookup k cs
+    maybe (fallback k) (flip f k) mclient
+
+tellClientHisName state k = forClient state k fallback go
+ where
+    fallback k = localJID "nobody" "fallback"
+    go client k = localJID (clientUser client) (clientResource client)
+
+
 main = runResourceT $ do
-    hostname <- fmap Text.pack $ liftIO BSD.getHostName
+    -- us <- liftIO UTmp.users
+    -- liftIO $ putStrLn (show us)
+    hostname <- liftIO textHostName
+    state <- do
+        clients <- liftIO . atomically $ newTVar Map.empty
+        return PresenceState
+            { clients = clients
+            }
     sv <- xmppServer
         XMPPServerParameters
-        { xmppChooseResourceName = \k sock desired -> return $ "nobody@" <> hostname <> "/tty666"
-        , xmppTellMyNameToClient = return hostname
+        { xmppChooseResourceName = chooseResourceName state
+        , xmppTellClientHisName = tellClientHisName state
+        , xmppTellMyNameToClient = textHostName
         , xmppTellMyNameToPeer = \addr -> return $ addrToText addr
-        , xmppTellClientHisName = \k -> return $ "nobody@" <> hostname <> "/tty666"
         , xmppTellPeerHisName = return . peerKeyToText
         , xmppNewConnection = \k outchan -> return ()
         , xmppEOF = \k -> return ()
@@ -37,7 +127,7 @@ main = runResourceT $ do
         , xmppRosterOthers = \k -> return []
         , xmppSubscribeToRoster = \k -> return ()
         , xmppLookupPeerName = \k ->  return "localhost"
-        , xmppLookupClientJID = \k -> return $ "nobody@" <> hostname <> "/tty666"
+        -- , xmppLookupClientJID = \k -> return $ "nobody@" <> hostname <> "/tty666"
         , xmppDeliverMessage = \fail msg -> do
             let msgs = msgLangMap (stanzaType msg)
                 body = fmap (maybe "" id . msgBody . snd) $ take 1 msgs