path: root/Presence/main.hs

{-# 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