From 716e4476ee454cfb667ab6a030deb4dad302a36b Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Fri, 20 Apr 2012 12:19:20 +0200 Subject: [PATCH] Warning clean --- src/Network/XMPP/Concurrent/Monad.hs | 3 +- src/Network/XMPP/Concurrent/Threads.hs | 17 +++------- src/Network/XMPP/Concurrent/Types.hs | 1 + src/Network/XMPP/Monad.hs | 3 -- src/Network/XMPP/SASL.hs | 2 +- src/Network/XMPP/Stream.hs | 3 -- src/Network/XMPP/TLS.hs | 13 ++------ src/Network/XMPP/Types.hs | 44 +++----------------------- src/Tests.hs | 2 +- 9 files changed, 15 insertions(+), 73 deletions(-) diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index f9a2d75..7cd3d40 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -4,7 +4,6 @@ import Network.XMPP.Types import Control.Concurrent import Control.Concurrent.STM -import qualified Control.Exception.Lifted as Ex import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.State.Strict @@ -156,7 +155,7 @@ withConnection a = do liftIO . throwTo readerId $ Interrupt wait s <- liftIO . atomically $ do putTMVar wait () - takeTMVar write + _ <- takeTMVar write takeTMVar stateRef (res, s') <- liftIO $ runStateT a s liftIO . atomically $ do diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index 961fd68..a801b05 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -10,18 +10,13 @@ import Control.Concurrent.STM import qualified Control.Exception.Lifted as Ex import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Trans import Control.Monad.Reader import Control.Monad.State.Strict import qualified Data.ByteString as BS -import Data.Conduit -import qualified Data.Conduit.List as CL -import Data.Default (def) import Data.IORef import qualified Data.Map as Map import Data.Maybe -import qualified Data.Text as Text import Data.XML.Types @@ -31,7 +26,6 @@ import Network.XMPP.Pickle import Network.XMPP.Concurrent.Types import Text.XML.Stream.Elements -import qualified Text.XML.Stream.Render as XR import GHC.IO (unsafeUnmask) @@ -64,7 +58,8 @@ readWorker messageC presenceC handlers stateRef = _ <- readTChan messageC -- Sic! return () -- this may seem ridiculous, but to prevent - -- the channel from filling up we immedtiately remove the + -- the channel from filling up we + -- immedtiately remove the -- Stanza we just put in. It will still be -- available in duplicates. MessageErrorS m -> do writeTChan messageC $ Left m @@ -88,6 +83,7 @@ readWorker messageC presenceC handlers stateRef = allowInterrupt :: IO () allowInterrupt = unsafeUnmask $ return () +handleIQRequest :: TVar IQHandlers -> IQRequest -> STM () handleIQRequest handlers iq = do (byNS, _) <- readTVar handlers let iqNS = fromMaybe "" (nameNamespace . elementName $ iqRequestPayload iq) @@ -97,6 +93,7 @@ handleIQRequest handlers iq = do sent <- newTVar False writeTChan ch (iq, sent) +handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> STM () handleIQResponse handlers iq = do (byNS, byID) <- readTVar handlers case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq) byID of @@ -107,7 +104,7 @@ handleIQResponse handlers iq = do writeTVar handlers (byNS, byID') where iqID (Left err) = iqErrorID err - iqID (Right iq) = iqResultID iq + iqID (Right iq') = iqResultID iq' writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO ()) -> IO () writeWorker stCh writeR = forever $ do @@ -137,14 +134,12 @@ startThreads = do writeLock <- liftIO . newTMVarIO =<< gets sConPushBS messageC <- liftIO newTChanIO presenceC <- liftIO newTChanIO - iqC <- liftIO newTChanIO outC <- liftIO newTChanIO handlers <- liftIO $ newTVarIO ( Map.empty, Map.empty) eh <- liftIO $ newTVarIO zeroEventHandlers conS <- liftIO . newTMVarIO =<< get lw <- liftIO . forkIO $ writeWorker outC writeLock cp <- liftIO . forkIO $ connPersist writeLock - s <- get rd <- liftIO . forkIO $ readWorker messageC presenceC handlers conS return (messageC, presenceC, handlers, outC , killConnection writeLock [lw, rd, cp] @@ -170,7 +165,6 @@ runThreaded a = do curId <- readTVar idRef writeTVar idRef (curId + 1 :: Integer) return . read. show $ curId - s <- get liftIO . putStrLn $ "starting application" liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId conS eh stopThreads') @@ -181,5 +175,4 @@ connPersist lock = forever $ do pushBS <- atomically $ takeTMVar lock pushBS " " atomically $ putTMVar lock pushBS --- putStrLn "" threadDelay 30000000 diff --git a/src/Network/XMPP/Concurrent/Types.hs b/src/Network/XMPP/Concurrent/Types.hs index 26b9418..3f741f1 100644 --- a/src/Network/XMPP/Concurrent/Types.hs +++ b/src/Network/XMPP/Concurrent/Types.hs @@ -26,6 +26,7 @@ data EventHandlers = EventHandlers , connectionClosedHandler :: XMPPThread () } +zeroEventHandlers :: EventHandlers zeroEventHandlers = EventHandlers { sessionEndHandler = return () , connectionClosedHandler = return () diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 2ff458e..f860c15 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -13,7 +13,6 @@ import Control.Monad.State.Strict import Data.ByteString as BS import Data.Conduit import Data.Conduit.Binary as CB -import Data.Conduit.List as CL import Data.Text(Text) import Data.XML.Pickle import Data.XML.Types @@ -27,8 +26,6 @@ import System.IO import Text.XML.Stream.Elements import Text.XML.Stream.Parse as XP -import Text.XML.Stream.Render as XR - pushN :: Element -> XMPPConMonad () pushN x = do diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 589146d..6dc8ec6 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -78,7 +78,7 @@ xmppStartSASL realm username passwd = do Right _ -> return () pushN saslResponse2E Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pullE - xmppRestartStream + _ <- xmppRestartStream return () createResponse :: Random.RandomGen g diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index 6f750e4..c192116 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -3,9 +3,6 @@ module Network.XMPP.Stream where -import Control.Applicative((<$>)) -import Control.Exception(throwIO) -import Control.Monad(unless) import Control.Monad.Error import Control.Monad.State.Strict diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index df88b46..b5a91a4 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -9,24 +9,15 @@ import qualified Control.Exception.Lifted as Ex import Control.Monad import Control.Monad.Error import Control.Monad.State.Strict -import Control.Monad.Trans -import Data.Conduit -import Data.Conduit.List as CL import Data.Conduit.TLS as TLS -import Data.Default import Data.Typeable import Data.XML.Types -import qualified Network.TLS as TLS -import qualified Network.TLS.Extra as TLS import Network.XMPP.Monad import Network.XMPP.Stream import Network.XMPP.Types -import qualified Text.XML.Stream.Render as XR - - starttlsE :: Element starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] @@ -41,7 +32,7 @@ exampleParams = TLS.defaultParams , pUseSecureRenegotiation = False -- No renegotiation , pCertificates = [] -- TODO , pLogging = TLS.defaultLogging -- TODO - , onCertificatesRecv = \ certificate -> + , onCertificatesRecv = \ _certificate -> return TLS.CertificateUsageAccept } @@ -68,7 +59,7 @@ xmppStartTLS params = Ex.handle (return . Left . TLSError) case answer of Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return () _ -> throwError $ TLSStreamError StreamXMLError - (raw, snk, psh, ctx) <- lift $ TLS.tlsinit params handle + (raw, _snk, psh, ctx) <- lift $ TLS.tlsinit params handle lift $ modify (\x -> x { sRawSrc = raw -- , sConSrc = -- Note: this momentarily leaves us in an diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index 1f59194..b08d15e 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -15,7 +15,7 @@ module Network.XMPP.Types ( IQError(..) , IQRequest(..) , IQRequestType(..) - , IQResponse(..) + , IQResponse , IQResult(..) , IdGenerator(..) , LangTag (..) @@ -37,7 +37,7 @@ module Network.XMPP.Types , StanzaId(..) , StreamError(..) , Version(..) - , XMPPConMonad(..) + , XMPPConMonad , XMPPConState(..) , XMPPT(..) , parseLangTag @@ -56,7 +56,6 @@ import Control.Monad.Error import qualified Data.ByteString as BS import Data.Conduit -import Data.List.Split as L import Data.String(IsString(..)) import Data.Text (Text) import qualified Data.Text as Text @@ -69,15 +68,6 @@ import Network.XMPP.JID import System.IO - --- | The string prefix MUST be - -data SessionSettings = - SessionSettings { ssIdPrefix :: String - , ssIdGenerator :: IdGenerator - , ssStreamLang :: LangTag } - - -- ============================================================================= -- STANZA TYPES -- ============================================================================= @@ -535,39 +525,14 @@ instance Read SASLError where readsPrec _ "mechanism-too-weak" = [(SASLMechanismTooWeak , "")] readsPrec _ "not-authorized" = [(SASLNotAuthorized , "")] readsPrec _ "temporary-auth-failure" = [(SASLTemporaryAuthFailure , "")] + readsPrec _ _ = [] -- | Readability type for host name Texts. -- type HostName = Text -- This is defined in Network as well - --- | Readability type for port number Integers. - -type PortNumber = Integer -- We use N(etwork).PortID (PortNumber) internally - - --- | Readability type for user name Texts. - -type UserName = Text - - --- | Readability type for password Texts. - -type Password = Text - - --- | Readability type for (Address) resource identifier Texts. - -type Resource = Text - - -type StreamID = Text - - data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq) -type Timeout = Int - data StreamError = StreamError String | StreamWrongVersion Text | StreamXMLError @@ -640,8 +605,6 @@ instance Read LangTag where -- all (\ (a, b) -> map toLower a == map toLower b) $ zip as bs -- | otherwise = False - - data ServerFeatures = SF { stls :: Maybe Bool , saslMechanisms :: [Text.Text] @@ -659,6 +622,7 @@ data XMPPConState = XMPPConState , sUsername :: Maybe Text , sResource :: Maybe Text , sCloseConnection :: IO () + -- TODO: add default Language } -- | diff --git a/src/Tests.hs b/src/Tests.hs index d5621ab..ff194c4 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -100,7 +100,7 @@ runMain debug number = do Right _ -> return () Left e -> error e xmppThreadedBind (resourcepart we) --- startSession + startSession debug' "session standing" sendPresence presenceOnline forkXMPP autoAccept