diff --git a/pontarius.cabal b/pontarius.cabal index e555639..8dc8918 100644 --- a/pontarius.cabal +++ b/pontarius.cabal @@ -51,20 +51,25 @@ Library , data-default -any , stringprep >= 0.1.5 Exposed-modules: Network.XMPP - , Network.XMPP.Types - , Network.XMPP.SASL - , Network.XMPP.Stream - , Network.XMPP.Pickle + , Network.XMPP.Bind + , Network.XMPP.Concurrent , Network.XMPP.Marshal , Network.XMPP.Monad - , Network.XMPP.Concurrent - , Network.XMPP.TLS - , Network.XMPP.Bind + , Network.XMPP.Message + , Network.XMPP.Pickle + , Network.XMPP.Presence + , Network.XMPP.SASL , Network.XMPP.Session + , Network.XMPP.Stream + , Network.XMPP.TLS + , Network.XMPP.Types Other-modules: Network.XMPP.JID + , Network.XMPP.Concurrent.Types , Network.XMPP.Concurrent.IQ , Network.XMPP.Concurrent.Threads , Network.XMPP.Concurrent.Monad + , Text.XML.Stream.Elements + , Data.Conduit.TLS GHC-Options: -Wall diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index af4ed0a..1c87cb9 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -35,6 +35,8 @@ module Network.XMPP ( -- * Session management withNewSession + , withSession + , newSession , connect , startTLS , auth diff --git a/src/Network/XMPP/Concurrent/IQ.hs b/src/Network/XMPP/Concurrent/IQ.hs index 6693397..500719c 100644 --- a/src/Network/XMPP/Concurrent/IQ.hs +++ b/src/Network/XMPP/Concurrent/IQ.hs @@ -27,7 +27,7 @@ sendIQ to tp lang body = do -- TODO: add timeout writeTVar handlers (byNS, Map.insert newId resRef byId) -- TODO: Check for id collisions (shouldn't happen?) return resRef - sendS . IQRequestS $ IQRequest newId Nothing to lang tp body + sendStanza . IQRequestS $ IQRequest newId Nothing to lang tp body return ref -- | like 'sendIQ', but waits for the answer IQ diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index 84cb77e..515d55b 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -4,6 +4,7 @@ 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 @@ -34,7 +35,7 @@ listenIQChan tp ns = do writeTVar handlers (byNS', byID) return $ case present of Nothing -> Just iqCh - Just iqCh' -> Nothing + Just _iqCh' -> Nothing -- | get the inbound stanza channel, duplicates from master if necessary -- please note that once duplicated it will keep filling up, call @@ -92,8 +93,8 @@ pullPresence = do liftIO $ atomically $ readTChan c -- | Send a stanza to the server -sendS :: Stanza -> XMPP () -sendS a = do +sendStanza :: Stanza -> XMPP () +sendStanza a = do out <- asks outCh liftIO . atomically $ writeTChan out a return () @@ -159,24 +160,38 @@ withConnection a = do stateRef <- asks conStateRef write <- asks writeRef wait <- liftIO $ newEmptyTMVarIO - liftIO . throwTo readerId $ Interrupt wait - s <- liftIO . atomically $ do - putTMVar wait () - _ <- takeTMVar write - takeTMVar stateRef - (res, s') <- liftIO $ runStateT a s - liftIO . atomically $ do - putTMVar write (sConPushBS s') - putTMVar stateRef s' - return res + liftIO . Ex.mask_ $ do + throwTo readerId $ Interrupt wait + s <- Ex.catch ( atomically $ do + _ <- takeTMVar write + s <- takeTMVar stateRef + putTMVar wait () + return s + ) + (\e -> atomically (putTMVar wait ()) + >> Ex.throwIO (e :: Ex.SomeException) + -- No MVar taken + ) + Ex.catch ( do + (res, s') <- runStateT a s + atomically $ do + _ <- tryPutTMVar write (sConPushBS s') + _ <- tryPutTMVar stateRef s' + return () + return res + ) + -- we treat all Exceptions as fatal + (\e -> runStateT xmppKillConnection s + >> Ex.throwIO (e :: Ex.SomeException) + ) -- | Send a presence Stanza sendPresence :: Presence -> XMPP () -sendPresence = sendS . PresenceS +sendPresence = sendStanza . PresenceS -- | Send a Message Stanza sendMessage :: Message -> XMPP () -sendMessage = sendS . MessageS +sendMessage = sendStanza . MessageS modifyHandlers :: (EventHandlers -> EventHandlers) -> XMPP () diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index 6a57dbb..7230205 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -32,6 +32,7 @@ import GHC.IO (unsafeUnmask) -- While waiting for the first semaphore(s) to flip we might receive -- another interrupt. When that happens we add it's semaphore to the -- list and retry waiting +handleInterrupts :: [TMVar ()] -> IO [()] handleInterrupts ts = Ex.catch (atomically $ forM ts takeTMVar) ( \(Interrupt t) -> handleInterrupts (t:ts)) @@ -51,11 +52,11 @@ readWorker messageC presenceC handlers stateRef = -- we don't know whether pull will -- necessarily be interruptible allowInterrupt - Just <$> runStateT pull s + Just <$> runStateT pullStanza s ) ) (\(Interrupt t) -> do - handleInterrupts [t] + void $ handleInterrupts [t] return Nothing ) liftIO . atomically $ do @@ -121,7 +122,7 @@ writeWorker stCh writeR = forever $ do (write, next) <- atomically $ (,) <$> takeTMVar writeR <*> readTChan stCh - _ <- write $ renderElement (pickleElem stanzaP next) + _ <- write $ renderElement (pickleElem xpStanza next) atomically $ putTMVar writeR write -- Two streams: input and output. Threads read from input stream and write to output stream. @@ -141,13 +142,13 @@ startThreads ) startThreads = do - writeLock <- newEmptyTMVarIO + writeLock <- newTMVarIO (\_ -> return ()) messageC <- newTChanIO presenceC <- newTChanIO outC <- newTChanIO handlers <- newTVarIO ( Map.empty, Map.empty) eh <- newTVarIO zeroEventHandlers - conS <- newEmptyTMVarIO + conS <- newTMVarIO xmppZeroConState lw <- forkIO $ writeWorker outC writeLock cp <- forkIO $ connPersist writeLock rd <- forkIO $ readWorker messageC presenceC handlers conS @@ -173,8 +174,11 @@ newSession = do return . read. show $ curId return (Session workermCh workerpCh mC pC outC hand writeR rdr getId conS eh stopThreads') -withNewSession :: XMPP b -> IO b -withNewSession a = newSession >>= runReaderT a +withNewSession :: XMPP b -> IO (Session, b) +withNewSession a = do + sess <- newSession + ret <- runReaderT a sess + return (sess, ret) withSession :: Session -> XMPP a -> IO a withSession = flip runReaderT diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index 3d694e2..165a963 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -8,6 +8,9 @@ import Data.XML.Types import Network.XMPP.Pickle import Network.XMPP.Types +xpStreamEntity :: PU [Node] (Either XmppStreamError Stanza) +xpStreamEntity = xpEither xpStreamError xpStanza + stanzaSel :: Stanza -> Int stanzaSel (IQRequestS _) = 0 stanzaSel (IQResultS _) = 1 @@ -17,8 +20,8 @@ stanzaSel (MessageErrorS _) = 4 stanzaSel (PresenceS _) = 5 stanzaSel (PresenceErrorS _) = 6 -stanzaP :: PU [Node] Stanza -stanzaP = xpAlt stanzaSel +xpStanza :: PU [Node] Stanza +xpStanza = xpAlt stanzaSel [ xpWrap IQRequestS (\(IQRequestS x) -> x) xpIQRequest , xpWrap IQResultS (\(IQResultS x) -> x) xpIQResult , xpWrap IQErrorS (\(IQErrorS x) -> x) xpIQError @@ -188,3 +191,27 @@ xpIQError = xpWrap (\((qid, from, to, lang, _tp),(err, body)) (xpOption xpElemVerbatim) ) +xpStreamError :: PU [Node] XmppStreamError +xpStreamError = xpWrap + (\((cond,() ,()), txt, el) -> XmppStreamError cond txt el) + (\(XmppStreamError cond txt el) ->((cond,() ,()), txt, el)) + (xpElemNodes + (Name "error" + (Just "http://etherx.jabber.org/streams") + (Just "stream") + ) $ xp3Tuple + (xpElemByNamespace + "urn:ietf:params:xml:ns:xmpp-streams" xpPrim + xpUnit + xpUnit + ) + (xpOption $ xpElem + "{urn:ietf:params:xml:ns:xmpp-streams}text" + xpLangTag + (xpContent xpId)) + ( xpOption xpElemVerbatim + -- application specific error conditions + ) + ) + + diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 013f186..e5a8b23 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -2,30 +2,31 @@ module Network.XMPP.Monad where -import Control.Applicative((<$>)) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class +import Control.Applicative((<$>)) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class --import Control.Monad.Trans.Resource -import Control.Concurrent -import Control.Monad.State.Strict +import Control.Concurrent +import qualified Control.Exception as Ex +import Control.Monad.State.Strict -import Data.ByteString as BS -import Data.Conduit -import Data.Conduit.Binary as CB -import Data.Text(Text) -import Data.XML.Pickle -import Data.XML.Types +import Data.ByteString as BS +import Data.Conduit +import Data.Conduit.Binary as CB +import Data.Text(Text) +import Data.XML.Pickle +import Data.XML.Types -import Network -import Network.XMPP.Types -import Network.XMPP.Marshal -import Network.XMPP.Pickle +import Network +import Network.XMPP.Types +import Network.XMPP.Marshal +import Network.XMPP.Pickle -import System.IO +import System.IO -import Text.XML.Stream.Elements -import Text.XML.Stream.Parse as XP +import Text.XML.Stream.Elements +import Text.XML.Stream.Parse as XP pushN :: Element -> XMPPConMonad () pushN x = do @@ -33,7 +34,7 @@ pushN x = do liftIO . sink $ renderElement x push :: Stanza -> XMPPConMonad () -push = pushN . pickleElem stanzaP +push = pushN . pickleElem xpStanza pushOpen :: Element -> XMPPConMonad () pushOpen e = do @@ -41,21 +42,29 @@ pushOpen e = do liftIO . sink $ renderOpenElement e return () -pulls :: Sink Event IO b -> XMPPConMonad b -pulls snk = do +pullSink :: Sink Event IO b -> XMPPConMonad b +pullSink snk = do source <- gets sConSrc (src', r) <- lift $ source $$+ snk modify $ (\s -> s {sConSrc = src'}) return r -pullE :: XMPPConMonad Element -pullE = pulls elementFromEvents +pullElement :: XMPPConMonad Element +pullElement = pullSink elementFromEvents pullPickle :: PU [Node] a -> XMPPConMonad a -pullPickle p = unpickleElem' p <$> pullE - -pull :: XMPPConMonad Stanza -pull = pullPickle stanzaP +pullPickle p = do + res <- unpickleElem p <$> pullElement + case res of + Left e -> liftIO . Ex.throwIO $ StreamXMLError e + Right r -> return r + +pullStanza :: XMPPConMonad Stanza +pullStanza = do + res <- pullPickle xpStreamEntity + case res of + Left e -> liftIO . Ex.throwIO $ StreamError e + Right r -> return r xmppFromHandle :: Handle -> Text @@ -119,7 +128,6 @@ xmppRawConnect host hostname = do (hClose con) put st - xmppNewSession :: XMPPConMonad a -> IO (a, XMPPConState) xmppNewSession action = do runStateT action xmppZeroConState diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index 347e8a5..bc611d8 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -5,7 +5,21 @@ -- Marshalling between XML and Native Types -module Network.XMPP.Pickle where +module Network.XMPP.Pickle + ( mbToBool + , xpElemEmpty + , xmlLang + , xpLangTag + , xpNodeElem + , ignoreAttrs + , mbl + , lmb + , right + , unpickleElem' + , unpickleElem + , pickleElem + , ppElement + ) where import Data.XML.Types import Data.XML.Pickle @@ -65,3 +79,4 @@ unpickleElem p x = unpickle (xpNodeElem p) x pickleElem :: PU [Node] a -> a -> Element pickleElem p = pickle $ xpNodeElem p + diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 24f4288..87e3325 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -5,7 +5,6 @@ import Control.Applicative import Control.Arrow (left) import Control.Monad import Control.Monad.Error -import Control.Monad.IO.Class import Control.Monad.State.Strict import qualified Crypto.Classes as CC @@ -80,7 +79,8 @@ xmppStartSASL realm username passwd = runErrorT $ do unless ("DIGEST-MD5" `elem` mechanisms) . throwError $ SaslMechanismError mechanisms lift . pushN $ saslInitE "DIGEST-MD5" - challenge' <- lift $ B64.decode . Text.encodeUtf8<$> pullPickle challengePickle + challenge' <- lift $ B64.decode . Text.encodeUtf8 + <$> pullPickle challengePickle challenge <- case challenge' of Left _e -> throwError SaslChallengeError Right r -> return r @@ -94,7 +94,7 @@ xmppStartSASL realm username passwd = runErrorT $ do Left _x -> throwError $ SaslXmlError Right _ -> return () lift $ pushN saslResponse2E - e <- lift pullE + e <- lift pullElement case e of Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] -> return () _ -> throwError SaslXmlError -- TODO: investigate diff --git a/src/Network/XMPP/Session.hs b/src/Network/XMPP/Session.hs index 8e3082f..b21c265 100644 --- a/src/Network/XMPP/Session.hs +++ b/src/Network/XMPP/Session.hs @@ -28,7 +28,7 @@ sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" xmppSession :: XMPPConMonad () xmppSession = do push $ sessionIQ - answer <- pull + answer <- pullStanza let IQResultS (IQResult "sess" Nothing Nothing _lang _body) = answer return () diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index c192116..be79acf 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -27,7 +27,7 @@ streamUnpickleElem :: PU [Node] a -> ErrorT StreamError (Pipe Event Void IO) a streamUnpickleElem p x = do case unpickleElem p x of - Left l -> throwError $ StreamUnpickleError l + Left l -> throwError $ StreamXMLError l Right r -> return r type StreamSink a = ErrorT StreamError (Pipe Event Void IO) a @@ -55,7 +55,7 @@ xmppStartStream = runErrorT $ do Nothing -> throwError StreamConnectionError Just hostname -> lift . pushOpen $ pickleElem pickleStream ("1.0",Nothing, Just hostname) - features <- ErrorT . pulls $ runErrorT xmppStream + features <- ErrorT . pullSink $ runErrorT xmppStream modify (\s -> s {sFeatures = features}) return () diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index 8cfc0a4..5d2418d 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -3,8 +3,6 @@ module Network.XMPP.TLS where -import Control.Applicative((<$>)) -import Control.Arrow(left) import qualified Control.Exception.Lifted as Ex import Control.Monad import Control.Monad.Error @@ -15,6 +13,7 @@ import Data.Typeable import Data.XML.Types import Network.XMPP.Monad +import Network.XMPP.Pickle(ppElement) import Network.XMPP.Stream import Network.XMPP.Types @@ -45,7 +44,6 @@ data XMPPTLSError = TLSError TLSError instance Error XMPPTLSError where noMsg = TLSNoConnection -- TODO: What should we choose here? -instance Ex.Exception XMPPTLSError xmppStartTLS :: TLS.TLSParams -> XMPPConMonad (Either XMPPTLSError ()) @@ -56,10 +54,14 @@ xmppStartTLS params = Ex.handle (return . Left . TLSError) handle <- maybe (throwError TLSNoConnection) return handle' when (stls features == Nothing) $ throwError TLSNoServerSupport lift $ pushN starttlsE - answer <- lift $ pullE + answer <- lift $ pullElement case answer of Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return () - _ -> throwError $ TLSStreamError StreamXMLError + Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _ + -> lift . Ex.throwIO $ StreamConnectionError + -- TODO: find something more suitable + e -> lift . Ex.throwIO . StreamXMLError + $ "Unexpected element: " ++ ppElement e (raw, _snk, psh, ctx) <- lift $ TLS.tlsinit params handle lift $ modify (\x -> x { sRawSrc = raw @@ -68,7 +70,7 @@ xmppStartTLS params = Ex.handle (return . Left . TLSError) , sConPushBS = psh , sCloseConnection = TLS.bye ctx >> sCloseConnection x }) - ErrorT $ (left TLSStreamError) <$> xmppRestartStream + either (lift . Ex.throwIO) return =<< lift xmppRestartStream modify (\s -> s{sHaveTLS = True}) return () diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index c8f4619..9013eb2 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -40,6 +40,7 @@ module Network.XMPP.Types , XMPPConMonad , XMPPConState(..) , XMPPT(..) + , XmppStreamError(..) , parseLangTag , module Network.XMPP.JID ) @@ -338,7 +339,6 @@ instance Read ShowType where -- wrapped in the @StanzaError@ type. -- TODO: Sender XML is (optional and is) not included. - data StanzaError = StanzaError { stanzaErrorType :: StanzaErrorType , stanzaErrorCondition :: StanzaErrorCondition , stanzaErrorText :: Maybe (Maybe LangTag, Text) @@ -537,14 +537,103 @@ instance Read SASLError where data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq) -data StreamError = StreamError String +-- TODO: document the error cases +data StreamErrorCondition = StreamBadFormat + | StreamBadNamespacePrefix + | StreamConflict + | StreamConnectionTimeout + | StreamHostGone + | StreamHostUnknown + | StreamImproperAddressing + | StreamInternalServerError + | StreamInvalidFrom + | StreamInvalidNamespace + | StreamInvalidXml + | StreamNotAuthorized + | StreamNotWellFormed + | StreamPolicyViolation + | StreamRemoteConnectionFailed + | StreamReset + | StreamResourceConstraint + | StreamRestrictedXml + | StreamSeeOtherHost + | StreamSystemShutdown + | StreamUndefinedCondition + | StreamUnsupportedEncoding + | StreamUnsupportedFeature + | StreamUnsupportedStanzaType + | StreamUnsupportedVersion + deriving Eq + +instance Show StreamErrorCondition where + show StreamBadFormat = "bad-format" + show StreamBadNamespacePrefix = "bad-namespace-prefix" + show StreamConflict = "conflict" + show StreamConnectionTimeout = "connection-timeout" + show StreamHostGone = "host-gone" + show StreamHostUnknown = "host-unknown" + show StreamImproperAddressing = "improper-addressing" + show StreamInternalServerError = "internal-server-error" + show StreamInvalidFrom = "invalid-from" + show StreamInvalidNamespace = "invalid-namespace" + show StreamInvalidXml = "invalid-xml" + show StreamNotAuthorized = "not-authorized" + show StreamNotWellFormed = "not-well-formed" + show StreamPolicyViolation = "policy-violation" + show StreamRemoteConnectionFailed = "remote-connection-failed" + show StreamReset = "reset" + show StreamResourceConstraint = "resource-constraint" + show StreamRestrictedXml = "restricted-xml" + show StreamSeeOtherHost = "see-other-host" + show StreamSystemShutdown = "system-shutdown" + show StreamUndefinedCondition = "undefined-condition" + show StreamUnsupportedEncoding = "unsupported-encoding" + show StreamUnsupportedFeature = "unsupported-feature" + show StreamUnsupportedStanzaType = "unsupported-stanza-type" + show StreamUnsupportedVersion = "unsupported-version" + +instance Read StreamErrorCondition where + readsPrec _ "bad-format" = [(StreamBadFormat , "")] + readsPrec _ "bad-namespace-prefix" = [(StreamBadNamespacePrefix , "")] + readsPrec _ "conflict" = [(StreamConflict , "")] + readsPrec _ "connection-timeout" = [(StreamConnectionTimeout , "")] + readsPrec _ "host-gone" = [(StreamHostGone , "")] + readsPrec _ "host-unknown" = [(StreamHostUnknown , "")] + readsPrec _ "improper-addressing" = [(StreamImproperAddressing , "")] + readsPrec _ "internal-server-error" = [(StreamInternalServerError , "")] + readsPrec _ "invalid-from" = [(StreamInvalidFrom , "")] + readsPrec _ "invalid-namespace" = [(StreamInvalidNamespace , "")] + readsPrec _ "invalid-xml" = [(StreamInvalidXml , "")] + readsPrec _ "not-authorized" = [(StreamNotAuthorized , "")] + readsPrec _ "not-well-formed" = [(StreamNotWellFormed , "")] + readsPrec _ "policy-violation" = [(StreamPolicyViolation , "")] + readsPrec _ "remote-connection-failed" = [(StreamRemoteConnectionFailed , "")] + readsPrec _ "reset" = [(StreamReset , "")] + readsPrec _ "resource-constraint" = [(StreamResourceConstraint , "")] + readsPrec _ "restricted-xml" = [(StreamRestrictedXml , "")] + readsPrec _ "see-other-host" = [(StreamSeeOtherHost , "")] + readsPrec _ "system-shutdown" = [(StreamSystemShutdown , "")] + readsPrec _ "undefined-condition" = [(StreamUndefinedCondition , "")] + readsPrec _ "unsupported-encoding" = [(StreamUnsupportedEncoding , "")] + readsPrec _ "unsupported-feature" = [(StreamUnsupportedFeature , "")] + readsPrec _ "unsupported-stanza-type" = [(StreamUnsupportedStanzaType , "")] + readsPrec _ "unsupported-version" = [(StreamUnsupportedVersion , "")] + readsPrec _ _ = [(StreamUndefinedCondition , "")] + +data XmppStreamError = XmppStreamError + { errorCondition :: StreamErrorCondition + , errorText :: Maybe (Maybe LangTag, Text) + , errorXML :: Maybe Element + } deriving (Show, Eq) + + +data StreamError = StreamError XmppStreamError | StreamWrongVersion Text - | StreamXMLError - | StreamUnpickleError String + | StreamXMLError String | StreamConnectionError deriving (Show, Eq, Typeable) instance Exception StreamError -instance Error StreamError where strMsg = StreamError +instance Error StreamError where noMsg = StreamConnectionError -- ============================================================================= -- XML TYPES