From be81364d881a30508dceeb0f100bc1da0597d859 Mon Sep 17 00:00:00 2001 From: joe Date: Mon, 15 Jul 2013 14:22:37 -0400 Subject: Moved all output to module: Logging --- Presence/main.hs | 59 ++++++++++++++++++++++++++++---------------------------- 1 file changed, 30 insertions(+), 29 deletions(-) (limited to 'Presence/main.hs') diff --git a/Presence/main.hs b/Presence/main.hs index 83f11df3..ef6a0e66 100644 --- a/Presence/main.hs +++ b/Presence/main.hs @@ -31,6 +31,7 @@ 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 (Set,(\\)) import qualified Data.Map as Map @@ -43,7 +44,7 @@ import Control.Monad.IO.Class import ByteStringOperators import qualified Data.ByteString.Lazy.Char8 as L -import Data.ByteString.Lazy.Char8 as L (ByteString,putStrLn) +import Data.ByteString.Lazy.Char8 as L (ByteString) import qualified Prelude import Prelude hiding (putStrLn) import System.Environment @@ -149,7 +150,7 @@ instance JabberClientSession ClientSession where -- muid <- getLocalPeerCred sock addr <- getPeerName sock muid <- getLocalPeerCred' addr - L.putStrLn $ "CLIENT SESSION: open " <++> bshow muid + debugL $ "CLIENT SESSION: open " <++> bshow muid uid_ref <- newIORef muid (mtty,pid) <- getTTYandPID muid res_ref <- newIORef mtty @@ -171,7 +172,7 @@ instance JabberClientSession ClientSession where rsc <- readIORef (unix_resource s) let rsc' = maybe wanted_resource id rsc writeIORef (unix_resource s) (Just rsc') - L.putStrLn $ "CLIENT SESSION: resource " <++> rsc' + debugL $ "CLIENT SESSION: resource " <++> rsc' getJID s = do let host = localhost s @@ -179,7 +180,7 @@ instance JabberClientSession ClientSession where rsc <- readIORef (unix_resource s) -- let jid = user <++> "@" <++> host <++?> "/" <++$> rsc - -- L.putStrLn $ "CLIENT SESSION: jid " <++> L.show (JID (Just user) host rsc) + -- debugL $ "CLIENT SESSION: jid " <++> L.show (JID (Just user) host rsc) return (JID (Just user) host rsc) closeSession session = do @@ -187,7 +188,7 @@ instance JabberClientSession ClientSession where cs <- readTVar (chans session) forM_ cs $ \(RefCountedChan c) -> do unsubscribeToChan c - L.putStrLn "CLIENT SESSION: close" + debugL "CLIENT SESSION: close" subscribe session Nothing = do let tmvar = localSubscriber (presence_state session) @@ -210,7 +211,7 @@ instance JabberClientSession ClientSession where forCachedPresence s action = do jid <- getJID s - L.putStrLn $ "forCachedPresence "<++> bshow jid + debugL $ "forCachedPresence "<++> bshow jid withJust (name jid) $ \user -> do let parseHostNameJID' str = do handle (\(SomeException _) -> return Nothing) @@ -220,19 +221,19 @@ instance JabberClientSession ClientSession where fmap catMaybes (mapM parseHostNameJID' buddies) remotes <- readTVarIO . remoteUsers . presence_state $ s forM_ buddies $ \buddy -> do - L.putStrLn $ "forCachedPresence buddy = "<++> bshow buddy + debugL $ "forCachedPresence buddy = "<++> bshow buddy let mjids = fmap snd $ Map.lookup (peer buddy) remotes jids <- maybe (return MM.empty) readTVarIO mjids - L.putStrLn $ "forCachedPresence jids = "<++> bshow jids + debugL $ "forCachedPresence jids = "<++> bshow jids withJust (splitResource buddy) $ \(buddyU,_) -> do forM_ (Set.toList . MM.lookup buddyU $ jids) $ \(rsc,status) -> do let p = Presence buddy status - L.putStrLn $ "cached presence: " <++> bshow p + debugL $ "cached presence: " <++> bshow p action p sendPending s = do jid <- getJID s - putStrLn $ "sendPending "<++> bshow jid + debugL $ "sendPending "<++> bshow jid flip (maybe (return ())) (name jid) $ \user -> do pending <- ConfigFiles.getPending user let getRChan = do @@ -279,7 +280,7 @@ instance JabberClientSession ClientSession where handleIO (\e -> return False) $ do user <- readIORef (unix_uid s) >>= getJabberUserForId subs <- ConfigFiles.getSubscribers user - putStrLn $ "isSubscribed parsing: "<++>contact + debugL $ "isSubscribed parsing: "<++>contact cjid <- parseHostNameJID contact msubs <- mapM (cmpJID cjid) subs return (Nothing `elem` msubs) @@ -288,7 +289,7 @@ instance JabberClientSession ClientSession where handleIO (\e -> return False) $ do user <- readIORef (unix_uid s) >>= getJabberUserForId subs <- ConfigFiles.getBuddies user - putStrLn $ "isBuddy parsing: "<++>contact + debugL $ "isBuddy parsing: "<++>contact cjid <- parseHostNameJID contact msubs <- mapM (cmpJID cjid) subs return (Nothing `elem` msubs) @@ -369,13 +370,13 @@ instance JabberPeerSession PeerSession where newPeerSession (PeerSessions state) sock = do me <- fmap (RemotePeer . withoutPort) (getPeerName sock) - L.putStrLn $ "PEER SESSION: open "<++>showPeer me + 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 - L.putStrLn $ "PEER SESSION: close "<++>showPeer (peer_name session) + debugL $ "PEER SESSION: close "<++>showPeer (peer_name session) let offline jid = Presence jid Offline unrefFromMap (remoteUsers . peer_global $ session) (peer_name session) $ do @@ -409,7 +410,7 @@ instance JabberPeerSession PeerSession where sendPeerMessage session msg = do let cons = remotePeers . peer_global $ session - putStrLn $ "sendPeerMessage " <++> bshow msg <++> " --> "<++>bshow (peer_name session) + debugL $ "sendPeerMessage " <++> bshow msg <++> " --> "<++>bshow (peer_name session) sendMessage cons msg (peer_name session) getBuddies _ user = ConfigFiles.getBuddies user @@ -442,7 +443,7 @@ instance JabberPeerSession PeerSession where hbuddy <- asHostNameJID buddy modify user (cmpJID buddy) hbuddy was_pending <- addjid ConfigFiles.modifyPending user buddy - putStrLn $ "processRequest was_pending="<++>bshow was_pending + 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 @@ -492,7 +493,7 @@ getJabberUserForId muid = muid cmpJID newitem jid = do - -- putStrLn $ "Comparing "<++>bshow jid + -- debugL $ "Comparing "<++>bshow jid olditem <- parseHostNameJID jid if olditem==newitem then return Nothing else return $ Just jid @@ -505,7 +506,7 @@ addRawJid modify user jid = do addJid modify user jid = do hjid <- asHostNameJID jid - putStrLn $ "addJid (asHostNameJID) --> "<++>bshow hjid + debugL $ "addJid (asHostNameJID) --> "<++>bshow hjid withJust hjid $ \hjid -> do modify user (cmpJID jid) (Just hjid) return () @@ -598,10 +599,10 @@ update_presence locals_greedy subscribers state getStatus = runMaybeT $ do chan <- MaybeT . return $ locals_greedy sendPresence chan jid status - putStrLn $ bshow jid <++> " " <++> bshow status + debugL $ bshow jid <++> " " <++> bshow status sendProbes state jid = do - L.putStrLn $ "sending probes for " <++> bshow jid + debugL $ "sending probes for " <++> bshow jid withJust (name jid) $ \user -> do let parseHostNameJID' str = do handle (\(SomeException _) -> return Nothing) @@ -609,7 +610,7 @@ sendProbes state jid = do buddies <- do buddies <- ConfigFiles.getBuddies user fmap catMaybes (mapM parseHostNameJID' buddies) - L.putStrLn $ "buddies for " <++> bshow jid <++> " = " <++> bshow buddies + debugL $ "buddies for " <++> bshow jid <++> " = " <++> bshow buddies wanted <- do wanted <- ConfigFiles.getSolicited user fmap catMaybes (mapM parseHostNameJID' wanted) @@ -621,7 +622,7 @@ sendProbes state jid = do let noinfo = not (MM.member buddyU jids) when noinfo $ do let msg = if got then PresenceProbe jid buddy else Solicitation jid buddy - L.putStrLn $ "sendMessage " <++> bshow msg + debugL $ "sendMessage " <++> bshow msg sendMessage (remotePeers state) msg (peer buddy) @@ -651,7 +652,7 @@ track_login host state e = do on_chvt state vtnum = do let tty = L.snoc "tty" $ intToDigit (fromIntegral vtnum) - L.putStrLn $ "VT switch: " <++> tty + debugL $ "VT switch: " <++> tty (users,subs,locals_greedy) <- atomically $ do us <- readTVar $ activeUsers state subs <- readTVar $ subscriberMap state @@ -694,19 +695,19 @@ start ip4or6 = do threadDelay 1000 -- wait a moment to obtain current tty dologin () - putStrLn "\nHit enter to terminate...\n" + L.putStrLn "\nHit enter to terminate...\n" getLine killThread remotes quitListening clients quitListening peers -- threadDelay 1000 - putStrLn "closed listener." + debugL "closed listener." unmonitorTTY mtty - putStrLn "unhooked tty monitor." + debugL "unhooked tty monitor." #ifndef NOUTMP removeWatch wd #endif - putStrLn "Normal termination." + debugL "Normal termination." sendUSR1 pid = do signalProcess sigUSR1 pid @@ -721,11 +722,11 @@ getStartupAction (p:ps) = do where onEr (SomeException _) = do pid <- getProcessID - putStrLn $ "starting pid = " <++> bshow pid + debugL $ "starting pid = " <++> bshow pid handle (\(SomeException _) -> getStartupAction ps) (do writeFile p (show pid) - putStrLn $ "writing " <++> bshow p + debugL $ "writing " <++> bshow p -- start daemon return (Right p) ) -- cgit v1.2.3