{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module Main where import System.Directory import Control.Monad import System.Posix.Signals import System.Posix.Types import System.Posix.Process import Data.Maybe import Data.Char import ConfigFiles import Control.Arrow (second) import Data.Traversable (sequenceA) import System.INotify #ifndef NOUTMP import UTmp -- UTmp is inconvenient for the profiling build due to Template Haskell -- causing ghc to report "Dynamic linking required,..." -- -- To make a full-featured profiling build, the bp script will make a -- non-profiling binary for BitSyntax available to an otherwise-profiling -- build. #endif import FGConsole import XMPP import ControlMaybe import Data.HList import Control.Exception hiding (catch) import LocalPeerCred import System.Posix.User import Logging import qualified Data.Set as Set import Data.Set as Set ((\\)) import qualified Data.Map as Map import Data.Map as Map (Map) import Control.Concurrent.STM import Control.Concurrent import Control.Monad.Trans.Maybe import Control.Monad.IO.Class import ByteStringOperators import qualified Data.ByteString.Lazy.Char8 as L import Data.ByteString.Lazy.Char8 as L (ByteString) import qualified Prelude import Prelude hiding (putStrLn) import System.Environment -- import qualified Text.Show.ByteString as L import Network.Socket (Family(AF_INET,AF_INET6)) import Holumbus.Data.MultiMap as MM (MultiMap) import qualified Holumbus.Data.MultiMap as MM data Client = Client { clientShow :: JabberShow, clientChan :: TChan ClientCommands } -- see Data.Map.Lazy.fromSet fromSet f = Map.fromList . map (\a -> (a,f a)) . Set.toList -- see Data.Map.Lazy.keysSet keys = map fst . Map.toList {- PresenceState - - This is the global state for the xmpp daemon. - It is not directly accessed outside of this module. -} data PresenceState = PresenceState { hostname :: Peer -- ByteString, TODO: remove this, its always LocalHost now -- currentTTY - a string such as "tty7" which is kept up to date as console -- switches occur. , currentTTY :: TVar ByteString -- activeUsers - a is a set of triples representing data in /var/run/utmp -- it is kept up to date by an inotify watch on that file. , activeUsers :: TVar (Map (UserName, Tty) (ProcessID, Map ProcessID Client)) -- subscriberMap - the idea was to allow subscribing to a particular user only. -- When that user becomes present, an announcement would be sent -- on the channel associated with him. This functionality is currently -- unused and may be removed soon if it's decided its unneccessary. , subscriberMap :: TVar (Map JID (RefCount,TChan Presence)) -- UNUSED as yet -- localSubscriber - a channel and reference count where all presence events are -- announced. , localSubscriber :: TMVar (RefCount,TChan Presence) -- TODO: rename this, its not just locals -- ... or make a seperate channel for remotes -- rosterChannel - a channel and reference count where all roster change events are -- announced , rosterChannel :: TMVar (RefCount,TChan RosterEvent) -- remoteUsers - a cache of remote users considered to be online. These are sent to a client -- on connect so that it can populate it's notion of online users. , remoteUsers :: TVar (Map Peer (RefCount,TVar (MultiMap JabberUser (JabberResource,JabberShow)))) -- remotePeers - a set of channels that may be used to send messages to remote peers. , remotePeers :: OutgoingConnections CachedMessages } {- newPresenceState - - This is a smart constructor for the global state. - This is currently used only from Main.start and PresenceState - records are not created by any means other than this constructor. -} newPresenceState hostname = atomically $ do tty <- newTVar "" us <- newTVar (Map.empty) subs <- newTVar (Map.empty) locals_greedy <- newEmptyTMVar rchan <- newEmptyTMVar remotes <- newTVar (Map.empty) server_connections <- newOutgoingConnections toPeer return $ PresenceState hostname tty us subs locals_greedy rchan remotes server_connections {- ClientSessions - - This is the per-client state. It is manipulated mainly via the - JabberClientSession interface. -} data ClientSession = ClientSession { localhost :: Peer, -- anotehr name or the LocalHost constructor, todo: remove this. -- unix_uid: This is the detected uid of the user of the connecting client. -- The ByteString is the numeric inode text parsed from /proc/net/tcp6 -- (*not* the login name of the user) unix_uid :: (IORef (Maybe (UserID,L.ByteString))), unix_pid :: Maybe CPid, -- unix_resource: This is the detected TTY of the connecting client. unix_resource :: (IORef (Maybe L.ByteString)), -- chans: This is a list of channels that the session is reading and will be -- whose counts will be decremented when the session ends. -- Note: currently is likely to be only two channels, the -- localSubscriber & rosterChannel of the global state record. chans :: TVar [RefCountedChan], clientChannel :: TChan ClientCommands, -- presence_state: a reference to the global state. presence_state :: PresenceState } instance JabberClientSession ClientSession where data XMPPClass ClientSession = ClientSessions PresenceState newSession (ClientSessions state) sock = do -- muid <- getLocalPeerCred sock addr <- getPeerName sock muid <- getLocalPeerCred' addr debugL $ "CLIENT SESSION: open " <++> bshow muid uid_ref <- newIORef muid (mtty,pid) <- getTTYandPID muid res_ref <- newIORef mtty chans <- atomically $ newTVar [] clientChan <- atomically $ newTChan return $ ClientSession (hostname state) uid_ref pid res_ref chans clientChan state where getTTYandPID muid = do us <- fmap (map (second fst) . Map.toList) . readTVarIO $ activeUsers state let tailOf3 ((_,a),b) = (a,b) (t,pid) <- case muid of Just (uid,inode) -> identifyTTY (map tailOf3 us) uid inode Nothing -> return (Nothing,Nothing) let rsc = t `mplus` fmap ( ("pid."<++>) . bshow ) pid return (rsc,pid) setResource s wanted_resource = do -- TODO: handle resource = empty string rsc <- readIORef (unix_resource s) let rsc' = maybe wanted_resource id rsc writeIORef (unix_resource s) (Just rsc') debugL $ "CLIENT SESSION: resource " <++> rsc' <++> " (wanted: "<++>wanted_resource<++>")" setPresence s stat = do withJust (unix_pid s) $ \client_pid -> do whenJust (readIORef (unix_resource s)) $ \tty -> do user <- readIORef (unix_uid s) >>= getJabberUserForId greedysubs <- atomically $ do let au = activeUsers . presence_state $ s us <- readTVar au sequenceA $ Map.lookup (user,tty) us >>= \(ttypid,cs) -> do let entry = (ttypid, Map.insert client_pid (Client { clientShow = stat, clientChan = Main.clientChannel s }) cs) Just $ do writeTVar au (Map.insert (user,tty) entry us) subs <- readTVar $ subscriberMap (presence_state s) greedy <- fmap snd . readTMVar $ localSubscriber (presence_state s) activetty <- readTVar $ currentTTY (presence_state s) usermap <- readTVar $ activeUsers (presence_state s) return (greedy,subs,activetty,usermap) withJust greedysubs $ \(greedy,subs,active_tty,usermap) -> do update_presence (Just greedy) (fmap snd subs) [JID (Just user) (localhost s) (Just tty)] (matchResource usermap active_tty) getJID s = do let host = localhost s user <- readIORef (unix_uid s) >>= getJabberUserForId rsc <- readIORef (unix_resource s) -- let jid = user <++> "@" <++> host <++?> "/" <++$> rsc -- debugL $ "CLIENT SESSION: jid " <++> L.show (JID (Just user) host rsc) return (JID (Just user) host rsc) closeSession s = do atomically $ do cs <- readTVar (chans s) forM_ cs $ \(RefCountedChan c) -> do unsubscribeToChan c debugL "CLIENT SESSION: close" withJust (unix_pid s) $ \client_pid -> do whenJust (readIORef (unix_resource s)) $ \tty -> do user <- readIORef (unix_uid s) >>= getJabberUserForId atomically $ do let au = activeUsers . presence_state $ s us <- readTVar au let remove = second (Map.delete client_pid) writeTVar au (Map.adjust remove (user,tty) us) subscribe session Nothing = do let tmvar = localSubscriber (presence_state session) atomically $ do cs <- readTVar (chans session) writeTVar (chans session) (RefCountedChan tmvar:cs) subscribeToChan tmvar subscribe session (Just jid) = do -- UNUSED as yet let tvar = subscriberMap (presence_state session) atomically $ subscribeToMap tvar jid subscribeToRoster session = do let rchan = rosterChannel . presence_state $ session atomically $ do cs <- readTVar (chans session) writeTVar (chans session) (RefCountedChan rchan:cs) subscribeToChan rchan clientChannel session = Main.clientChannel session forCachedPresence s action = do jid <- getJID s debugL $ "forCachedPresence "<++> bshow jid withJust (name jid) $ \user -> do let parseHostNameJID' str = do handle (\(SomeException _) -> return Nothing) (fmap Just . parseHostNameJID $ str) buddies <- do buddies <- ConfigFiles.getBuddies user fmap catMaybes (mapM parseHostNameJID' buddies) remotes <- readTVarIO . remoteUsers . presence_state $ s forM_ buddies $ \buddy -> do debugL $ "forCachedPresence buddy = "<++> bshow buddy let mjids = fmap snd $ Map.lookup (peer buddy) remotes jids <- maybe (return MM.empty) readTVarIO mjids debugL $ "forCachedPresence jids = "<++> bshow jids withJust (splitResource buddy) $ \(buddyU,_) -> do forM_ (Set.toList . MM.lookup buddyU $ jids) $ \(rsc,status) -> do let p = Presence (buddy `withResource` Just rsc) status debugL $ "cached presence: " <++> bshow p action p -- forCachedPresence jids = MM (fromList -- [(JabberUser (Chunk "joe" Empty) (RemotePeer [fde3:6df:8be1:81ef:8bae:a0df:9c5d:5]:0) -- ,fromList [(Chunk "tty7" Empty,Available)])]) -- cached presence: Presence joe@[fde3:6df:8be1:81ef:8bae:a0df:9c5d:5] Available sendPending s = do jid <- getJID s debugL $ "sendPending "<++> bshow jid flip (maybe (return ())) (name jid) $ \user -> do pending <- ConfigFiles.getPending user let getRChan = do let rchan = rosterChannel . presence_state $ s isempty <- isEmptyTMVar rchan if (not isempty) then do (_,ch) <- readTMVar rchan return . Just $ ch else return Nothing atomically $ do whenJust getRChan $ \rchan -> do forM_ pending (writeTChan rchan . PendingSubscriber user) addSolicited s jid_str jid = do me <- getJID s withJust (name me) $ \user -> do addRawJid ConfigFiles.modifySolicited user jid_str rosterPush (RequestedSubscription user jid_str) (presence_state s) sendMessage (remotePeers . presence_state $ s) (Solicitation me jid) (peer jid) getMyBuddies s = do user <- readIORef (unix_uid s) >>= getJabberUserForId ConfigFiles.getBuddies user getMySubscribers s = do user <- readIORef (unix_uid s) >>= getJabberUserForId ConfigFiles.getSubscribers user getMyOthers s = do user <- readIORef (unix_uid s) >>= getJabberUserForId ConfigFiles.getOthers user getMyPending s = do user <- readIORef (unix_uid s) >>= getJabberUserForId ConfigFiles.getPending user getMySolicited s = do user <- readIORef (unix_uid s) >>= getJabberUserForId ConfigFiles.getSolicited user isSubscribed s contact = do handleIO (\e -> return False) $ do user <- readIORef (unix_uid s) >>= getJabberUserForId subs <- ConfigFiles.getSubscribers user debugL $ "isSubscribed parsing: "<++>contact cjid <- parseHostNameJID contact msubs <- mapM (cmpJID cjid) subs return (Nothing `elem` msubs) isBuddy s contact = do handleIO (\e -> return False) $ do user <- readIORef (unix_uid s) >>= getJabberUserForId subs <- ConfigFiles.getBuddies user debugL $ "isBuddy parsing: "<++>contact cjid <- parseHostNameJID contact msubs <- mapM (cmpJID cjid) subs return (Nothing `elem` msubs) approveSubscriber s contact = do user <- readIORef (unix_uid s) >>= getJabberUserForId cjid <- parseHostNameJID contact let rmjid modify user buddy = modify user (cmpJID buddy) Nothing -- update config files addRawJid ConfigFiles.modifySubscribers user contact -- add subscribers rmjid ConfigFiles.modifyPending user cjid rmjid ConfigFiles.modifyOthers user cjid -- roster push rosterPush (NewSubscriber user contact) (presence_state s) -- notify peer sendMessage (remotePeers . presence_state $ s) (Approval (JID (Just user) LocalHost Nothing) cjid) (peer cjid) presence <- getUserStatus (presence_state s) user let cons = remotePeers . presence_state $ s forM_ presence $ \p -> sendMessage cons (OutBoundPresence p) (peer cjid) return () rejectSubscriber s contact = do user <- readIORef (unix_uid s) >>= getJabberUserForId cjid <- parseHostNameJID contact let rmjid modify user buddy = modify user (cmpJID buddy) Nothing -- update config files was_pending <- rmjid ConfigFiles.modifyPending user cjid was_subscribed <- rmjid ConfigFiles.modifySubscribers user cjid addRawJid ConfigFiles.modifyOthers user contact -- roster push rosterPush (RejectSubscriber user contact) (presence_state s) -- notify peer when (was_pending || was_subscribed) $ do let cons = remotePeers . presence_state $ s isonline (Presence _ Offline) = False isonline _ = True presence <- fmap (filter isonline) $ getUserStatus (presence_state s) user me <- getJID s when (not (null presence)) $ sendMessage cons (OutBoundPresence . Presence me $ Offline) (peer cjid) sendMessage (remotePeers . presence_state $ s) (Rejection (JID (Just user) LocalHost Nothing) cjid) (peer cjid) return () sendChat s msg = do sendMessage (remotePeers . presence_state $ s) (OutBoundMessage msg) (peer . msgTo $ msg) {- PeerSession - - This is the per-remote-peer state. It is manipulated mainly via the - JabberPeerSession interface. -} data PeerSession = PeerSession { -- announced: a list of users that were announced by the remote peer. -- This list is kept in order to mark them all offline in -- case the peer connection is lost or goes down. announced :: TVar (MultiMap JabberUser (JabberResource,JabberShow)), -- peer_name: This the address of the remote peer. peer_name :: Peer, -- peer_global: a reference to the global state. peer_global :: PresenceState } instance JabberPeerSession PeerSession where data XMPPPeerClass PeerSession = PeerSessions PresenceState newPeerSession (PeerSessions state) sock = do me <- fmap (RemotePeer . withoutPort) (getPeerName sock) debugL $ "PEER SESSION: open "<++>showPeer me let remotes = remoteUsers state jids <- atomically $ getRefFromMap remotes me (newTVar MM.empty) return return $ PeerSession jids me state closePeerSession session = do debugL $ "PEER SESSION: close "<++>showPeer (peer_name session) let offline jid = Presence jid Offline unrefFromMap (remoteUsers . peer_global $ session) (peer_name session) $ do sendPeerMessage session Disconnect debugStr ("unrefFromMap!") js <- fmap (MM.toAscList) (readTVarIO . announced $ session) forM_ js $ \(u,rs) -> do forM_ (Set.toList rs) $ \(rsc,_) -> do debugStr ("Annoucing offline: "++show (offline $ unsplitResource u (Just rsc))) announcePresence session . offline $ unsplitResource u (Just rsc) peerSessionFactory session = PeerSessions (peer_global session) peerAddress session = peer_name session userStatus session user = getUserStatus (peer_global session) user -- This should be used on inbound presence to inform clients. -- For outbound, use sendPeerMessage and OutBoundPresence. announcePresence session (Presence jid status) = do (greedy,subs) <- atomically $ do subs <- readTVar $ subscriberMap (peer_global session) greedy <- fmap snd $ readTMVar $ localSubscriber (peer_global session) return (greedy,subs) update_presence (Just greedy) (fmap snd subs) [jid] (const status) liftIO . atomically $ do jids <- readTVar . announced $ session withJust (splitResource jid) $ \(u,rsc) -> do let match (r',_) = (rsc==Nothing || Just r'==rsc) writeTVar (announced session) $ case status of Offline -> MM.deleteElemIf u match jids stat -> maybe jids (\r -> MM.insert u (r,stat) jids) rsc sendPeerMessage session msg = do let cons = remotePeers . peer_global $ session debugL $ "sendPeerMessage " <++> bshow msg <++> " --> "<++>bshow (peer_name session) sendMessage cons msg (peer_name session) getBuddies _ user = ConfigFiles.getBuddies user getSubscribers _ user = ConfigFiles.getSubscribers user processApproval session user buddy = do solicited <- ConfigFiles.getSolicited user let rmjid modify user buddy = modify user (cmpJID buddy) Nothing was_sol <- rmjid ConfigFiles.modifySolicited user buddy when was_sol $ do -- if buddy ∈ solicited: addJid ConfigFiles.modifyBuddies user buddy -- add buddies rmjid ConfigFiles.modifyOthers user buddy -- remove others mbuddy <- asHostNameJID buddy withJust mbuddy $ \buddy -> do rosterPush (NewBuddy user buddy) (peer_global session) processRejection session user buddy = do solicited <- ConfigFiles.getSolicited user let rmjid modify user buddy = modify user (cmpJID buddy) Nothing was_sol <- rmjid ConfigFiles.modifySolicited user buddy when was_sol $ do -- if buddy ∈ solicited: rmjid ConfigFiles.modifyBuddies user buddy -- remove buddies addJid ConfigFiles.modifyOthers user buddy -- add others mbuddy <- asHostNameJID buddy withJust mbuddy $ \buddy -> do rosterPush (RemovedBuddy user buddy) (peer_global session) processRequest session user buddy = do let addjid modify user buddy = do hbuddy <- asHostNameJID buddy modify user (cmpJID buddy) hbuddy was_pending <- addjid ConfigFiles.modifyPending user buddy debugL $ "processRequest was_pending="<++>bshow was_pending -- "all available resources in accordence with section 8" -- Section 8 says (for presence of type "subscribe", the server MUST -- adhere to the rules defined under Section 3 and summarized under -- Appendix A. -- Appendex A.3.1 says -- contact ∈ subscribers --> SHOULD NOT, already handled -- contact ∉ subscribers & contact ∈ pending --> SHOULD NOT -- contact ∉ subscribers & contact ∉ pending --> MUST when (not was_pending) $ do mbuddy <- asHostNameJID buddy withJust mbuddy $ \buddy -> do rosterPush (PendingSubscriber user buddy) (peer_global session) sendChatToClient session msg = do let rsc = resource (msgTo msg) g = peer_global session (curtty,cmap) <- atomically $ liftM2 (,) (readTVar (currentTTY g)) (readTVar (activeUsers g)) let rsc' = maybe curtty id rsc withJust (name (msgTo msg)) $ \nto -> do case Map.lookup (nto,rsc') cmap of Just (ttypid,clients) -> forM_ (Map.toList clients) $ \(pid,client) -> do atomically $ writeTChan (clientChan client) (Chat msg) Nothing -> -- todo: fallback return () type RefCount = Int type JabberResource = L.ByteString type JabberName = L.ByteString data JabberUser = JabberUser JabberName Peer deriving (Eq,Ord,Show) splitResource :: JID -> Maybe (JabberUser,Maybe JabberResource) splitResource (JID Nothing _ _ ) = Nothing splitResource (JID (Just n) p r ) = Just (JabberUser n p, r) unsplitResource (JabberUser n p) r = JID (Just n) p r rosterPush msg state = do let rchan = rosterChannel state atomically $ do isempty <- isEmptyTMVar rchan when (not isempty) $ do (_,ch) <- readTMVar rchan writeTChan ch msg getJabberUserForId muid = maybe (return "nobody") (\(uid,_) -> handle (\(SomeException _) -> return . L.append "uid." . L.pack . show $ uid) $ do user <- fmap userName $ getUserEntryForID uid return (L.pack user) ) muid cmpJID newitem jid = do -- debugL $ "Comparing "<++>bshow jid olditem <- parseHostNameJID jid if olditem==newitem then return Nothing else return $ Just jid addRawJid modify user jid = do newitem <- parseHostNameJID jid modify user (cmpJID newitem) (Just jid) return () addJid modify user jid = do hjid <- asHostNameJID jid debugL $ "addJid (asHostNameJID) --> "<++>bshow hjid withJust hjid $ \hjid -> do modify user (cmpJID jid) (Just hjid) return () tupleToJID (user,tty) = jid user LocalHost tty filterKeys f m = Map.filterWithKey (\k v->f k) m getUserStatus state user = do (tty,users) <- atomically $ do tty <- readTVar $ currentTTY state users <- readTVar $ activeUsers state return (tty,users) let jids = filterKeys (\(name,tty) -> name ==user) users ps = map (\jid -> Presence (tupleToJID jid) (matchResource' tty jid)) . keys $ jids if null ps then return [Presence (JID { name=Just user, peer=LocalHost, resource=Nothing }) Offline] else return ps data RefCountedChan = forall a. RefCountedChan (TMVar (RefCount,TChan a)) subscribeToChan :: TMVar (RefCount, TChan a) -> STM (TChan a) subscribeToChan tmvar = (do (cnt,chan) <- takeTMVar tmvar putTMVar tmvar (cnt+1,chan) chan' <- dupTChan chan return chan' ) `orElse` (do chan <- newTChan putTMVar tmvar (1,chan) return chan ) unsubscribeToChan :: TMVar (RefCount,TChan a) -> STM () unsubscribeToChan tmvar = do isEmpty <- isEmptyTMVar tmvar when (not isEmpty) $ do (cnt,chan) <- takeTMVar tmvar when (cnt>1) (putTMVar tmvar (cnt-1,chan)) getRefFromMap tvar key newObject copyObject = do subs <- readTVar tvar let mbobject = Map.lookup key subs (object,subs') <- do case mbobject of Nothing -> do newobject <- newObject return (newobject, Map.insert key (1,newobject) subs) Just (cnt,object) -> do object' <- copyObject object return (object', Map.insert key (cnt+1,object) subs) writeTVar tvar subs' return object unrefFromMap tvar key finalizer = do vanished <- atomically $ do omap <- readTVar tvar let (r,omap') = Map.updateLookupWithKey unref key omap writeTVar tvar omap' -- updateLookupWithKey -- The function returns changed value, if it is updated. -- Returns the original key value if the map entry is deleted. -- GAAAHGAFHASD:LFKJDSA:LKFJPOFEIWE:FLJF!#@!$@#! -- FUCK YOU Data.Map -- Guess I have to do another pointless logarithmic lookup. return (isNothing (Map.lookup key omap')) when vanished finalizer where unref key (cnt,object) = if cnt==1 then Nothing else Just (cnt-1,object) subscribeToMap tvar jid = getRefFromMap tvar jid newTChan dupTChan matchResource usermap tty jid = maybe Away (avail . (==tty)) $ resource jid where avail True = case ( name jid >>= \u -> Map.lookup (u,tty) usermap ) of Nothing -> Available Just (pid,clients) -> let stats = map (clientShow . snd) . Map.toList $ clients in if null stats then Available else maximum stats avail False = Away matchResource' tty (_,rsc) = avail (rsc==tty) where avail True = Available avail False = Away sendPresence chan jid status = (liftIO . atomically . writeTChan chan . Presence jid $ status) :: MaybeT IO () lookupT jid subscribers = MaybeT . return $ Map.lookup jid subscribers update_presence locals_greedy subscribers state getStatus = forM_ state $ \jid -> do let status = getStatus jid runMaybeT $ do chan <- lookupT jid subscribers sendPresence chan jid status runMaybeT $ do chan <- MaybeT . return $ locals_greedy sendPresence chan jid status debugL $ bshow jid <++> " " <++> bshow status sendProbes state jid = do debugL $ "sending probes for " <++> bshow jid withJust (name jid) $ \user -> do let parseHostNameJID' str = do handle (\(SomeException _) -> return Nothing) (fmap Just . parseHostNameJID $ str) buddies <- do buddies <- ConfigFiles.getBuddies user fmap catMaybes (mapM parseHostNameJID' buddies) debugL $ "buddies for " <++> bshow jid <++> " = " <++> bshow buddies wanted <- do wanted <- ConfigFiles.getSolicited user fmap catMaybes (mapM parseHostNameJID' wanted) remotes <- readTVarIO (remoteUsers state) forM_ (map (True,) buddies ++ map (False,) wanted) $ \(got,buddy) -> do let mjids = fmap snd $ Map.lookup (peer buddy) remotes jids <- maybe (return MM.empty) readTVarIO mjids withJust (splitResource buddy) $ \(buddyU,_) -> do let noinfo = not (MM.member buddyU jids) when noinfo $ do let msg = if got then PresenceProbe jid buddy else Solicitation jid buddy debugL $ "sendMessage " <++> bshow msg sendMessage (remotePeers state) msg (peer buddy) track_login host state e = do #ifndef NOUTMP us <- UTmp.users #else let us = [] #endif let toJabberId host (user,tty,pid) = if L.take 3 tty == "tty" then Just ((user,tty),pid) -- (jid user host tty) else Nothing new_users0 = mapMaybe (toJabberId host) us new_users' = Map.fromList . map (\((u,tty),pid)-> ((u,tty),(pid,Map.empty))) $ new_users0 (Set.fromList->new_users,_) = unzip new_users0 (tty,active_users,subs,locals_greedy) <- atomically $ do tty <- readTVar $ currentTTY state st <- flip swapTVar new_users' $ activeUsers state xs <- readTVar $ subscriberMap state locals_greedy <- tryReadTMVar $ localSubscriber state return (tty,st,fmap snd xs,fmap snd locals_greedy) let known_users = Map.keysSet active_users let arrivals = map tupleToJID . Set.toList $ new_users \\ known_users departures = map tupleToJID . Set.toList $ known_users \\ new_users update_presence locals_greedy subs departures $ const Offline update_presence locals_greedy subs arrivals $ matchResource active_users tty forM_ arrivals $ sendProbes state on_chvt state vtnum = do let tty = L.snoc "tty" $ intToDigit (fromIntegral vtnum) debugL $ "VT switch: " <++> tty (active_users,subs,locals_greedy) <- atomically $ do us <- readTVar $ activeUsers state subs <- readTVar $ subscriberMap state writeTVar (currentTTY state) tty locals_greedy <- tryReadTMVar $ localSubscriber state return (us,fmap snd subs,fmap snd locals_greedy) let users = Map.keysSet active_users update_presence locals_greedy subs (map tupleToJID . Set.toList $ users) $ matchResource active_users tty -- start -- -- This function creates the global state, kicks off all the server threads, -- and inotify watches and then waits for Enter before terminating the program. -- start :: Network.Socket.Family -> IO () start ip4or6 = do let host = LocalHost global_state <- newPresenceState host let dologin e = track_login host global_state e dologin :: t -> IO () chan <- atomically $ subscribeToChan (localSubscriber global_state) remotes <- forkIO $ seekRemotePeers (PeerSessions global_state) chan (remotePeers global_state) installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing -- installHandler sigTERM (CatchOnce (dologin (userError "term signaled"))) Nothing mtty <- monitorTTY (on_chvt global_state) inotify <- initINotify #ifndef NOUTMP wd <- addWatch inotify [CloseWrite] -- [Open,Close,Access,Modify,Move] utmp_file dologin #endif clients <- listenForXmppClients ip4or6 (ClientSessions global_state) 5222 HNil peers <- listenForRemotePeers ip4or6 (PeerSessions global_state) 5269 HNil threadDelay 1000 -- wait a moment to obtain current tty dologin () L.putStrLn "\nHit enter to terminate...\n" getLine killThread remotes quitListening clients quitListening peers -- threadDelay 1000 debugL "closed listener." unmonitorTTY mtty debugL "unhooked tty monitor." #ifndef NOUTMP removeWatch wd #endif debugL "Normal termination." sendUSR1 pid = do signalProcess sigUSR1 pid getStartupAction [] = throw (userError "pid file?") >> return (Right "") getStartupAction (p:ps) = do handle onEr $ ( do pid <- fmap CPid (readFile p >>= readIO) -- signal pid return (Left pid) ) where onEr (SomeException _) = do pid <- getProcessID debugL $ "starting pid = " <++> bshow pid handle (\(SomeException _) -> getStartupAction ps) (do writeFile p (show pid) debugL $ "writing " <++> bshow p -- start daemon return (Right p) ) runOnce ps run notify = getStartupAction ps >>= doit where doit (Left pid ) = notify pid doit (Right pidfile ) = do run removeFile pidfile getOptions [] = Map.empty getOptions (('-':opt_name):xs) = if xs/=[] && xs!!0!!0/='-' then Map.insert (L.pack opt_name) (L.pack (xs!!0)) (getOptions (tail xs)) else Map.insert (L.pack opt_name) "" (getOptions xs) getOptions (x0:xs) = getOptions xs -- main -- -- This function parses the comand line arguments and checks if the pid file already -- exists. If the pid file exists, it signals USR1 to the currently running daemon. -- Otherwise, it chains to the true "main" function of the application: Main.start main = do opts <- fmap getOptions getArgs let use_ip4 = if isJust (Map.lookup "4" opts) then AF_INET else AF_INET6 runOnce ["/var/run/presence.pid","/tmp/presence.pid"] (start use_ip4) sendUSR1