diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 0c830c4..81680b1 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -33,11 +33,12 @@ Library , base64-bytestring >=0.1.0.0 , binary >=0.4.1 , bytestring >=0.9.1.9 - , conduit >=0.5 && <1.0 + , conduit >=0.5 , containers >=0.4.0.0 , crypto-api >=0.9 , crypto-random-api >=0.2 , cryptohash >=0.6.1 + , cryptohash-cryptoapi >=0.1 , data-default >=0.2 , dns >=0.3.0 , hslogger >=1.1.0 @@ -58,17 +59,22 @@ Library , void >=0.5.5 , xml-types >=0.3.1 , xml-conduit >=1.0 - , xml-picklers >=0.3 + , xml-picklers >=0.3.2 Exposed-modules: Network.Xmpp + , Network.Xmpp.IM , Network.Xmpp.Internal Other-modules: Network.Xmpp.Concurrent - , Network.Xmpp.Concurrent.Types , Network.Xmpp.Concurrent.Basic , Network.Xmpp.Concurrent.IQ , Network.Xmpp.Concurrent.Message + , Network.Xmpp.Concurrent.Monad , Network.Xmpp.Concurrent.Presence , Network.Xmpp.Concurrent.Threads - , Network.Xmpp.Concurrent.Monad + , Network.Xmpp.Concurrent.Types + , Network.Xmpp.IM.Message + , Network.Xmpp.IM.Presence + , Network.Xmpp.IM.Roster + , Network.Xmpp.IM.Roster.Types , Network.Xmpp.Marshal , Network.Xmpp.Sasl , Network.Xmpp.Sasl.Common @@ -78,6 +84,7 @@ Library , Network.Xmpp.Sasl.Mechanisms.Scram , Network.Xmpp.Sasl.StringPrep , Network.Xmpp.Sasl.Types + , Network.Xmpp.Stanza , Network.Xmpp.Stream , Network.Xmpp.Tls , Network.Xmpp.Types diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 585039e..bc8281b 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -29,6 +29,7 @@ module Network.Xmpp , session , StreamConfiguration(..) , SessionConfiguration(..) + , ConnectionDetails(..) -- TODO: Close session, etc. -- ** Authentication handlers -- | The use of 'scramSha1' is /recommended/, but 'digestMd5' might be @@ -45,6 +46,7 @@ module Network.Xmpp , isFull , jidFromText , jidFromTexts + , getJid -- * Stanzas -- | The basic protocol data unit in XMPP is the XML stanza. The stanza is -- essentially a fragment of XML that is sent over a stream. @Stanzas@ come in @@ -81,6 +83,7 @@ module Network.Xmpp -- occur in a system such as email. It is not to be confused with -- /instant messaging/ which is handled in the 'Network.Xmpp.IM' module , Message(..) + , message , MessageError(..) , MessageType(..) -- *** Creating @@ -102,6 +105,12 @@ module Network.Xmpp , PresenceType(..) , PresenceError(..) -- *** Creating + , presence + , presenceOffline + , presenceOnline + , presenceSubscribe + , presenceSubscribed + , presenceUnsubscribe , presTo -- *** Sending -- | Sends a presence stanza. In general, the presence stanza should have no @@ -137,8 +146,7 @@ module Network.Xmpp , sendIQ' , answerIQ , listenIQChan - , iqRequestPayload - , iqResultPayload + , dropIQChan -- * Errors , StanzaError(..) , StanzaErrorType(..) @@ -156,10 +164,9 @@ module Network.Xmpp , AuthOtherFailure ) ) where -import Network import Network.Xmpp.Concurrent -import Network.Xmpp.Utilities import Network.Xmpp.Sasl import Network.Xmpp.Sasl.Types -import Network.Xmpp.Tls +import Network.Xmpp.Stanza import Network.Xmpp.Types +import Network.Xmpp.Utilities diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 9ff6ccc..c91c1c1 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -18,37 +18,30 @@ import Control.Applicative((<$>),(<*>)) import Control.Concurrent import Control.Concurrent.STM import Control.Monad +import Control.Monad.Error import qualified Data.ByteString as BS -import Data.IORef import qualified Data.Map as Map import Data.Maybe -import Data.Maybe (fromMaybe) import Data.Text as Text import Data.XML.Types import Network -import qualified Network.TLS as TLS import Network.Xmpp.Concurrent.Basic import Network.Xmpp.Concurrent.IQ import Network.Xmpp.Concurrent.Message import Network.Xmpp.Concurrent.Monad import Network.Xmpp.Concurrent.Presence import Network.Xmpp.Concurrent.Threads -import Network.Xmpp.Concurrent.Threads import Network.Xmpp.Concurrent.Types +import Network.Xmpp.IM.Roster.Types +import Network.Xmpp.IM.Roster import Network.Xmpp.Marshal import Network.Xmpp.Sasl -import Network.Xmpp.Sasl.Mechanisms import Network.Xmpp.Sasl.Types import Network.Xmpp.Stream import Network.Xmpp.Tls import Network.Xmpp.Types import Network.Xmpp.Utilities -import Control.Monad.Error -import Data.Default -import System.Log.Logger -import Control.Monad.State.Strict - runHandlers :: (TChan Stanza) -> [StanzaHandler] -> Stanza -> IO () runHandlers _ [] _ = return () runHandlers outC (h:hands) sta = do @@ -80,8 +73,24 @@ handleIQ iqHands outC sta = atomically $ do case Map.lookup (iqRequestType iq, iqNS) byNS of Nothing -> writeTChan outC $ serviceUnavailable iq Just ch -> do - sent <- newTVar False - writeTChan ch $ IQRequestTicket sent iq + sentRef <- newTVar False + let answerT answer = do + let IQRequest iqid from _to lang _tp bd = iq + response = case answer of + Left er -> IQErrorS $ IQError iqid Nothing + from lang er + (Just bd) + Right res -> IQResultS $ IQResult iqid Nothing + from lang res + atomically $ do + sent <- readTVar sentRef + case sent of + False -> do + writeTVar sentRef True + writeTChan outC response + return True + True -> return False + writeTChan ch $ IQRequestTicket answerT iq serviceUnavailable (IQRequest iqid from _to lang _tp bd) = IQErrorS $ IQError iqid Nothing from lang err (Just bd) err = StanzaError Cancel ServiceUnavailable Nothing Nothing @@ -96,7 +105,7 @@ handleIQ iqHands outC sta = atomically $ do _ <- tryPutTMVar tmvar answer -- Don't block. writeTVar handlers (byNS, byID') where - iqID (Left err) = iqErrorID err + iqID (Left err') = iqErrorID err' iqID (Right iq') = iqResultID iq' -- | Creates and initializes a new Xmpp context. @@ -104,26 +113,32 @@ newSession :: Stream -> SessionConfiguration -> IO (Either XmppFailure Session) newSession stream config = runErrorT $ do outC <- lift newTChanIO stanzaChan <- lift newTChanIO - iqHandlers <- lift $ newTVarIO (Map.empty, Map.empty) + iqHands <- lift $ newTVarIO (Map.empty, Map.empty) eh <- lift $ newTVarIO $ EventHandlers { connectionClosedHandler = sessionClosedHandler config } - let stanzaHandler = runHandlers outC $ Prelude.concat [ [toChan stanzaChan] + ros <- liftIO . newTVarIO $ Roster Nothing Map.empty + let rosterH = if (enableRoster config) then handleRoster ros + else \ _ _ -> return True + let stanzaHandler = runHandlers outC $ Prelude.concat [ [ toChan stanzaChan ] , extraStanzaHandlers config - , [handleIQ iqHandlers] + , [ handleIQ iqHands + , rosterH + ] ] - (kill, wLock, streamState, readerThread) <- ErrorT $ startThreadsWith stanzaHandler eh stream + (kill, wLock, streamState, reader) <- ErrorT $ startThreadsWith stanzaHandler eh stream writer <- lift $ forkIO $ writeWorker outC wLock idGen <- liftIO $ sessionStanzaIDs config return $ Session { stanzaCh = stanzaChan , outCh = outC - , iqHandlers = iqHandlers + , iqHandlers = iqHands , writeRef = wLock - , readerThread = readerThread + , readerThread = reader , idGenerator = idGen , streamRef = streamState , eventHandlers = eh , stopThreads = kill >> killThread writer , conf = config + , rosterRef = ros } -- Worker to write stanzas to the stream concurrently. @@ -145,12 +160,12 @@ writeWorker stCh writeR = forever $ do -- third parameter is a 'Just' value, @session@ will attempt to authenticate and -- acquire an XMPP resource. session :: HostName -- ^ The hostname / realm - -> SessionConfiguration -- ^ configuration details -> Maybe ([SaslHandler], Maybe Text) -- ^ SASL handlers and the desired -- JID resource (or Nothing to let -- the server decide) + -> SessionConfiguration -- ^ configuration details -> IO (Either XmppFailure Session) -session realm config mbSasl = runErrorT $ do +session realm mbSasl config = runErrorT $ do stream <- ErrorT $ openStream realm (sessionStreamConfiguration config) ErrorT $ tls stream mbAuthError <- case mbSasl of @@ -160,4 +175,5 @@ session realm config mbSasl = runErrorT $ do Nothing -> return () Just _ -> throwError XmppAuthFailure ses <- ErrorT $ newSession stream config + liftIO $ when (enableRoster config) $ initRoster ses return ses diff --git a/source/Network/Xmpp/Concurrent/Basic.hs b/source/Network/Xmpp/Concurrent/Basic.hs index 5b16e4e..912cba5 100644 --- a/source/Network/Xmpp/Concurrent/Basic.hs +++ b/source/Network/Xmpp/Concurrent/Basic.hs @@ -3,7 +3,9 @@ module Network.Xmpp.Concurrent.Basic where import Control.Concurrent.STM import Network.Xmpp.Concurrent.Types +import Network.Xmpp.Stream import Network.Xmpp.Types +import Control.Monad.State.Strict -- | Send a stanza to the server. sendStanza :: Stanza -> Session -> IO () @@ -14,3 +16,9 @@ dupSession :: Session -> IO Session dupSession session = do stanzaCh' <- atomically $ dupTChan (stanzaCh session) return $ session {stanzaCh = stanzaCh'} + +-- | Return the JID assigned to us by the server +getJid :: Session -> IO (Maybe Jid) +getJid Session{streamRef = st} = do + s <- atomically $ readTMVar st + withStream' (gets streamJid) s diff --git a/source/Network/Xmpp/Concurrent/IQ.hs b/source/Network/Xmpp/Concurrent/IQ.hs index bd79061..4b6c462 100644 --- a/source/Network/Xmpp/Concurrent/IQ.hs +++ b/source/Network/Xmpp/Concurrent/IQ.hs @@ -4,8 +4,6 @@ module Network.Xmpp.Concurrent.IQ where import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.STM import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader import qualified Data.Map as Map import Data.Text (Text) @@ -64,9 +62,14 @@ sendIQ' to tp lang body session = do -- | Retrieves an IQ listener channel. If the namespace/'IQRequestType' is not -- already handled, a new 'TChan' is created and returned as a 'Right' value. -- Otherwise, the already existing channel will be returned wrapped in a 'Left' --- value. Note that the 'Left' channel might need to be duplicated in order not +-- value. The 'Left' channel might need to be duplicated in order not -- to interfere with existing consumers. -listenIQChan :: IQRequestType -- ^ Type of IQs to receive (@Get@ or @Set@) +-- +-- Note thet every 'IQRequest' must be answered exactly once. To insure this, +-- the incoming requests are wrapped in an 'IQRequestTicket' that prevents +-- multiple responses. Use 'iqRequestBody' to extract the corresponding request +-- and 'answerIQ' to send the response +listenIQChan :: IQRequestType -- ^ Type of IQs to receive ('Get' or 'Set') -> Text -- ^ Namespace of the child element -> Session -> IO (Either (TChan IQRequestTicket) (TChan IQRequestTicket)) @@ -85,23 +88,22 @@ listenIQChan tp ns session = do Nothing -> Right iqCh Just iqCh' -> Left iqCh' -answerIQ :: IQRequestTicket - -> Either StanzaError (Maybe Element) - -> Session - -> IO Bool -answerIQ (IQRequestTicket - sentRef - (IQRequest iqid from _to lang _tp bd)) - answer session = do - let response = case answer of - Left err -> IQErrorS $ IQError iqid Nothing from lang err (Just bd) - Right res -> IQResultS $ IQResult iqid Nothing from lang res - atomically $ do - sent <- readTVar sentRef - case sent of - False -> do - writeTVar sentRef True +-- | Unregister a previously acquired IQ channel. Please make sure that you +-- where the one who acquired it in the first place as no check for ownership +-- can be made +dropIQChan :: IQRequestType -- ^ Type of IQ ('Get' or 'Set') + -> Text -- ^ Namespace of the child element + -> Session + -> IO () +dropIQChan tp ns session = do + let handlers = (iqHandlers session) + atomically $ do + (byNS, byID) <- readTVar handlers + let byNS' = Map.delete (tp, ns) byNS + writeTVar handlers (byNS', byID) + return () - writeTChan (outCh session) response - return True - True -> return False +-- | Answer an IQ request. Only the first answer ist sent and then True is +-- returned. Subsequent answers are dropped and (False is returned in that case) +answerIQ :: IQRequestTicket -> Either StanzaError (Maybe Element) -> IO Bool +answerIQ ticket = answerTicket ticket diff --git a/source/Network/Xmpp/Concurrent/Message.hs b/source/Network/Xmpp/Concurrent/Message.hs index 543303c..234484c 100644 --- a/source/Network/Xmpp/Concurrent/Message.hs +++ b/source/Network/Xmpp/Concurrent/Message.hs @@ -3,9 +3,7 @@ module Network.Xmpp.Concurrent.Message where import Network.Xmpp.Concurrent.Types import Control.Concurrent.STM -import Data.IORef import Network.Xmpp.Types -import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Basic -- | Read an element from the inbound stanza channel, discardes any diff --git a/source/Network/Xmpp/Concurrent/Monad.hs b/source/Network/Xmpp/Concurrent/Monad.hs index 5a1d627..9a61745 100644 --- a/source/Network/Xmpp/Concurrent/Monad.hs +++ b/source/Network/Xmpp/Concurrent/Monad.hs @@ -60,15 +60,15 @@ import Network.Xmpp.Stream -- | Executes a function to update the event handlers. modifyHandlers :: (EventHandlers -> EventHandlers) -> Session -> IO () -modifyHandlers f session = atomically $ modifyTVar (eventHandlers session) f +modifyHandlers f session = atomically $ modifyTVar_ (eventHandlers session) f where -- Borrowing modifyTVar from -- http://hackage.haskell.org/packages/archive/stm/2.4/doc/html/src/Control-Concurrent-STM-TVar.html -- as it's not available in GHC 7.0. - modifyTVar :: TVar a -> (a -> a) -> STM () - modifyTVar var f = do + modifyTVar_ :: TVar a -> (a -> a) -> STM () + modifyTVar_ var g = do x <- readTVar var - writeTVar var (f x) + writeTVar var (g x) -- | Sets the handler to be executed when the server connection is closed. setConnectionClosedHandler_ :: (XmppFailure -> Session -> IO ()) -> Session -> IO () diff --git a/source/Network/Xmpp/Concurrent/Presence.hs b/source/Network/Xmpp/Concurrent/Presence.hs index d9cfc6e..cb6a502 100644 --- a/source/Network/Xmpp/Concurrent/Presence.hs +++ b/source/Network/Xmpp/Concurrent/Presence.hs @@ -2,7 +2,6 @@ module Network.Xmpp.Concurrent.Presence where import Control.Concurrent.STM -import Data.IORef import Network.Xmpp.Types import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Basic diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs index f1ce15d..5c0b03b 100644 --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -4,25 +4,18 @@ module Network.Xmpp.Concurrent.Threads where -import Network.Xmpp.Types - import Control.Applicative((<$>)) import Control.Concurrent import Control.Concurrent.STM import qualified Control.Exception.Lifted as Ex import Control.Monad -import Control.Monad.IO.Class +import Control.Monad.Error import Control.Monad.State.Strict - import qualified Data.ByteString as BS +import GHC.IO (unsafeUnmask) import Network.Xmpp.Concurrent.Types import Network.Xmpp.Stream - -import Control.Concurrent.STM.TMVar - -import GHC.IO (unsafeUnmask) - -import Control.Monad.Error +import Network.Xmpp.Types import System.Log.Logger -- Worker to read stanzas from the stream and concurrently distribute them to @@ -38,8 +31,8 @@ readWorker onStanza onConnectionClosed stateRef = -- necessarily be interruptible s <- atomically $ do s@(Stream con) <- readTMVar stateRef - state <- streamConnectionState <$> readTMVar con - when (state == Closed) + scs <- streamConnectionState <$> readTMVar con + when (scs == Closed) retry return s allowInterrupt @@ -55,7 +48,7 @@ readWorker onStanza onConnectionClosed stateRef = ] case res of Nothing -> return () -- Caught an exception, nothing to do. TODO: Can this happen? - Just (Left e) -> return () + Just (Left _) -> return () Just (Right sta) -> onStanza sta where -- Defining an Control.Exception.allowInterrupt equivalent for GHC 7 @@ -85,19 +78,19 @@ startThreadsWith :: (Stanza -> IO ()) TMVar Stream, ThreadId)) startThreadsWith stanzaHandler eh con = do - read <- withStream' (gets $ streamSend . streamHandle >>= \d -> return $ Right d) con - case read of + rd <- withStream' (gets $ streamSend . streamHandle >>= \d -> return $ Right d) con + case rd of Left e -> return $ Left e Right read' -> do writeLock <- newTMVarIO read' conS <- newTMVarIO con -- lw <- forkIO $ writeWorker outC writeLock cp <- forkIO $ connPersist writeLock - rd <- forkIO $ readWorker stanzaHandler (noCon eh) conS - return $ Right ( killConnection writeLock [rd, cp] + rdw <- forkIO $ readWorker stanzaHandler (noCon eh) conS + return $ Right ( killConnection writeLock [rdw, cp] , writeLock , conS - , rd + , rdw ) where killConnection writeLock threads = liftIO $ do diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index 008d853..c2b97b8 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -3,19 +3,16 @@ module Network.Xmpp.Concurrent.Types where -import qualified Control.Exception.Lifted as Ex import Control.Concurrent import Control.Concurrent.STM - +import qualified Control.Exception.Lifted as Ex import qualified Data.ByteString as BS -import Data.Typeable - -import Network.Xmpp.Types - -import Data.IORef import qualified Data.Map as Map import Data.Text (Text) +import Data.Typeable +import Data.XML.Types (Element) +import Network.Xmpp.IM.Roster.Types import Network.Xmpp.Types -- | Handlers to be run when the Xmpp session ends and when the Xmpp connection is @@ -47,6 +44,7 @@ data Session = Session , streamRef :: TMVar (Stream) , eventHandlers :: TVar EventHandlers , stopThreads :: IO () + , rosterRef :: TVar Roster , conf :: SessionConfiguration } @@ -59,6 +57,6 @@ type IQHandlers = (Map.Map (IQRequestType, Text) (TChan IQRequestTicket) -- | Contains whether or not a reply has been sent, and the IQ request body to -- reply to. data IQRequestTicket = IQRequestTicket - { sentRef :: (TVar Bool) + { answerTicket :: Either StanzaError (Maybe Element) -> IO Bool , iqRequestBody :: IQRequest } diff --git a/source/Network/Xmpp/IM.hs b/source/Network/Xmpp/IM.hs index 35b2c9c..2f5bf08 100644 --- a/source/Network/Xmpp/IM.hs +++ b/source/Network/Xmpp/IM.hs @@ -1,15 +1,28 @@ +-- | RFC 6121: Instant Messaging and Presence +-- module Network.Xmpp.IM ( -- * Instant Messages - subject - , thread - , body - , bodies - , newIM - , simpleIM - , answerIM - -- * Presence - , module Network.Xmpp.IM.Presence + MessageBody(..) + , MessageThread(..) + , MessageSubject(..) + , instantMessage + , getIM + , withIM + -- * Presence + , ShowStatus(..) + , IMPresence(..) + , imPresence + , getIMPresence + , withIMPresence + -- * Roster + , Roster(..) + , Item(..) + , getRoster + , rosterAdd + , rosterRemove ) where import Network.Xmpp.IM.Message import Network.Xmpp.IM.Presence +import Network.Xmpp.IM.Roster +import Network.Xmpp.IM.Roster.Types diff --git a/source/Network/Xmpp/IM/Message.hs b/source/Network/Xmpp/IM/Message.hs index e5aa830..7d5a4b2 100644 --- a/source/Network/Xmpp/IM/Message.hs +++ b/source/Network/Xmpp/IM/Message.hs @@ -1,119 +1,64 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} -module Network.Xmpp.IM.Message - where +module Network.Xmpp.IM.Message where -import Control.Applicative ((<$>)) - -import Data.Maybe (maybeToList, listToMaybe) import Data.Text (Text) import Data.XML.Pickle import Data.XML.Types - import Network.Xmpp.Marshal import Network.Xmpp.Types +import Network.Xmpp.Stanza +import Data.List +import Data.Function + -data MessageBody = MessageBody { bodyLang :: (Maybe LangTag) +data MessageBody = MessageBody { bodyLang :: Maybe LangTag , bodyContent :: Text } -data MessageThread = MessageThread { theadID :: Text - , threadParent :: (Maybe Text) +data MessageThread = MessageThread { theadID :: Text + , threadParent :: Maybe Text } -data MessageSubject = MessageSubject { subjectLang :: (Maybe LangTag) +data MessageSubject = MessageSubject { subjectLang :: Maybe LangTag , subjectContent :: Text } -xpMessageSubject :: PU [Element] MessageSubject -xpMessageSubject = xpUnliftElems . - xpWrap (\(l, s) -> MessageSubject l s) - (\(MessageSubject l s) -> (l,s)) - $ xpElem "{jabber:client}subject" xpLangTag $ xpContent xpId +-- | The instant message (IM) specific part of a message. +data InstantMessage = InstantMessage { imThread :: Maybe MessageThread + , imSubject :: [MessageSubject] + , imBody :: [MessageBody] + } -xpMessageBody :: PU [Element] MessageBody -xpMessageBody = xpUnliftElems . - xpWrap (\(l, s) -> MessageBody l s) - (\(MessageBody l s) -> (l,s)) - $ xpElem "{jabber:client}body" xpLangTag $ xpContent xpId +instantMessage :: InstantMessage +instantMessage = InstantMessage { imThread = Nothing + , imSubject = [] + , imBody = [] + } -xpMessageThread :: PU [Element] MessageThread -xpMessageThread = xpUnliftElems - . xpWrap (\(t, p) -> MessageThread p t) - (\(MessageThread p t) -> (t,p)) - $ xpElem "{jabber:client}thread" - (xpAttrImplied "parent" xpId) - (xpContent xpId) +-- | Get the IM specific parts of a message. Returns 'Nothing' when the received +-- payload is not valid IM data. +getIM :: Message -> Maybe InstantMessage +getIM im = either (const Nothing) Just . unpickle xpIM $ messagePayload im --- | Get the subject elements of a message (if any). Messages may --- contain multiple subjects if each of them has a distinct xml:lang --- attribute -subject :: Message -> [MessageSubject] -subject m = ms - where - -- xpFindMatches will _always_ return Right - Right ms = unpickle (xpFindMatches xpMessageSubject) $ messagePayload m - --- | Get the thread elements of a message (if any). The thread of a --- message is considered opaque, that is, no meaning, other than it's --- literal identity, may be derived from it and it is not human --- readable -thread :: Message -> Maybe MessageThread -thread m = ms - where - -- xpFindMatches will _always_ return Right - Right ms = unpickle (xpOption xpMessageThread) $ messagePayload m - --- | Get the body elements of a message (if any). Messages may contain --- multiple bodies if each of them has a distinct xml:lang attribute -bodies :: Message -> [MessageBody] -bodies m = ms - where - -- xpFindMatches will _always_ return Right - Right ms = unpickle (xpFindMatches xpMessageBody) $ messagePayload m - --- | Return the first body element, regardless of it's language. -body :: Message -> Maybe Text -body m = bodyContent <$> listToMaybe (bodies m) - --- | Generate a new instant message -newIM - :: Jid - -> Maybe StanzaID - -> Maybe LangTag - -> MessageType - -> Maybe MessageSubject - -> Maybe MessageThread - -> Maybe MessageBody - -> [Element] - -> Message -newIM t i lang tp sbj thrd bdy payload = Message - { messageID = i - , messageFrom = Nothing - , messageTo = Just t - , messageLangTag = lang - , messageType = tp - , messagePayload = concat $ - maybeToList (pickle xpMessageSubject <$> sbj) - ++ maybeToList (pickle xpMessageThread <$> thrd) - ++ maybeToList (pickle xpMessageBody <$> bdy) - ++ [payload] - } +sanitizeIM :: InstantMessage -> InstantMessage +sanitizeIM im = im{imBody = nubBy ((==) `on` bodyLang) $ imBody im} + +-- | Append IM data to a message +withIM :: Message -> InstantMessage -> Message +withIM m im = m{ messagePayload = messagePayload m + ++ pickleTree xpIM (sanitizeIM im) } + +imToElements :: InstantMessage -> [Element] +imToElements im = pickle xpIM (sanitizeIM im) -- | Generate a simple message simpleIM :: Jid -- ^ recipient -> Text -- ^ body -> Message -simpleIM t bd = newIM - t - Nothing - Nothing - Normal - Nothing - Nothing - (Just $ MessageBody Nothing bd) - [] +simpleIM to bd = withIM message{messageTo = Just to} + instantMessage{imBody = [MessageBody Nothing bd]} -- | Generate an answer from a received message. The recepient is -- taken from the original sender, the sender is set to Nothing, @@ -121,17 +66,48 @@ simpleIM t bd = newIM -- thread are inherited, the remaining payload is replaced by the -- given one. -- --- If multiple message bodies are given they must have different language tags -answerIM :: [MessageBody] -> [Element] -> Message -> Message -answerIM bd payload msg = Message - { messageID = messageID msg - , messageFrom = Nothing - , messageTo = messageFrom msg - , messageLangTag = messageLangTag msg - , messageType = messageType msg - , messagePayload = concat $ - (pickle xpMessageSubject <$> subject msg) - ++ maybeToList (pickle xpMessageThread <$> thread msg) - ++ (pickle xpMessageBody <$> bd) - ++ [payload] - } +-- If multiple message bodies are given they MUST have different language tags +answerIM :: [MessageBody] -> Message -> Maybe Message +answerIM bd msg = case getIM msg of + Nothing -> Nothing + Just im -> Just $ flip withIM (im{imBody = bd}) $ + message { messageID = messageID msg + , messageFrom = Nothing + , messageTo = messageFrom msg + , messageLangTag = messageLangTag msg + , messageType = messageType msg + } + +-------------------------- +-- Picklers -------------- +-------------------------- +xpIM :: PU [Element] InstantMessage +xpIM = xpWrap (\(t, s, b) -> InstantMessage t s b) + (\(InstantMessage t s b) -> (t, s, b)) + . xpClean + $ xp3Tuple + xpMessageThread + xpMessageSubject + xpMessageBody + + +xpMessageSubject :: PU [Element] [MessageSubject] +xpMessageSubject = xpUnliftElems . + xpWrap (map $ \(l, s) -> MessageSubject l s) + (map $ \(MessageSubject l s) -> (l,s)) + $ xpElems "{jabber:client}subject" xpLangTag $ xpContent xpId + +xpMessageBody :: PU [Element] [MessageBody] +xpMessageBody = xpUnliftElems . + xpWrap (map $ \(l, s) -> MessageBody l s) + (map $ \(MessageBody l s) -> (l,s)) + $ xpElems "{jabber:client}body" xpLangTag $ xpContent xpId + +xpMessageThread :: PU [Element] (Maybe MessageThread) +xpMessageThread = xpUnliftElems + . xpOption + . xpWrap (\(t, p) -> MessageThread p t) + (\(MessageThread p t) -> (t,p)) + $ xpElem "{jabber:client}thread" + (xpAttrImplied "parent" xpId) + (xpContent xpId) diff --git a/source/Network/Xmpp/IM/Presence.hs b/source/Network/Xmpp/IM/Presence.hs index 512da70..dbfc4f5 100644 --- a/source/Network/Xmpp/IM/Presence.hs +++ b/source/Network/Xmpp/IM/Presence.hs @@ -1,76 +1,67 @@ {-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} module Network.Xmpp.IM.Presence where -import Data.Text(Text) -import Network.Xmpp.Types +import Data.Text (Text) +import Data.XML.Pickle +import Data.XML.Types +import Network.Xmpp.Types --- | An empty presence. -presence :: Presence -presence = Presence { presenceID = Nothing - , presenceFrom = Nothing - , presenceTo = Nothing - , presenceLangTag = Nothing - , presenceType = Nothing - , presencePayload = [] - } +data ShowStatus = StatusAway + | StatusChat + | StatusDnd + | StatusXa --- | Request subscription with an entity. -presenceSubscribe :: Jid -> Presence -presenceSubscribe to = presence { presenceTo = Just to - , presenceType = Just Subscribe - } +instance Show ShowStatus where + show StatusAway = "away" + show StatusChat = "chat" + show StatusDnd = "dnd" + show StatusXa = "xa" --- | Is presence a subscription request? -isPresenceSubscribe :: Presence -> Bool -isPresenceSubscribe pres = presenceType pres == (Just Subscribe) +instance Read ShowStatus where + readsPrec _ "away" = [(StatusAway, "")] + readsPrec _ "chat" = [(StatusChat, "")] + readsPrec _ "dnd" = [(StatusDnd , "")] + readsPrec _ "xa" = [(StatusXa , "")] + readsPrec _ _ = [] --- | Approve a subscripton of an entity. -presenceSubscribed :: Jid -> Presence -presenceSubscribed to = presence { presenceTo = Just to - , presenceType = Just Subscribed - } +data IMPresence = IMP { showStatus :: Maybe ShowStatus + , status :: Maybe Text + , priority :: Maybe Int + } --- | Is presence a subscription approval? -isPresenceSubscribed :: Presence -> Bool -isPresenceSubscribed pres = presenceType pres == (Just Subscribed) +imPresence :: IMPresence +imPresence = IMP { showStatus = Nothing + , status = Nothing + , priority = Nothing + } --- | End a subscription with an entity. -presenceUnsubscribe :: Jid -> Presence -presenceUnsubscribe to = presence { presenceTo = Just to - , presenceType = Just Unsubscribed - } --- | Is presence an unsubscription request? -isPresenceUnsubscribe :: Presence -> Bool -isPresenceUnsubscribe pres = presenceType pres == (Just Unsubscribe) +getIMPresence :: Presence -> Maybe IMPresence +getIMPresence pres = case unpickle xpIMPresence (presencePayload pres) of + Left _ -> Nothing + Right r -> Just r --- | Signal to the server that the client is available for communication. -presenceOnline :: Presence -presenceOnline = presence +withIMPresence :: IMPresence -> Presence -> Presence +withIMPresence imPres pres = pres{presencePayload = presencePayload pres + ++ pickleTree xpIMPresence + imPres} --- | Signal to the server that the client is no longer available for --- communication. -presenceOffline :: Presence -presenceOffline = presence {presenceType = Just Unavailable} +-- +-- Picklers +-- ----- Change your status ---status --- :: Maybe Text -- ^ Status message --- -> Maybe ShowType -- ^ Status Type --- -> Maybe Int -- ^ Priority --- -> Presence ---status txt showType prio = presence { presenceShowType = showType --- , presencePriority = prio --- , presenceStatus = txt --- } - --- | Set the current availability status. This implicitly sets the client's --- status online. ---presenceAvail :: ShowType -> Presence ---presenceAvail showType = status Nothing (Just showType) Nothing - --- | Set the current status message. This implicitly sets the client's status --- online. ---presenceMessage :: Text -> Presence ---presenceMessage txt = status (Just txt) Nothing Nothing +xpIMPresence :: PU [Element] IMPresence +xpIMPresence = xpUnliftElems . + xpWrap (\(s, st, p) -> IMP s st p) + (\(IMP s st p) -> (s, st, p)) . + xpClean $ + xp3Tuple + (xpOption $ xpElemNodes "{jabber:client}show" + (xpContent xpPrim)) + (xpOption $ xpElemNodes "{jabber:client}status" + (xpContent xpText)) + (xpOption $ xpElemNodes "{jabber:client}priority" + (xpContent xpPrim)) diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs index 1f359f9..7658bc3 100644 --- a/source/Network/Xmpp/IM/Roster.hs +++ b/source/Network/Xmpp/IM/Roster.hs @@ -1,104 +1,101 @@ -{-# LANGUAGE PatternGuards #-} +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.IM.Roster -where +module Network.Xmpp.IM.Roster where -import Control.Concurrent.STM -import Control.Monad -import Data.Text (Text) -import Data.XML.Pickle -import Data.XML.Types -import Network.Xmpp -import Network.Xmpp.Marshal -import System.Log.Logger +import Control.Concurrent.STM +import Control.Monad +import Data.List (nub) import qualified Data.Map.Strict as Map - -import Network.Xmpp.Types - -data Subscription = None | To | From | Both | Remove deriving Eq - -instance Show Subscription where - show None = "none" - show To = "to" - show From = "from" - show Both = "both" - show Remove = "remove" - -instance Read Subscription where - readsPrec _ "none" = [(None ,"")] - readsPrec _ "to" = [(To ,"")] - readsPrec _ "from" = [(From ,"")] - readsPrec _ "both" = [(Both ,"")] - readsPrec _ "remove" = [(Remove ,"")] - readsPrec _ _ = [] - -data Roster = Roster { ver :: Maybe Text - , items :: Map.Map Jid Item } - - -data Item = Item { approved :: Bool - , ask :: Bool - , jid :: Jid - , name :: Maybe Text - , subscription :: Subscription - , groups :: [Text] - } deriving Show - -data QueryItem = QueryItem { qiApproved :: Maybe Bool - , qiAsk :: Bool - , qiJid :: Jid - , qiName :: Maybe Text - , qiSubscription :: Maybe Subscription - , qiGroups :: [Text] - } deriving Show - -data Query = Query { queryVer :: Maybe Text - , queryItems :: [QueryItem] - } deriving Show - - -withRoster :: Maybe Roster - -> SessionConfiguration - -> (SessionConfiguration -> IO (Either XmppFailure Session)) - -> IO (Either XmppFailure (TVar Roster, Session)) -withRoster oldRoster conf startSession = do - rosterRef <- newTVarIO $ Roster Nothing Map.empty - mbSess <- startSession conf{extraStanzaHandlers = handleRoster rosterRef : - extraStanzaHandlers conf} - case mbSess of - Left e -> return $ Left e - Right sess -> do - mbRoster <- getRoster oldRoster sess - case mbRoster of - Nothing -> errorM "Pontarius.Xmpp" "Server did not return a roster" - Just roster -> atomically $ writeTVar rosterRef roster - return $ Right (rosterRef, sess) +import Data.Maybe (isJust, fromMaybe) +import Data.Text (Text) +import Data.XML.Pickle +import Data.XML.Types +import System.Log.Logger + +import Network.Xmpp.IM.Roster.Types +import Network.Xmpp.Marshal +import Network.Xmpp.Concurrent.Types +import Network.Xmpp.Types +import Network.Xmpp.Concurrent.IQ + +-- | Push a roster item to the server. The values for approved and ask are +-- ignored and all values for subsciption except "remove" are ignored +rosterPush :: Item -> Session -> IO IQResponse +rosterPush item session = do + let el = pickleElem xpQuery (Query Nothing [fromItem item]) + sendIQ' Nothing Set Nothing el session + +-- | Add or update an item to the roster. +-- +-- To update the item just send the complete set of new data +rosterAdd :: Jid -- ^ JID of the item + -> Maybe Text -- ^ Name alias + -> [Text] -- ^ Groups (duplicates will be removed) + -> Session + -> IO IQResponse +rosterAdd j n gs session = do + let el = pickleElem xpQuery (Query Nothing + [QueryItem { qiApproved = Nothing + , qiAsk = False + , qiJid = j + , qiName = n + , qiSubscription = Nothing + , qiGroups = nub gs + }]) + sendIQ' Nothing Set Nothing el session + +-- | Remove an item from the roster. Return True when the item is sucessfully +-- removed or if it wasn't in the roster to begin with. +rosterRemove :: Jid -> Session -> IO Bool +rosterRemove j sess = do + roster <- getRoster sess + case Map.lookup j (items roster) of + Nothing -> return True -- jid is not on the Roster + Just _ -> do + res <- rosterPush (Item False False j Nothing Remove []) sess + case res of + IQResponseResult IQResult{} -> return True + _ -> return False + +-- | Retrieve the current Roster state +getRoster :: Session -> IO Roster +getRoster session = atomically $ readTVar (rosterRef session) + +-- | Get the initial roster / refresh the roster. You don't need to call this on your own +initRoster :: Session -> IO () +initRoster session = do + oldRoster <- getRoster session + mbRoster <- retrieveRoster (if isJust (ver oldRoster) then Just oldRoster + else Nothing ) session + case mbRoster of + Nothing -> errorM "Pontarius.Xmpp" + "Server did not return a roster" + Just roster -> atomically $ writeTVar (rosterRef session) roster handleRoster :: TVar Roster -> TChan Stanza -> Stanza -> IO Bool -handleRoster rosterRef outC sta = do - case sta of - IQRequestS (iqr@IQRequest{iqRequestPayload = - iqb@Element{elementName = en}}) - | nameNamespace en == Just "jabber:iq:roster" -> do - case iqRequestFrom iqr of - Just _from -> return True -- Don't handle roster pushes from - -- unauthorized sources - Nothing -> case unpickleElem xpQuery iqb of - Right Query{ queryVer = v - , queryItems = [update] - } -> do - handleUpdate v update - atomically . writeTChan outC $ result iqr - return False - _ -> do - errorM "Pontarius.Xmpp" "Invalid roster query" - atomically . writeTChan outC $ badRequest iqr - return False - _ -> return True +handleRoster ref outC sta = case sta of + IQRequestS (iqr@IQRequest{iqRequestPayload = + iqb@Element{elementName = en}}) + | nameNamespace en == Just "jabber:iq:roster" -> do + case iqRequestFrom iqr of + Just _from -> return True -- Don't handle roster pushes from + -- unauthorized sources + Nothing -> case unpickleElem xpQuery iqb of + Right Query{ queryVer = v + , queryItems = [update] + } -> do + handleUpdate v update + atomically . writeTChan outC $ result iqr + return False + _ -> do + errorM "Pontarius.Xmpp" "Invalid roster query" + atomically . writeTChan outC $ badRequest iqr + return False + _ -> return True where - handleUpdate v' update = atomically $ modifyTVar rosterRef $ \(Roster v is) -> + handleUpdate v' update = atomically $ modifyTVar ref $ \(Roster v is) -> Roster (v' `mplus` v) $ case qiSubscription update of Just Remove -> Map.delete (qiJid update) is _ -> Map.insert (qiJid update) (toItem update) is @@ -109,8 +106,8 @@ handleRoster rosterRef outC sta = do result (IQRequest iqid from _to lang _tp _bd) = IQResultS $ IQResult iqid Nothing from lang Nothing -getRoster :: Maybe Roster -> Session -> IO (Maybe Roster) -getRoster oldRoster sess = do +retrieveRoster :: Maybe Roster -> Session -> IO (Maybe Roster) +retrieveRoster oldRoster sess = do res <- sendIQ' Nothing Get Nothing (pickleElem xpQuery (Query (ver =<< oldRoster) [])) sess @@ -120,9 +117,9 @@ getRoster oldRoster sess = do Left _e -> do errorM "Pontarius.Xmpp.Roster" "getRoster: invalid query element" return Nothing - Right roster -> return . Just $ toRoster roster + Right ros' -> return . Just $ toRoster ros' IQResponseResult (IQResult{iqResultPayload = Nothing}) -> do - return $ oldRoster + return oldRoster -- sever indicated that no roster updates are necessary IQResponseTimeout -> do errorM "Pontarius.Xmpp.Roster" "getRoster: request timed out" @@ -137,14 +134,25 @@ getRoster oldRoster sess = do is) toItem :: QueryItem -> Item -toItem qi = Item { approved = maybe False id (qiApproved qi) +toItem qi = Item { approved = fromMaybe False (qiApproved qi) , ask = qiAsk qi , jid = qiJid qi , name = qiName qi - , subscription = maybe None id (qiSubscription qi) - , groups = qiGroups qi + , subscription = fromMaybe None (qiSubscription qi) + , groups = nub $ qiGroups qi } +fromItem :: Item -> QueryItem +fromItem i = QueryItem { qiApproved = Nothing + , qiAsk = False + , qiJid = jid i + , qiName = name i + , qiSubscription = case subscription i of + Remove -> Just Remove + _ -> Nothing + , qiGroups = nub $ groups i + } + xpItems :: PU [Node] [QueryItem] xpItems = xpWrap (map (\((app_, ask_, jid_, name_, sub_), groups_) -> QueryItem app_ ask_ jid_ name_ sub_ groups_)) @@ -153,7 +161,7 @@ xpItems = xpWrap (map (\((app_, ask_, jid_, name_, sub_), groups_) -> xpElems "{jabber:iq:roster}item" (xp5Tuple (xpAttribute' "approved" xpBool) - (xpWrap (maybe False (const True)) + (xpWrap isJust (\p -> if p then Just () else Nothing) $ xpOption $ xpAttribute_ "ask" "subscribe") (xpAttribute "jid" xpPrim) diff --git a/source/Network/Xmpp/IM/Roster/Types.hs b/source/Network/Xmpp/IM/Roster/Types.hs new file mode 100644 index 0000000..04854b4 --- /dev/null +++ b/source/Network/Xmpp/IM/Roster/Types.hs @@ -0,0 +1,47 @@ +module Network.Xmpp.IM.Roster.Types where + +import qualified Data.Map as Map +import Data.Text (Text) +import Network.Xmpp.Types + +data Subscription = None | To | From | Both | Remove deriving Eq + +instance Show Subscription where + show None = "none" + show To = "to" + show From = "from" + show Both = "both" + show Remove = "remove" + +instance Read Subscription where + readsPrec _ "none" = [(None ,"")] + readsPrec _ "to" = [(To ,"")] + readsPrec _ "from" = [(From ,"")] + readsPrec _ "both" = [(Both ,"")] + readsPrec _ "remove" = [(Remove ,"")] + readsPrec _ _ = [] + +data Roster = Roster { ver :: Maybe Text + , items :: Map.Map Jid Item } deriving Show + + + +data Item = Item { approved :: Bool + , ask :: Bool + , jid :: Jid + , name :: Maybe Text + , subscription :: Subscription + , groups :: [Text] + } deriving Show + +data QueryItem = QueryItem { qiApproved :: Maybe Bool + , qiAsk :: Bool + , qiJid :: Jid + , qiName :: Maybe Text + , qiSubscription :: Maybe Subscription + , qiGroups :: [Text] + } deriving Show + +data Query = Query { queryVer :: Maybe Text + , queryItems :: [QueryItem] + } deriving Show diff --git a/source/Network/Xmpp/Internal.hs b/source/Network/Xmpp/Internal.hs index 60f7fbc..c06d06e 100644 --- a/source/Network/Xmpp/Internal.hs +++ b/source/Network/Xmpp/Internal.hs @@ -29,7 +29,7 @@ module Network.Xmpp.Internal , pushStanza , pullStanza , pushIQ - , SaslHandler(..) + , SaslHandler , StanzaID(..) ) @@ -37,9 +37,6 @@ module Network.Xmpp.Internal import Network.Xmpp.Stream import Network.Xmpp.Sasl -import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.Types import Network.Xmpp.Tls import Network.Xmpp.Types -import Network.Xmpp.Stream -import Network.Xmpp.Marshal diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index cab4c6d..00df024 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -1,6 +1,6 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} - +-- -- Submodule for functionality related to SASL negotation: -- authentication functions, SASL functionality, bind functionality, -- and the legacy `{urn:ietf:params:xml:ns:xmpp-session}session' @@ -14,51 +14,17 @@ module Network.Xmpp.Sasl , auth ) where -import Control.Applicative -import Control.Arrow (left) -import Control.Monad import Control.Monad.Error import Control.Monad.State.Strict -import Data.Maybe (fromJust, isJust) - -import qualified Crypto.Classes as CC - -import qualified Data.Binary as Binary -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as BL -import qualified Data.Digest.Pure.MD5 as MD5 -import qualified Data.List as L -import Data.Word (Word8) - -import qualified Data.Text as Text import Data.Text (Text) -import qualified Data.Text.Encoding as Text - -import Network.Xmpp.Stream -import Network.Xmpp.Types - -import System.Log.Logger (debugM, errorM) -import qualified System.Random as Random - -import Network.Xmpp.Sasl.Types -import Network.Xmpp.Sasl.Mechanisms - -import Control.Concurrent.STM.TMVar - -import Control.Exception - import Data.XML.Pickle import Data.XML.Types - -import Network.Xmpp.Types import Network.Xmpp.Marshal - -import Control.Monad.State(modify) - -import Control.Concurrent.STM.TMVar - -import Control.Monad.Error +import Network.Xmpp.Sasl.Mechanisms +import Network.Xmpp.Sasl.Types +import Network.Xmpp.Stream +import Network.Xmpp.Types +import System.Log.Logger (debugM, errorM, infoM) -- | Uses the first supported mechanism to authenticate, if any. Updates the -- state with non-password credentials and restarts the stream upon @@ -105,16 +71,18 @@ auth :: [SaslHandler] -> Stream -> IO (Either XmppFailure (Maybe AuthFailure)) auth mechanisms resource con = runErrorT $ do - ErrorT $ xmppSasl mechanisms con - jid <- ErrorT $ xmppBind resource con - ErrorT $ flip withStream con $ do - s <- get - case establishSession $ streamConfiguration s of - False -> return $ Right Nothing - True -> do - _ <- lift $ startSession con - return $ Right Nothing - return Nothing + mbAuthFail <- ErrorT $ xmppSasl mechanisms con + case mbAuthFail of + Nothing -> do + _jid <- ErrorT $ xmppBind resource con + ErrorT $ flip withStream' con $ do + s <- get + case establishSession $ streamConfiguration s of + False -> return $ Right Nothing + True -> do + _ <-liftIO $ startSession con + return $ Right Nothing + f -> return f -- Produces a `bind' element, optionally wrapping a resource. bindBody :: Maybe Text -> Element @@ -133,20 +101,21 @@ xmppBind rsrc c = runErrorT $ do answer <- ErrorT $ pushIQ "bind" Nothing Set Nothing (bindBody rsrc) c case answer of Right IQResult{iqResultPayload = Just b} -> do - lift $ debugM "Pontarius.XMPP" "xmppBind: IQ result received; unpickling JID..." + lift $ debugM "Pontarius.Xmpp" "xmppBind: IQ result received; unpickling JID..." let jid = unpickleElem xpJid b case jid of Right jid' -> do - lift $ debugM "Pontarius.XMPP" $ "xmppBind: JID unpickled: " ++ show jid' - ErrorT $ withStream (do - modify $ \s -> s{streamJid = Just jid'} - return $ Right jid') c -- not pretty + lift $ infoM "Pontarius.Xmpp" $ "Bound JID: " ++ show jid' + _ <- lift $ withStream ( do modify $ \s -> + s{streamJid = Just jid'}) + c return jid' - otherwise -> do - lift $ errorM "Pontarius.XMPP" $ "xmppBind: JID could not be unpickled from: " - ++ show b + _ -> do + lift $ errorM "Pontarius.Xmpp" + $ "xmppBind: JID could not be unpickled from: " + ++ show b throwError $ XmppOtherFailure - otherwise -> do + _ -> do lift $ errorM "Pontarius.XMPP" "xmppBind: IQ error received." throwError XmppOtherFailure where @@ -164,15 +133,6 @@ sessionXml = pickleElem (xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session") () -sessionIQ :: Stanza -sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" - , iqRequestFrom = Nothing - , iqRequestTo = Nothing - , iqRequestLangTag = Nothing - , iqRequestType = Set - , iqRequestPayload = sessionXml - } - -- Sends the session IQ set element and waits for an answer. Throws an error if -- if an IQ error stanza is returned from the server. startSession :: Stream -> IO Bool diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index 3a5382c..fb15668 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -4,28 +4,23 @@ module Network.Xmpp.Sasl.Common where -import Network.Xmpp.Types - import Control.Applicative ((<$>)) import Control.Monad.Error -import Control.Monad.State.Class - import qualified Data.Attoparsec.ByteString.Char8 as AP import Data.Bits import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 -import Data.Maybe (fromMaybe) import Data.Maybe (maybeToList) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Word (Word8) import Data.XML.Pickle import Data.XML.Types - -import Network.Xmpp.Stream +import Network.Xmpp.Marshal import Network.Xmpp.Sasl.StringPrep import Network.Xmpp.Sasl.Types -import Network.Xmpp.Marshal +import Network.Xmpp.Stream +import Network.Xmpp.Types import qualified System.Random as Random @@ -66,9 +61,9 @@ pairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do AP.skipSpace name <- AP.takeWhile1 (/= '=') _ <- AP.char '=' - quote <- ((AP.char '"' >> return True) `mplus` return False) + qt <- ((AP.char '"' >> return True) `mplus` return False) content <- AP.takeWhile1 (AP.notInClass [',', '"']) - when quote . void $ AP.char '"' + when qt . void $ AP.char '"' return (name, content) -- Failure element pickler. @@ -108,19 +103,20 @@ xpSaslElement = xpAlt saslSel quote :: BS.ByteString -> BS.ByteString quote x = BS.concat ["\"",x,"\""] -saslInit :: Text.Text -> Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) Bool +saslInit :: Text.Text -> Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) () saslInit mechanism payload = do r <- lift . pushElement . saslInitE mechanism $ Text.decodeUtf8 . B64.encode <$> payload case r of - Left e -> throwError $ AuthStreamFailure e - Right b -> return b + Right True -> return () + Right False -> throwError $ AuthStreamFailure XmppNoStream + Left e -> throwError $ AuthStreamFailure e -- | Pull the next element. pullSaslElement :: ErrorT AuthFailure (StateT StreamState IO) SaslElement pullSaslElement = do - r <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement) - case r of + mbse <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement) + case mbse of Left e -> throwError $ AuthStreamFailure e Right (Left e) -> throwError $ AuthSaslFailure e Right (Right r) -> return r @@ -173,13 +169,13 @@ toPairs ctext = case pairs ctext of Right r -> return r -- | Send a SASL response element. The content will be base64-encoded. -respond :: Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) Bool +respond :: Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) () respond m = do r <- lift . pushElement . saslResponseE . fmap (Text.decodeUtf8 . B64.encode) $ m case r of Left e -> throwError $ AuthStreamFailure e - Right b -> return b - + Right False -> throwError $ AuthStreamFailure XmppNoStream + Right True -> return () -- | Run the appropriate stringprep profiles on the credentials. -- May fail with 'AuthStringPrepFailure' @@ -190,12 +186,12 @@ prepCredentials authcid authzid password = case credentials of Just creds -> return creds where credentials = do - ac <- normalizeUsername authcid - az <- case authzid of - Nothing -> Just Nothing - Just az' -> Just <$> normalizeUsername az' - pw <- normalizePassword password - return (ac, az, pw) + ac <- normalizeUsername authcid + az <- case authzid of + Nothing -> Just Nothing + Just az' -> Just <$> normalizeUsername az' + pw <- normalizePassword password + return (ac, az, pw) -- | Bit-wise xor of byte strings xorBS :: BS.ByteString -> BS.ByteString -> BS.ByteString diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs index 7e7aca4..36e87eb 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -5,37 +5,21 @@ module Network.Xmpp.Sasl.Mechanisms.DigestMd5 ( digestMd5 ) where -import Control.Applicative -import Control.Arrow (left) -import Control.Monad import Control.Monad.Error import Control.Monad.State.Strict -import Data.Maybe (fromJust, isJust) - import qualified Crypto.Classes as CC - import qualified Data.Binary as Binary +import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BL import qualified Data.Digest.Pure.MD5 as MD5 import qualified Data.List as L - -import qualified Data.Text as Text import Data.Text (Text) import qualified Data.Text.Encoding as Text - -import Data.XML.Pickle - -import qualified Data.ByteString as BS - -import Data.XML.Types - -import Network.Xmpp.Stream -import Network.Xmpp.Types import Network.Xmpp.Sasl.Common -import Network.Xmpp.Sasl.StringPrep import Network.Xmpp.Sasl.Types +import Network.Xmpp.Types @@ -43,19 +27,19 @@ xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username) -> Maybe Text -- ^ Authorization identity (authcid) -> Text -- ^ Password (authzid) -> ErrorT AuthFailure (StateT StreamState IO) () -xmppDigestMd5 authcid authzid password = do - (ac, az, pw) <- prepCredentials authcid authzid password +xmppDigestMd5 authcid' authzid' password' = do + (ac, az, pw) <- prepCredentials authcid' authzid' password' Just address <- gets streamAddress xmppDigestMd5' address ac az pw where xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> ErrorT AuthFailure (StateT StreamState IO) () - xmppDigestMd5' hostname authcid authzid password = do + xmppDigestMd5' hostname authcid _authzid password = do -- TODO: use authzid? -- Push element and receive the challenge. _ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean? - pairs <- toPairs =<< saslFromJust =<< pullChallenge + prs <- toPairs =<< saslFromJust =<< pullChallenge cnonce <- liftIO $ makeNonce - _b <- respond . Just $ createResponse hostname pairs cnonce - challenge2 <- pullFinalMessage + _b <- respond . Just $ createResponse hostname prs cnonce + _challenge2 <- pullFinalMessage return () where -- Produce the response to the challenge. @@ -63,19 +47,19 @@ xmppDigestMd5 authcid authzid password = do -> Pairs -> BS.ByteString -- nonce -> BS.ByteString - createResponse hostname pairs cnonce = let - Just qop = L.lookup "qop" pairs -- TODO: proper handling - Just nonce = L.lookup "nonce" pairs + createResponse hname prs cnonce = let + Just qop = L.lookup "qop" prs -- TODO: proper handling + Just nonce = L.lookup "nonce" prs uname_ = Text.encodeUtf8 authcid passwd_ = Text.encodeUtf8 password -- Using Int instead of Word8 for random 1.0.0.0 (GHC 7) -- compatibility. nc = "00000001" - digestURI = "xmpp/" `BS.append` Text.encodeUtf8 hostname + digestURI = "xmpp/" `BS.append` Text.encodeUtf8 hname digest = md5Digest uname_ - (lookup "realm" pairs) + (lookup "realm" prs) passwd_ digestURI nc @@ -84,7 +68,7 @@ xmppDigestMd5 authcid authzid password = do cnonce response = BS.intercalate "," . map (BS.intercalate "=") $ [["username", quote uname_]] ++ - case L.lookup "realm" pairs of + case L.lookup "realm" prs of Just realm -> [["realm" , quote realm ]] Nothing -> [] ++ [ ["nonce" , quote nonce ] @@ -115,8 +99,8 @@ xmppDigestMd5 authcid authzid password = do -> BS8.ByteString -> BS8.ByteString -> BS8.ByteString - md5Digest uname realm password digestURI nc qop nonce cnonce = - let ha1 = hash [ hashRaw [uname, maybe "" id realm, password] + md5Digest uname realm pwd digestURI nc qop nonce cnonce = + let ha1 = hash [ hashRaw [uname, maybe "" id realm, pwd] , nonce , cnonce ] diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs index fa35be7..0c32793 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs @@ -8,51 +8,22 @@ module Network.Xmpp.Sasl.Mechanisms.Plain ( plain ) where -import Control.Applicative -import Control.Arrow (left) -import Control.Monad import Control.Monad.Error import Control.Monad.State.Strict -import Data.Maybe (fromJust, isJust) - -import qualified Crypto.Classes as CC - -import qualified Data.Binary as Binary -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as BL -import qualified Data.Digest.Pure.MD5 as MD5 -import qualified Data.List as L -import Data.Word (Word8) - -import qualified Data.Text as Text -import Data.Text (Text) -import qualified Data.Text.Encoding as Text - -import Data.XML.Pickle - import qualified Data.ByteString as BS - -import Data.XML.Types - -import Network.Xmpp.Stream -import Network.Xmpp.Types - -import qualified System.Random as Random - -import Data.Maybe (fromMaybe) import qualified Data.Text as Text - +import qualified Data.Text.Encoding as Text import Network.Xmpp.Sasl.Common import Network.Xmpp.Sasl.Types +import Network.Xmpp.Types -- TODO: stringprep xmppPlain :: Text.Text -- ^ Password -> Maybe Text.Text -- ^ Authorization identity (authzid) -> Text.Text -- ^ Authentication identity (authcid) -> ErrorT AuthFailure (StateT StreamState IO) () -xmppPlain authcid authzid password = do - (ac, az, pw) <- prepCredentials authcid authzid password +xmppPlain authcid' authzid' password = do + (ac, az, pw) <- prepCredentials authcid' authzid' password _ <- saslInit "PLAIN" ( Just $ plainMessage ac az pw) _ <- pullSuccess return () @@ -63,15 +34,15 @@ xmppPlain authcid authzid password = do -> Maybe Text.Text -- Authentication identity (authcid) -> Text.Text -- Password -> BS.ByteString -- The PLAIN message - plainMessage authcid authzid passwd = BS.concat $ - [ authzid' - , "\NUL" - , Text.encodeUtf8 $ authcid - , "\NUL" - , Text.encodeUtf8 $ passwd - ] + plainMessage authcid _authzid passwd = BS.concat $ + [ authzid'' + , "\NUL" + , Text.encodeUtf8 $ authcid + , "\NUL" + , Text.encodeUtf8 $ passwd + ] where - authzid' = maybe "" Text.encodeUtf8 authzid + authzid'' = maybe "" Text.encodeUtf8 authzid' plain :: Text.Text -- ^ authentication ID (username) -> Maybe Text.Text -- ^ authorization ID diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs index 84535dc..01ce054 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -8,32 +8,20 @@ module Network.Xmpp.Sasl.Mechanisms.Scram import Control.Applicative ((<$>)) import Control.Monad.Error -import Control.Monad.Trans (liftIO) -import qualified Crypto.Classes as Crypto -import qualified Crypto.HMAC as Crypto -import qualified Crypto.Hash.SHA1 as Crypto -import Data.Binary(Binary,encode) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as B64 -import Data.ByteString.Char8 as BS8 (unpack) -import qualified Data.ByteString.Lazy as LBS +import Control.Monad.State.Strict +import qualified Crypto.Classes as Crypto +import qualified Crypto.HMAC as Crypto +import qualified Crypto.Hash.CryptoAPI as Crypto +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import Data.ByteString.Char8 as BS8 (unpack) import Data.List (foldl1', genericTake) - -import qualified Data.Binary.Builder as Build - -import Data.Maybe (maybeToList) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Data.Word(Word8) - +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import Network.Xmpp.Sasl.Common -import Network.Xmpp.Sasl.StringPrep import Network.Xmpp.Sasl.Types import Network.Xmpp.Types - -import Control.Monad.State.Strict - -- | A nicer name for undefined, for use as a dummy token to determin -- the hash function to use hashToken :: (Crypto.Hash ctx hash) => hash @@ -50,18 +38,18 @@ scram :: (Crypto.Hash ctx hash) -> Maybe Text.Text -- ^ Authorization ID -> Text.Text -- ^ Password -> ErrorT AuthFailure (StateT StreamState IO) () -scram hashToken authcid authzid password = do +scram hToken authcid authzid password = do (ac, az, pw) <- prepCredentials authcid authzid password - scramhelper hashToken ac az pw + scramhelper ac az pw where - scramhelper hashToken authcid authzid' password = do + scramhelper authcid' authzid' pwd = do cnonce <- liftIO $ makeNonce - saslInit "SCRAM-SHA-1" (Just $ cFirstMessage cnonce) + _ <- saslInit "SCRAM-SHA-1" (Just $ cFirstMessage cnonce) sFirstMessage <- saslFromJust =<< pullChallenge - pairs <- toPairs sFirstMessage - (nonce, salt, ic) <- fromPairs pairs cnonce + prs <- toPairs sFirstMessage + (nonce, salt, ic) <- fromPairs prs cnonce let (cfm, v) = cFinalMessageAndVerifier nonce salt ic sFirstMessage cnonce - respond $ Just cfm + _ <- respond $ Just cfm finalPairs <- toPairs =<< saslFromJust =<< pullFinalMessage unless (lookup "v" finalPairs == Just v) $ throwError AuthOtherFailure -- TODO: Log return () @@ -71,27 +59,27 @@ scram hashToken authcid authzid password = do encode _hashtoken = Crypto.encode hash :: BS.ByteString -> BS.ByteString - hash str = encode hashToken $ Crypto.hash' str + hash str = encode hToken $ Crypto.hash' str hmac :: BS.ByteString -> BS.ByteString -> BS.ByteString - hmac key str = encode hashToken $ Crypto.hmac' (Crypto.MacKey key) str + hmac key str = encode hToken $ Crypto.hmac' (Crypto.MacKey key) str - authzid :: Maybe BS.ByteString - authzid = (\z -> "a=" +++ Text.encodeUtf8 z) <$> authzid' + authzid'' :: Maybe BS.ByteString + authzid'' = (\z -> "a=" +++ Text.encodeUtf8 z) <$> authzid' gs2CbindFlag :: BS.ByteString gs2CbindFlag = "n" -- we don't support channel binding yet gs2Header :: BS.ByteString gs2Header = merge $ [ gs2CbindFlag - , maybe "" id authzid - , "" - ] - cbindData :: BS.ByteString - cbindData = "" -- we don't support channel binding yet + , maybe "" id authzid'' + , "" + ] + -- cbindData :: BS.ByteString + -- cbindData = "" -- we don't support channel binding yet cFirstMessageBare :: BS.ByteString -> BS.ByteString - cFirstMessageBare cnonce = merge [ "n=" +++ Text.encodeUtf8 authcid + cFirstMessageBare cnonce = merge [ "n=" +++ Text.encodeUtf8 authcid' , "r=" +++ cnonce] cFirstMessage :: BS.ByteString -> BS.ByteString cFirstMessage cnonce = gs2Header +++ cFirstMessageBare cnonce @@ -99,13 +87,13 @@ scram hashToken authcid authzid password = do fromPairs :: Pairs -> BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) (BS.ByteString, BS.ByteString, Integer) - fromPairs pairs cnonce | Just nonce <- lookup "r" pairs - , cnonce `BS.isPrefixOf` nonce - , Just salt' <- lookup "s" pairs - , Right salt <- B64.decode salt' - , Just ic <- lookup "i" pairs - , [(i,"")] <- reads $ BS8.unpack ic - = return (nonce, salt, i) + fromPairs prs cnonce | Just nonce <- lookup "r" prs + , cnonce `BS.isPrefixOf` nonce + , Just salt' <- lookup "s" prs + , Right salt <- B64.decode salt' + , Just ic <- lookup "i" prs + , [(i,"")] <- reads $ BS8.unpack ic + = return (nonce, salt, i) fromPairs _ _ = throwError $ AuthOtherFailure -- TODO: Log cFinalMessageAndVerifier :: BS.ByteString @@ -126,7 +114,7 @@ scram hashToken authcid authzid password = do , "r=" +++ nonce] saltedPassword :: BS.ByteString - saltedPassword = hi (Text.encodeUtf8 password) salt ic + saltedPassword = hi (Text.encodeUtf8 pwd) salt ic clientKey :: BS.ByteString clientKey = hmac saltedPassword "Client Key" @@ -154,9 +142,9 @@ scram hashToken authcid authzid password = do -- helper hi :: BS.ByteString -> BS.ByteString -> Integer -> BS.ByteString - hi str salt ic = foldl1' xorBS (genericTake ic us) + hi str slt ic' = foldl1' xorBS (genericTake ic' us) where - u1 = hmac str (salt +++ (BS.pack [0,0,0,1])) + u1 = hmac str (slt +++ (BS.pack [0,0,0,1])) us = iterate (hmac str) u1 scramSha1 :: Text.Text -- ^ username diff --git a/source/Network/Xmpp/Sasl/StringPrep.hs b/source/Network/Xmpp/Sasl/StringPrep.hs index cff48a6..81f5117 100644 --- a/source/Network/Xmpp/Sasl/StringPrep.hs +++ b/source/Network/Xmpp/Sasl/StringPrep.hs @@ -4,27 +4,34 @@ module Network.Xmpp.Sasl.StringPrep where import Text.StringPrep import qualified Data.Set as Set -import Data.Text(singleton) +import Data.Text(Text, singleton) +nonAsciiSpaces :: Set.Set Char nonAsciiSpaces = Set.fromList [ '\x00A0', '\x1680', '\x2000', '\x2001', '\x2002' , '\x2003', '\x2004', '\x2005', '\x2006', '\x2007' , '\x2008', '\x2009', '\x200A', '\x200B', '\x202F' , '\x205F', '\x3000' ] +toSpace :: Char -> Text toSpace x = if x `Set.member` nonAsciiSpaces then " " else singleton x +saslPrepQuery :: StringPrepProfile saslPrepQuery = Profile [b1, toSpace] True [c12, c21, c22, c3, c4, c5, c6, c7, c8, c9] True +saslPrepStore :: StringPrepProfile saslPrepStore = Profile [b1, toSpace] True [a1, c12, c21, c22, c3, c4, c5, c6, c7, c8, c9] True +normalizePassword :: Text -> Maybe Text normalizePassword = runStringPrep saslPrepStore -normalizeUsername = runStringPrep saslPrepQuery \ No newline at end of file + +normalizeUsername :: Text -> Maybe Text +normalizeUsername = runStringPrep saslPrepQuery diff --git a/source/Network/Xmpp/Stanza.hs b/source/Network/Xmpp/Stanza.hs new file mode 100644 index 0000000..ab3c68f --- /dev/null +++ b/source/Network/Xmpp/Stanza.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_HADDOCK hide #-} + +-- | Stanza related functions and constants +-- + +module Network.Xmpp.Stanza where + +import Data.XML.Types +import Network.Xmpp.Types + + +-- | An empty message +message :: Message +message = Message { messageID = Nothing + , messageFrom = Nothing + , messageTo = Nothing + , messageLangTag = Nothing + , messageType = Normal + , messagePayload = [] + } + +-- | An empty presence. +presence :: Presence +presence = Presence { presenceID = Nothing + , presenceFrom = Nothing + , presenceTo = Nothing + , presenceLangTag = Nothing + , presenceType = Nothing + , presencePayload = [] + } + +-- | Request subscription with an entity. +presenceSubscribe :: Jid -> Presence +presenceSubscribe to = presence { presenceTo = Just to + , presenceType = Just Subscribe + } + +-- | Approve a subscripton of an entity. +presenceSubscribed :: Jid -> Presence +presenceSubscribed to = presence { presenceTo = Just to + , presenceType = Just Subscribed + } + +-- | End a subscription with an entity. +presenceUnsubscribe :: Jid -> Presence +presenceUnsubscribe to = presence { presenceTo = Just to + , presenceType = Just Unsubscribed + } + +-- | Signal to the server that the client is available for communication. +presenceOnline :: Presence +presenceOnline = presence + +-- | Signal to the server that the client is no longer available for +-- communication. +presenceOffline :: Presence +presenceOffline = presence {presenceType = Just Unavailable} + +-- | Produce an answer message with the given payload, switching the "from" and +-- "to" attributes in the original message. Produces a 'Nothing' value of the +-- provided message message has no from attribute. +answerMessage :: Message -> [Element] -> Maybe Message +answerMessage Message{messageFrom = Just frm, ..} payload = + Just Message{ messageFrom = messageTo + , messageID = Nothing + , messageTo = Just frm + , messagePayload = payload + , .. + } +answerMessage _ _ = Nothing + +-- | Add a recipient to a presence notification. +presTo :: Presence -> Jid -> Presence +presTo pres to = pres{presenceTo = Just to} diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 86bc227..b760483 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -7,54 +7,46 @@ module Network.Xmpp.Stream where -import Control.Applicative ((<$>), (<*>)) +import Control.Applicative ((<$>)) import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.STM import qualified Control.Exception as Ex -import Control.Exception.Base import qualified Control.Exception.Lifted as ExL import Control.Monad import Control.Monad.Error -import Control.Monad.IO.Class -import Control.Monad.Reader import Control.Monad.State.Strict -import Control.Monad.Trans.Class +import Control.Monad.Trans.Resource as R +import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.ByteString.Base64 -import Data.ByteString.Char8 as BSC8 +import qualified Data.ByteString.Char8 as BSC8 import Data.Conduit import Data.Conduit.Binary as CB import qualified Data.Conduit.Internal as DCI import qualified Data.Conduit.List as CL -import Data.Maybe (fromJust, isJust, isNothing) +import Data.IP +import Data.List +import Data.Maybe +import Data.Ord import Data.Text (Text) import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import Data.Void (Void) import Data.XML.Pickle import Data.XML.Types import qualified GHC.IO.Exception as GIE import Network +import Network.DNS hiding (encode, lookup) import Network.Xmpp.Marshal import Network.Xmpp.Types import System.IO import System.IO.Error (tryIOError) import System.Log.Logger +import System.Random (randomRIO) import Text.XML.Stream.Parse as XP import Text.XML.Unresolved(InvalidEventStream(..)) -import Control.Monad.Trans.Resource as R import Network.Xmpp.Utilities -import Network.DNS hiding (encode, lookup) - -import Data.Ord -import Data.Maybe -import Data.List -import Data.IP -import System.Random - -import qualified Network.Socket as NS - -- "readMaybe" definition, as readMaybe is not introduced in the `base' package -- until version 4.6. readMaybe_ :: (Read a) => String -> Maybe a @@ -72,6 +64,17 @@ lmb :: [t] -> Maybe [t] lmb [] = Nothing lmb x = Just x +pushing :: MonadIO m => + m (Either XmppFailure Bool) + -> ErrorT XmppFailure m () +pushing m = do + res <- ErrorT m + case res of + True -> return () + False -> do + liftIO $ debugM "Pontarius.Xmpp" "Failed to send data." + throwError XmppOtherFailure + -- Unpickles and returns a stream element. streamUnpickleElem :: PU [Node] a -> Element @@ -85,7 +88,7 @@ streamUnpickleElem p x = do -- This is the conduit sink that handles the stream XML events. We extend it -- with ErrorT capabilities. -type StreamSink a = ErrorT XmppFailure (Pipe Event Event Void () IO) a +type StreamSink a = ErrorT XmppFailure (ConduitM Event Void IO) a -- Discards all events before the first EventBeginElement. throwOutJunk :: Monad m => Sink Event m () @@ -114,55 +117,64 @@ openElementFromEvents = do startStream :: StateT StreamState IO (Either XmppFailure ()) startStream = runErrorT $ do lift $ lift $ debugM "Pontarius.Xmpp" "Starting stream..." - state <- lift $ get + st <- lift $ get -- Set the `from' (which is also the expected to) attribute depending on the -- state of the stream. - let expectedTo = case ( streamConnectionState state - , toJid $ streamConfiguration state) of - (Plain, (Just (jid, True))) -> Just jid - (Secured, (Just (jid, _))) -> Just jid - (Plain, Nothing) -> Nothing - (Secured, Nothing) -> Nothing - case streamAddress state of + let expectedTo = case ( streamConnectionState st + , toJid $ streamConfiguration st) of + (Plain , (Just (jid, True))) -> Just jid + (Plain , _ ) -> Nothing + (Secured, (Just (jid, _ ))) -> Just jid + (Secured, Nothing ) -> Nothing + (Closed , _ ) -> Nothing + case streamAddress st of Nothing -> do lift $ lift $ errorM "Pontarius.XMPP" "Server sent no hostname." throwError XmppOtherFailure - Just address -> lift $ do - pushXmlDecl - pushOpenElement $ + Just address -> do + pushing pushXmlDecl + pushing . pushOpenElement . streamNSHack $ pickleElem xpStream ( "1.0" , expectedTo , Just (Jid Nothing address Nothing) , Nothing - , preferredLang $ streamConfiguration state + , preferredLang $ streamConfiguration st ) response <- ErrorT $ runEventsSink $ runErrorT $ streamS expectedTo case response of Left e -> throwError e -- Successful unpickling of stream element. - Right (Right (ver, from, to, id, lt, features)) + Right (Right (ver, from, to, sid, lt, features)) | (Text.unpack ver) /= "1.0" -> closeStreamWithError StreamUnsupportedVersion Nothing "Unknown version" - | lt == Nothing -> - closeStreamWithError StreamInvalidXml Nothing - "Stream has no language tag" - -- If `from' is set, we verify that it's the correct one. TODO: Should we check against the realm instead? - | isJust from && (from /= Just (Jid Nothing (fromJust $ streamAddress state) Nothing)) -> + + -- HACK: We ignore MUST-strength requirement (section 4.7.4. of RFC + -- 6120) for the sake of compatibility with jabber.org + -- | lt == Nothing -> + -- closeStreamWithError StreamInvalidXml Nothing + -- "Stream has no language tag" + + -- If `from' is set, we verify that it's the correct one. TODO: Should we + -- check against the realm instead? + | isJust from && (from /= Just (Jid Nothing (fromJust $ streamAddress st) Nothing)) -> closeStreamWithError StreamInvalidFrom Nothing "Stream from is invalid" | to /= expectedTo -> closeStreamWithError StreamUndefinedCondition (Just $ Element "invalid-to" [] []) "Stream to invalid"-- TODO: Suitable? | otherwise -> do + -- HACK: (ignore section 4.7.4. of RFC 6120), see above + unless (isJust lt) $ liftIO $ warningM "Pontariusm.Xmpp" + "Stream has no language tag" modify (\s -> s{ streamFeatures = features , streamLang = lt - , streamId = id + , streamId = sid , streamFrom = from } ) return () -- Unpickling failed - we investigate the element. - Right (Left (Element name attrs children)) + Right (Left (Element name attrs _children)) | (nameLocalName name /= "stream") -> closeStreamWithError StreamInvalidXml Nothing "Root element is not stream" @@ -174,15 +186,17 @@ startStream = runErrorT $ do "Root name prefix set and not stream" | otherwise -> ErrorT $ checkchildren (flattenAttrs attrs) where - -- closeStreamWithError :: MonadIO m => Stream -> StreamErrorCondition -> - -- Maybe Element -> ErrorT XmppFailure m () + -- HACK: We include the default namespace to make isode's M-LINK server happy. + streamNSHack e = e{elementAttributes = elementAttributes e + ++ [( "xmlns" + , [ContentText "jabber:client"])]} closeStreamWithError :: StreamErrorCondition -> Maybe Element -> String -> ErrorT XmppFailure (StateT StreamState IO) () closeStreamWithError sec el msg = do - lift . pushElement . pickleElem xpStreamError + void . lift . pushElement . pickleElem xpStreamError $ StreamErrorInfo sec Nothing el - lift $ closeStreams' - lift $ lift $ errorM "Pontarius.XMPP" $ "closeStreamWithError: " ++ msg + void . lift $ closeStreams' + liftIO $ errorM "Pontarius.XMPP" $ "closeStreamWithError: " ++ msg throwError XmppOtherFailure checkchildren children = let to' = lookup "to" children @@ -206,12 +220,12 @@ startStream = runErrorT $ do "" safeRead x = case reads $ Text.unpack x of [] -> Nothing - [(y,_),_] -> Just y + ((y,_):_) -> Just y flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)] -flattenAttrs attrs = Prelude.map (\(name, content) -> +flattenAttrs attrs = Prelude.map (\(name, cont) -> ( name - , Text.concat $ Prelude.map uncontentify content) + , Text.concat $ Prelude.map uncontentify cont) ) attrs where @@ -229,11 +243,15 @@ restartStream = do modify (\s -> s{streamEventSource = newSource }) startStream where - loopRead read = do - bs <- liftIO (read 4096) + loopRead rd = do + bs <- liftIO (rd 4096) if BS.null bs then return () - else yield bs >> loopRead read + else do + liftIO $ debugM "Pontarius.Xmpp" $ "in: " ++ + (Text.unpack . Text.decodeUtf8 $ bs) + yield bs + loopRead rd -- Reads the (partial) stream:stream and the server features from the stream. -- Returns the (unvalidated) stream attributes, the unparsed element, or @@ -247,12 +265,12 @@ streamS :: Maybe Jid -> StreamSink (Either Element ( Text , Maybe Text , Maybe LangTag , StreamFeatures )) -streamS expectedTo = do - header <- xmppStreamHeader - case header of - Right (version, from, to, id, langTag) -> do +streamS _expectedTo = do -- TODO: check expectedTo + streamHeader <- xmppStreamHeader + case streamHeader of + Right (version, from, to, sid, lTag) -> do features <- xmppStreamFeatures - return $ Right (version, from, to, id, langTag, features) + return $ Right (version, from, to, sid, lTag, features) Left el -> return $ Left el where xmppStreamHeader :: StreamSink (Either Element (Text, Maybe Jid, Maybe Jid, Maybe Text.Text, Maybe LangTag)) @@ -280,7 +298,7 @@ openStream :: HostName -> StreamConfiguration -> IO (Either XmppFailure (Stream) openStream realm config = runErrorT $ do lift $ debugM "Pontarius.XMPP" "Opening stream..." stream' <- createStream realm config - result <- liftIO $ withStream startStream stream' + ErrorT . liftIO $ withStream startStream stream' return stream' -- | Send "" and wait for the server to finish processing and to @@ -289,14 +307,15 @@ openStream realm config = runErrorT $ do closeStreams :: Stream -> IO (Either XmppFailure [Element]) closeStreams = withStream closeStreams' +closeStreams' :: StateT StreamState IO (Either XmppFailure [Element]) closeStreams' = do lift $ debugM "Pontarius.XMPP" "Closing stream..." send <- gets (streamSend . streamHandle) cc <- gets (streamClose . streamHandle) - liftIO $ send "" + void . liftIO $ send "" void $ liftIO $ forkIO $ do threadDelay 3000000 -- TODO: Configurable value - (Ex.try cc) :: IO (Either Ex.SomeException ()) + void ((Ex.try cc) :: IO (Either Ex.SomeException ())) return () collectElems [] where @@ -311,6 +330,9 @@ closeStreams' = do Right e -> collectElems (e:es) -- TODO: Can the TLS send/recv functions throw something other than an IO error? +debugOut :: MonadIO m => ByteString -> m () +debugOut outData = liftIO $ debugM "Pontarius.Xmpp" + ("Out: " ++ (Text.unpack . Text.decodeUtf8 $ outData)) wrapIOException :: IO a -> StateT StreamState IO (Either XmppFailure a) wrapIOException action = do @@ -324,7 +346,21 @@ wrapIOException action = do pushElement :: Element -> StateT StreamState IO (Either XmppFailure Bool) pushElement x = do send <- gets (streamSend . streamHandle) - wrapIOException $ send $ renderElement x + let outData = renderElement $ nsHack x + debugOut outData + wrapIOException $ send outData + where + -- HACK: We remove the "jabber:client" namespace because it is set as + -- default in the stream. This is to make isode's M-LINK server happy and + -- should be removed once jabber.org accepts prefix-free canonicalization + nsHack e@(Element{elementName = n}) + | nameNamespace n == Just "jabber:client" = + e{ elementName = Name (nameLocalName n) Nothing Nothing + , elementNodes = map mapNSHack $ elementNodes e + } + | otherwise = e + mapNSHack (NodeElement e) = NodeElement $ nsHack e + mapNSHack n = n -- | Encode and send stanza pushStanza :: Stanza -> Stream -> IO (Either XmppFailure Bool) @@ -341,8 +377,10 @@ pushXmlDecl = do pushOpenElement :: Element -> StateT StreamState IO (Either XmppFailure Bool) pushOpenElement e = do - sink <- gets (streamSend . streamHandle) - wrapIOException $ sink $ renderOpenElement e + send <- gets (streamSend . streamHandle) + let outData = renderOpenElement e + debugOut outData + wrapIOException $ send outData -- `Connect-and-resumes' the given sink to the stream source, and pulls a -- `b' value. @@ -378,8 +416,8 @@ pullElement = do -- Pulls an element and unpickles it. pullUnpickle :: PU [Node] a -> StateT StreamState IO (Either XmppFailure a) pullUnpickle p = do - elem <- pullElement - case elem of + el <- pullElement + case el of Left e -> return $ Left e Right elem' -> do let res = unpickleElem p elem' @@ -433,7 +471,7 @@ xmppNoStream = StreamState { where zeroSource :: Source IO output zeroSource = liftIO $ do - errorM "Pontarius.XMPP" "zeroSource utilized." + errorM "Pontarius.Xmpp" "zeroSource utilized." ExL.throwIO XmppOtherFailure createStream :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Stream) @@ -472,7 +510,7 @@ createStream realm config = do where logConduit :: Conduit ByteString IO ByteString logConduit = CL.mapM $ \d -> do - debugM "Pontarius.Xmpp" $ "Received TCP data: " ++ (BSC8.unpack d) ++ + debugM "Pontarius.Xmpp" $ "In: " ++ (BSC8.unpack d) ++ "." return d @@ -483,79 +521,78 @@ createStream realm config = do -- attempt has been made. Will return the Handle acquired, if any. connect :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO (Maybe Handle) connect realm config = do - case socketDetails config of - -- Just (_, NS.SockAddrUnix _) -> do - -- lift $ errorM "Pontarius.Xmpp" "SockAddrUnix address provided." - -- throwError XmppIllegalTcpDetails - Just socketDetails' -> lift $ do - debugM "Pontarius.Xmpp" "Connecting to configured SockAddr address..." - connectTcp $ Left socketDetails' - Nothing -> do - case (readMaybe_ realm :: Maybe IPv6, readMaybe_ realm :: Maybe IPv4, hostname (Text.pack realm) :: Maybe Hostname) of - (Just ipv6, Nothing, _) -> lift $ connectTcp $ Right [(show ipv6, 5222)] - (Nothing, Just ipv4, _) -> lift $ connectTcp $ Right [(show ipv4, 5222)] - (Nothing, Nothing, Just (Hostname realm')) -> do - resolvSeed <- lift $ makeResolvSeed (resolvConf config) - lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..." - srvRecords <- srvLookup realm' resolvSeed - case srvRecords of - -- No SRV records. Try fallback lookup. - Nothing -> do - lift $ debugM "Pontarius.Xmpp" "No SRV records, using fallback process..." - lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ realm) 5222 - Just srvRecords' -> do - lift $ debugM "Pontarius.Xmpp" "SRV records found, performing A/AAAA lookups..." - lift $ resolvSrvsAndConnectTcp resolvSeed srvRecords' - (Nothing, Nothing, Nothing) -> do - lift $ errorM "Pontarius.Xmpp" "The hostname could not be validated." + case connectionDetails config of + UseHost host port -> lift $ do + debugM "Pontarius.Xmpp" "Connecting to configured address." + connectTcp $ [(host, port)] + UseSrv host -> connectSrv host + UseRealm -> connectSrv realm + where + connectSrv host = do + case checkHostName (Text.pack host) of + Just host' -> do + resolvSeed <- lift $ makeResolvSeed (resolvConf config) + lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..." + srvRecords <- srvLookup host' resolvSeed + case srvRecords of + Nothing -> do + lift $ debugM "Pontarius.Xmpp" + "No SRV records, using fallback process." + lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ host) + 5222 + Just srvRecords' -> do + lift $ debugM "Pontarius.Xmpp" + "SRV records found, performing A/AAAA lookups." + lift $ resolvSrvsAndConnectTcp resolvSeed srvRecords' + Nothing -> do + lift $ errorM "Pontarius.Xmpp" + "The hostname could not be validated." throwError XmppIllegalTcpDetails -- Connects to a list of addresses and ports. Surpresses any exceptions from -- connectTcp. -connectTcp :: Either (NS.Socket, NS.SockAddr) [(HostName, Int)] -> IO (Maybe Handle) -connectTcp (Right []) = return Nothing -connectTcp (Right ((address, port):remainder)) = do - result <- try $ (do - debugM "Pontarius.Xmpp" $ "Connecting to " ++ (address) ++ " on port " ++ +connectTcp :: [(HostName, PortID)] -> IO (Maybe Handle) +connectTcp [] = return Nothing +connectTcp ((address, port):remainder) = do + result <- Ex.try $ (do + debugM "Pontarius.Xmpp" $ "Connecting to " ++ address ++ " on port " ++ (show port) ++ "." - connectTo address (PortNumber $ fromIntegral port)) :: IO (Either IOException Handle) + connectTo address port) :: IO (Either Ex.IOException Handle) case result of Right handle -> do debugM "Pontarius.Xmpp" "Successfully connected to HostName." return $ Just handle Left _ -> do debugM "Pontarius.Xmpp" "Connection to HostName could not be established." - connectTcp $ Right remainder -connectTcp (Left (sock, sockAddr)) = do - result <- try $ (do - NS.connect sock sockAddr - NS.socketToHandle sock ReadWriteMode) :: IO (Either IOException Handle) - case result of - Right handle -> do - debugM "Pontarius.Xmpp" "Successfully connected to SockAddr." - return $ Just handle - Left _ -> do - debugM "Pontarius.Xmpp" "Connection to SockAddr could not be established." - return Nothing + connectTcp remainder -- Makes an AAAA query to acquire a IPs, and tries to connect to all of them. If -- a handle can not be acquired this way, an analogous A query is performed. -- Surpresses all IO exceptions. resolvAndConnectTcp :: ResolvSeed -> Domain -> Int -> IO (Maybe Handle) resolvAndConnectTcp resolvSeed domain port = do - aaaaResults <- (try $ rethrowErrorCall $ withResolver resolvSeed $ - \resolver -> lookupAAAA resolver domain) :: IO (Either IOException (Maybe [IPv6])) + aaaaResults <- (Ex.try $ rethrowErrorCall $ withResolver resolvSeed $ + \resolver -> lookupAAAA resolver domain) :: IO (Either Ex.IOException (Maybe [IPv6])) handle <- case aaaaResults of Right Nothing -> return Nothing - Right (Just ipv6s) -> connectTcp $ Right $ Data.List.map (\ipv6 -> (show ipv6, port)) ipv6s - Left e -> return Nothing + Right (Just ipv6s) -> connectTcp $ + map (\ip -> ( show ip + , PortNumber $ fromIntegral port)) + ipv6s + Left _e -> return Nothing case handle of Nothing -> do - aResults <- (try $ rethrowErrorCall $ withResolver resolvSeed $ - \resolver -> lookupA resolver domain) :: IO (Either IOException (Maybe [IPv4])) + aResults <- (Ex.try $ rethrowErrorCall $ withResolver resolvSeed $ + \resolver -> lookupA resolver domain) :: IO (Either Ex.IOException (Maybe [IPv4])) handle' <- case aResults of + Left _ -> return Nothing Right Nothing -> return Nothing - Right (Just ipv4s) -> connectTcp $ Right $ Data.List.map (\ipv4 -> (show ipv4, port)) ipv4s + + Right (Just ipv4s) -> connectTcp $ + map (\ip -> (show ip + , PortNumber + $ fromIntegral port)) + ipv4s case handle' of Nothing -> return Nothing Just handle'' -> return $ Just handle'' @@ -576,29 +613,30 @@ resolvSrvsAndConnectTcp resolvSeed ((domain, port):remaining) = do -- exceptions and rethrows them as IOExceptions. rethrowErrorCall :: IO a -> IO a rethrowErrorCall action = do - result <- try action + result <- Ex.try action case result of Right result' -> return result' - Left (ErrorCall e) -> ioError $ userError $ "rethrowErrorCall: " ++ e - Left e -> throwIO e + Left (Ex.ErrorCall e) -> Ex.ioError $ userError + $ "rethrowErrorCall: " ++ e -- Provides a list of A(AAA) names and port numbers upon a successful -- DNS-SRV request, or `Nothing' if the DNS-SRV request failed. srvLookup :: Text -> ResolvSeed -> ErrorT XmppFailure IO (Maybe [(Domain, Int)]) srvLookup realm resolvSeed = ErrorT $ do - result <- try $ rethrowErrorCall $ withResolver resolvSeed $ \resolver -> do + result <- Ex.try $ rethrowErrorCall $ withResolver resolvSeed + $ \resolver -> do srvResult <- lookupSRV resolver $ BSC8.pack $ "_xmpp-client._tcp." ++ (Text.unpack realm) ++ "." case srvResult of - Just srvResult -> do - debugM "Pontarius.Xmpp" $ "SRV result: " ++ (show srvResult) - -- Get [(Domain, PortNumber)] of SRV request, if any. - srvResult' <- orderSrvResult srvResult - return $ Just $ Prelude.map (\(_, _, port, domain) -> (domain, port)) srvResult' - -- The service is not available at this domain. - -- Sorts the records based on the priority value. Just [(_, _, _, ".")] -> do debugM "Pontarius.Xmpp" $ "\".\" SRV result returned." return $ Just [] + Just srvResult' -> do + debugM "Pontarius.Xmpp" $ "SRV result: " ++ (show srvResult') + -- Get [(Domain, PortNumber)] of SRV request, if any. + orderedSrvResult <- orderSrvResult srvResult' + return $ Just $ Prelude.map (\(_, _, port, domain) -> (domain, port)) orderedSrvResult + -- The service is not available at this domain. + -- Sorts the records based on the priority value. Nothing -> do debugM "Pontarius.Xmpp" "No SRV result returned." return Nothing @@ -629,7 +667,7 @@ srvLookup realm resolvSeed = ErrorT $ do orderSublist sublist = do -- Compute the running sum, as well as the total sum of -- the sublist. Add the running sum to the SRV tuples. - let (total, sublist') = Data.List.mapAccumL (\total (priority, weight, port, domain) -> (total + weight, (priority, weight, port, domain, total + weight))) 0 sublist + let (total, sublist') = Data.List.mapAccumL (\total' (priority, weight, port, domain) -> (total' + weight, (priority, weight, port, domain, total' + weight))) 0 sublist -- Choose a random number between 0 and the total sum -- (inclusive). randomNumber <- randomRIO (0, total) @@ -638,11 +676,11 @@ srvLookup realm resolvSeed = ErrorT $ do let (beginning, ((priority, weight, port, domain, _):end)) = Data.List.break (\(_, _, _, _, running) -> randomNumber <= running) sublist' -- Remove the running total number from the remaining -- elements. - let sublist'' = Data.List.map (\(priority, weight, port, domain, _) -> (priority, weight, port, domain)) (Data.List.concat [beginning, end]) + let sublist'' = Data.List.map (\(priority', weight', port', domain', _) -> (priority', weight', port', domain')) (Data.List.concat [beginning, end]) -- Repeat the ordering procedure on the remaining -- elements. - tail <- orderSublist sublist'' - return $ ((priority, weight, port, domain):tail) + rest <- orderSublist sublist'' + return $ ((priority, weight, port, domain):rest) -- Closes the connection and updates the XmppConMonad Stream state. -- killStream :: Stream -> IO (Either ExL.SomeException ()) @@ -663,25 +701,26 @@ pushIQ :: StanzaID -> Element -> Stream -> IO (Either XmppFailure (Either IQError IQResult)) -pushIQ iqID to tp lang body stream = do - pushStanza (IQRequestS $ IQRequest iqID Nothing to lang tp body) stream - res <- pullStanza stream +pushIQ iqID to tp lang body stream = runErrorT $ do + pushing $ pushStanza + (IQRequestS $ IQRequest iqID Nothing to lang tp body) stream + res <- lift $ pullStanza stream case res of - Left e -> return $ Left e - Right (IQErrorS e) -> return $ Right $ Left e + Left e -> throwError e + Right (IQErrorS e) -> return $ Left e Right (IQResultS r) -> do unless (iqID == iqResultID r) $ liftIO $ do - errorM "Pontarius.XMPP" $ "pushIQ: ID mismatch (" ++ (show iqID) ++ " /= " ++ (show $ iqResultID r) ++ ")." - ExL.throwIO XmppOtherFailure + liftIO $ errorM "Pontarius.XMPP" $ "pushIQ: ID mismatch (" ++ (show iqID) ++ " /= " ++ (show $ iqResultID r) ++ ")." + liftIO $ ExL.throwIO XmppOtherFailure -- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++ -- " /= " ++ show (iqResultID r) ++ " .") - return $ Right $ Right r + return $ Right r _ -> do - errorM "Pontarius.XMPP" $ "pushIQ: Unexpected stanza type." - return . Left $ XmppOtherFailure + liftIO $ errorM "Pontarius.XMPP" $ "pushIQ: Unexpected stanza type." + throwError XmppOtherFailure -debugConduit :: Pipe l ByteString ByteString u IO b +debugConduit :: (Show o, MonadIO m) => ConduitM o o m b debugConduit = forever $ do s' <- await case s' of @@ -697,7 +736,9 @@ elements = do Just (EventBeginElement n as) -> do goE n as >>= yield elements - Just (EventEndElement streamName) -> lift $ R.monadThrow StreamEnd + -- This might be an XML error if the end element tag is not + -- "". TODO: We might want to check this at a later time + Just (EventEndElement _) -> lift $ R.monadThrow StreamEnd Nothing -> return () _ -> lift $ R.monadThrow $ InvalidXmppXml $ "not an element: " ++ show x where @@ -707,8 +748,8 @@ elements = do go front = do x <- f case x of - Left x -> return $ (x, front []) - Right y -> go (front . (:) y) + Left l -> return $ (l, front []) + Right r -> go (front . (:) r) goE n as = do (y, ns) <- many' goN if y == Just (EventEndElement n) @@ -732,11 +773,8 @@ elements = do compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z compressNodes (x:xs) = x : compressNodes xs - streamName :: Name - streamName = (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) - -withStream :: StateT StreamState IO (Either XmppFailure c) -> Stream -> IO (Either XmppFailure c) -withStream action (Stream stream) = bracketOnError +withStream :: StateT StreamState IO a -> Stream -> IO a +withStream action (Stream stream) = Ex.bracketOnError (atomically $ takeTMVar stream ) (atomically . putTMVar stream) (\s -> do @@ -746,7 +784,7 @@ withStream action (Stream stream) = bracketOnError ) -- nonblocking version. Changes to the connection are ignored! -withStream' :: StateT StreamState IO (Either XmppFailure b) -> Stream -> IO (Either XmppFailure b) +withStream' :: StateT StreamState IO a -> Stream -> IO a withStream' action (Stream stream) = do stream_ <- atomically $ readTMVar stream (r, _) <- runStateT action stream_ diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs index 71e9b8d..f9f1745 100644 --- a/source/Network/Xmpp/Tls.hs +++ b/source/Network/Xmpp/Tls.hs @@ -4,7 +4,6 @@ module Network.Xmpp.Tls where -import Control.Concurrent.STM.TMVar import qualified Control.Exception.Lifted as Ex import Control.Monad import Control.Monad.Error @@ -14,21 +13,30 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC8 import qualified Data.ByteString.Lazy as BL import Data.Conduit -import qualified Data.Conduit.Binary as CB import Data.IORef -import Data.Typeable import Data.XML.Types import Network.TLS -import Network.TLS.Extra import Network.Xmpp.Stream import Network.Xmpp.Types -import System.Log.Logger (debugM, errorM) +import System.Log.Logger (debugM, errorM, infoM) +mkBackend :: StreamHandle -> Backend mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs) - , backendRecv = streamReceive con + , backendRecv = bufferReceive (streamReceive con) , backendFlush = streamFlush con , backendClose = streamClose con } + where + bufferReceive _ 0 = return BS.empty + bufferReceive recv n = BS.concat `liftM` (go n) + where + go m = do + bs <- recv m + case BS.length bs of + 0 -> return [] + l -> if l < m + then (bs :) `liftM` go (m - l) + else return [bs] starttlsE :: Element starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] @@ -43,49 +51,60 @@ tls con = Ex.handle (return . Left . TlsError) case sState of Plain -> return () Closed -> do - liftIO $ errorM "Pontarius.XMPP" "startTls: The stream is closed." + liftIO $ errorM "Pontarius.Xmpp" "startTls: The stream is closed." throwError XmppNoStream Secured -> do - liftIO $ errorM "Pontarius.XMPP" "startTls: The stream is already secured." + liftIO $ errorM "Pontarius.Xmpp" "startTls: The stream is already secured." throwError TlsStreamSecured features <- lift $ gets streamFeatures case (tlsBehaviour conf, streamTls features) of (RequireTls , Just _ ) -> startTls (RequireTls , Nothing ) -> throwError TlsNoServerSupport (PreferTls , Just _ ) -> startTls - (PreferTls , Nothing ) -> return () + (PreferTls , Nothing ) -> skipTls (PreferPlain , Just True) -> startTls - (PreferPlain , _ ) -> return () + (PreferPlain , _ ) -> skipTls (RefuseTls , Just True) -> throwError XmppOtherFailure - (RefuseTls , _ ) -> return () + (RefuseTls , _ ) -> skipTls where + skipTls = liftIO $ infoM "Pontarius.Xmpp" "Skipping TLS negotiation" startTls = do + liftIO $ infoM "Pontarius.Xmpp" "Running StartTLS" params <- gets $ tlsParams . streamConfiguration - lift $ pushElement starttlsE + sent <- ErrorT $ pushElement starttlsE + unless sent $ do + liftIO $ errorM "Pontarius.Xmpp" "startTls: Could not sent stanza." + throwError XmppOtherFailure answer <- lift $ pullElement case answer of - Left e -> return $ Left e + Left e -> throwError e Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] []) -> - return $ Right () + return () Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _) -> do - liftIO $ errorM "Pontarius.XMPP" "startTls: TLS initiation failed." - return . Left $ XmppOtherFailure + liftIO $ errorM "Pontarius.Xmpp" "startTls: TLS initiation failed." + throwError XmppOtherFailure + Right r -> + liftIO $ errorM "Pontarius.Xmpp" $ + "startTls: Unexpected element: " ++ show r hand <- gets streamHandle - (raw, _snk, psh, read, ctx) <- lift $ tlsinit params (mkBackend hand) + (_raw, _snk, psh, recv, ctx) <- lift $ tlsinit params (mkBackend hand) let newHand = StreamHandle { streamSend = catchPush . psh - , streamReceive = read - , streamFlush = contextFlush ctx - , streamClose = bye ctx >> streamClose hand - } + , streamReceive = recv + , streamFlush = contextFlush ctx + , streamClose = bye ctx >> streamClose hand + } lift $ modify ( \x -> x {streamHandle = newHand}) + liftIO $ infoM "Pontarius.Xmpp" "Stream Secured." either (lift . Ex.throwIO) return =<< lift restartStream modify (\s -> s{streamConnectionState = Secured}) return () +client :: (MonadIO m, CPRG rng) => Params -> rng -> Backend -> m Context client params gen backend = do contextNew backend params gen -defaultParams = defaultParamsClient +xmppDefaultParams :: Params +xmppDefaultParams = defaultParamsClient tlsinit :: (MonadIO m, MonadIO m1) => TLSParams @@ -96,10 +115,10 @@ tlsinit :: (MonadIO m, MonadIO m1) => , Int -> m1 BS.ByteString , Context ) -tlsinit tlsParams backend = do +tlsinit params backend = do liftIO $ debugM "Pontarius.Xmpp.TLS" "TLS with debug mode enabled." gen <- liftIO $ getSystemRandomGen -- TODO: Find better random source? - con <- client tlsParams gen backend + con <- client params gen backend handshake con let src = forever $ do dt <- liftIO $ recvData con @@ -111,25 +130,21 @@ tlsinit tlsParams backend = do Nothing -> return () Just x -> do sendData con (BL.fromChunks [x]) - liftIO $ debugM "Pontarius.Xmpp.TLS" - ("out :" ++ BSC8.unpack x) snk - read <- liftIO $ mkReadBuffer (recvData con) + readWithBuffer <- liftIO $ mkReadBuffer (recvData con) return ( src , snk - , \s -> do - liftIO $ debugM "Pontarius.Xmpp.TLS" ("out :" ++ BSC8.unpack s) - sendData con $ BL.fromChunks [s] - , liftIO . read + , \s -> sendData con $ BL.fromChunks [s] + , liftIO . readWithBuffer , con ) mkReadBuffer :: IO BS.ByteString -> IO (Int -> IO BS.ByteString) -mkReadBuffer read = do +mkReadBuffer recv = do buffer <- newIORef BS.empty let read' n = do nc <- readIORef buffer - bs <- if BS.null nc then read + bs <- if BS.null nc then recv else return nc let (result, rest) = BS.splitAt n bs writeIORef buffer rest diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 5ad805d..6720061 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -37,6 +37,7 @@ module Network.Xmpp.Types , ConnectionState(..) , StreamErrorInfo(..) , StanzaHandler + , ConnectionDetails(..) , StreamConfiguration(..) , langTag , Jid(..) @@ -46,8 +47,6 @@ module Network.Xmpp.Types , jidFromTexts , StreamEnd(..) , InvalidXmppXml(..) - , Hostname(..) - , hostname , SessionConfiguration(..) , TlsBehaviour(..) ) @@ -70,7 +69,6 @@ import Data.Typeable(Typeable) import Data.XML.Types import Network import Network.DNS -import Network.Socket import Network.TLS hiding (Version) import Network.TLS.Extra import qualified Text.NamePrep as SP @@ -1012,6 +1010,10 @@ data InvalidXmppXml = InvalidXmppXml String deriving (Show, Typeable) instance Exception InvalidXmppXml +data ConnectionDetails = UseRealm -- ^ Use realm to resolv host + | UseSrv HostName -- ^ Use this hostname for a SRC lookup + | UseHost HostName PortID -- ^ Use specified host + -- | Configuration settings related to the stream. data StreamConfiguration = StreamConfiguration { -- | Default language when no language tag is set @@ -1026,7 +1028,7 @@ data StreamConfiguration = -- of the realm, as well as specify the use of a -- non-standard port when connecting by IP or -- connecting to a domain without SRV records. - , socketDetails :: Maybe (Socket, SockAddr) + , connectionDetails :: ConnectionDetails -- | DNS resolver configuration , resolvConf :: ResolvConf -- | Whether or not to perform the legacy @@ -1039,56 +1041,19 @@ data StreamConfiguration = , tlsParams :: TLSParams } - instance Default StreamConfiguration where def = StreamConfiguration { preferredLang = Nothing , toJid = Nothing - , socketDetails = Nothing + , connectionDetails = UseRealm , resolvConf = defaultResolvConf , establishSession = True , tlsBehaviour = PreferTls - , tlsParams = defaultParamsClient { pConnectVersion = TLS12 - , pAllowedVersions = [TLS12] + , tlsParams = defaultParamsClient { pConnectVersion = TLS10 + , pAllowedVersions = [TLS10, TLS11, TLS12] , pCiphers = ciphersuite_strong } } -data Hostname = Hostname Text deriving (Eq, Show) - -instance Read Hostname where - readsPrec _ x = case hostname (Text.pack x) of - Nothing -> [] - Just h -> [(h,"")] - -instance IsString Hostname where - fromString = fromJust . hostname . Text.pack - --- | Validates the hostname string in accordance with RFC 1123. -hostname :: Text -> Maybe Hostname -hostname t = do - eitherToMaybeHostname $ AP.parseOnly hostnameP t - where - eitherToMaybeHostname = either (const Nothing) (Just . Hostname) - --- Validation of RFC 1123 hostnames. -hostnameP :: AP.Parser Text -hostnameP = do - -- Hostnames may not begin with a hyphen. - h <- AP.satisfy $ AP.inClass $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] - t <- AP.takeWhile $ AP.inClass $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ ['-'] - let label = Text.concat [Text.pack [h], t] - if Text.length label > 63 - then fail "Label too long." - else do - AP.endOfInput - return label - <|> do - _ <- AP.satisfy (== '.') - r <- hostnameP - if (Text.length label) + 1 + (Text.length r) > 255 - then fail "Hostname too long." - else return $ Text.concat [label, Text.pack ".", r] - type StanzaHandler = TChan Stanza -- ^ outgoing stanza -> Stanza -- ^ stanza to handle -> IO Bool -- ^ True when processing should continue @@ -1098,10 +1063,11 @@ data SessionConfiguration = SessionConfiguration { -- | Configuration for the @Stream@ object. sessionStreamConfiguration :: StreamConfiguration -- | Handler to be run when the session ends (for whatever reason). - , sessionClosedHandler :: XmppFailure -> IO () + , sessionClosedHandler :: XmppFailure -> IO () -- | Function to generate the stream of stanza identifiers. - , sessionStanzaIDs :: IO (IO StanzaID) - , extraStanzaHandlers :: [StanzaHandler] + , sessionStanzaIDs :: IO (IO StanzaID) + , extraStanzaHandlers :: [StanzaHandler] + , enableRoster :: Bool } instance Default SessionConfiguration where @@ -1114,6 +1080,7 @@ instance Default SessionConfiguration where writeTVar idRef (curId + 1 :: Integer) return . StanzaID . Text.pack . show $ curId , extraStanzaHandlers = [] + , enableRoster = True } -- | How the client should behave in regards to TLS. diff --git a/source/Network/Xmpp/Utilities.hs b/source/Network/Xmpp/Utilities.hs index 419bd6b..6d4cee3 100644 --- a/source/Network/Xmpp/Utilities.hs +++ b/source/Network/Xmpp/Utilities.hs @@ -1,105 +1,30 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_HADDOCK hide #-} -module Network.Xmpp.Utilities (presTo, message, answerMessage, openElementToEvents, renderOpenElement, renderElement) where -import Network.Xmpp.Types - -import Control.Monad.STM -import Control.Concurrent.STM.TVar -import Prelude - -import Data.XML.Types +module Network.Xmpp.Utilities + ( openElementToEvents + , renderOpenElement + , renderElement + , checkHostName + ) + where +import Control.Applicative ((<|>)) import qualified Data.Attoparsec.Text as AP -import qualified Data.Text as Text - import qualified Data.ByteString as BS +import Data.Conduit as C +import Data.Conduit.List as CL import qualified Data.Text as Text +import Data.Text(Text) import qualified Data.Text.Encoding as Text -import System.IO.Unsafe(unsafePerformIO) -import Data.Conduit.List as CL --- import Data.Typeable -import Control.Applicative ((<$>)) -import Control.Exception -import Control.Monad.Trans.Class - -import Data.Conduit as C import Data.XML.Types - +import Prelude +import System.IO.Unsafe(unsafePerformIO) import qualified Text.XML.Stream.Render as TXSR import Text.XML.Unresolved as TXU - --- TODO: Not used, and should probably be removed. --- | Creates a new @IdGenerator@. Internally, it will maintain an infinite list --- of IDs ('[\'a\', \'b\', \'c\'...]'). The argument is a prefix to prepend the --- IDs with. Calling the function will extract an ID and update the generator's --- internal state so that the same ID will not be generated again. -idGenerator :: Text.Text -> IO IdGenerator -idGenerator prefix = atomically $ do - tvar <- newTVar $ ids prefix - return $ IdGenerator $ next tvar - where - -- Transactionally extract the next ID from the infinite list of IDs. - next :: TVar [Text.Text] -> IO Text.Text - next tvar = atomically $ do - list <- readTVar tvar - case list of - [] -> error "empty list in Utilities.hs" - (x:xs) -> do - writeTVar tvar xs - return x - - -- Generates an infinite and predictable list of IDs, all beginning with the - -- provided prefix. Adds the prefix to all combinations of IDs (ids'). - ids :: Text.Text -> [Text.Text] - ids p = Prelude.map (\ id -> Text.append p id) ids' - where - -- Generate all combinations of IDs, with increasing length. - ids' :: [Text.Text] - ids' = Prelude.map Text.pack $ Prelude.concatMap ids'' [1..] - -- Generates all combinations of IDs with the given length. - ids'' :: Integer -> [String] - ids'' 0 = [""] - ids'' l = [x:xs | x <- repertoire, xs <- ids'' (l - 1)] - -- Characters allowed in IDs. - repertoire :: String - repertoire = ['a'..'z'] - --- Constructs a "Version" based on the major and minor version numbers. -versionFromNumbers :: Integer -> Integer -> Version -versionFromNumbers major minor = Version major minor - --- | Add a recipient to a presence notification. -presTo :: Presence -> Jid -> Presence -presTo pres to = pres{presenceTo = Just to} - --- | An empty message. -message :: Message -message = Message { messageID = Nothing - , messageFrom = Nothing - , messageTo = Nothing - , messageLangTag = Nothing - , messageType = Normal - , messagePayload = [] - } - --- | Produce an answer message with the given payload, switching the "from" and --- "to" attributes in the original message. Produces a 'Nothing' value of the --- provided message message has no from attribute. -answerMessage :: Message -> [Element] -> Maybe Message -answerMessage Message{messageFrom = Just frm, ..} payload = - Just Message{ messageFrom = messageTo - , messageID = Nothing - , messageTo = Just frm - , messagePayload = payload - , .. - } -answerMessage _ _ = Nothing - openElementToEvents :: Element -> [Event] openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns [] where @@ -124,4 +49,31 @@ renderElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO $ CL.sourceList (elementToEvents e) $$ TXSR.renderText def =$ CL.consume where elementToEvents :: Element -> [Event] - elementToEvents e@(Element name _ _) = openElementToEvents e ++ [EventEndElement name] + elementToEvents el@(Element name _ _) = openElementToEvents el + ++ [EventEndElement name] + +-- | Validates the hostname string in accordance with RFC 1123. +checkHostName :: Text -> Maybe Text +checkHostName t = + eitherToMaybeHostName $ AP.parseOnly hostnameP t + where + eitherToMaybeHostName = either (const Nothing) Just + +-- Validation of RFC 1123 hostnames. +hostnameP :: AP.Parser Text +hostnameP = do + -- Hostnames may not begin with a hyphen. + h <- AP.satisfy $ AP.inClass $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] + t <- AP.takeWhile $ AP.inClass $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ ['-'] + let label = Text.concat [Text.pack [h], t] + if Text.length label > 63 + then fail "Label too long." + else do + AP.endOfInput + return label + <|> do + _ <- AP.satisfy (== '.') + r <- hostnameP + if Text.length label + 1 + Text.length r > 255 + then fail "Hostname too long." + else return $ Text.concat [label, Text.pack ".", r] diff --git a/source/Network/Xmpp/Xep/DataForms.hs b/source/Network/Xmpp/Xep/DataForms.hs index 9491acd..2c2b733 100644 --- a/source/Network/Xmpp/Xep/DataForms.hs +++ b/source/Network/Xmpp/Xep/DataForms.hs @@ -7,12 +7,9 @@ module Network.Xmpp.Xep.DataForms where import qualified Data.Text as Text +import Data.XML.Pickle import qualified Data.XML.Types as XML -import Data.XML.Pickle -import qualified Data.Text as Text - -import qualified Text.XML.Stream.Parse as Parse dataFormNs :: Text.Text dataFormNs = "jabber:x:data" @@ -95,12 +92,12 @@ instance Read FieldType where xpForm :: PU [XML.Node] Form -xpForm = xpWrap (\(tp , (title, instructions, fields, reported, items)) -> - Form tp title (map snd instructions) fields reported (map snd items)) - (\(Form tp title instructions fields reported items) -> +xpForm = xpWrap (\(tp , (ttl, ins, flds, rpd, its)) -> + Form tp ttl (map snd ins) flds rpd (map snd its)) + (\(Form tp ttl ins flds rpd its) -> (tp , - (title, map ((),) instructions - , fields, reported, map ((),) items))) + (ttl, map ((),) ins + , flds, rpd, map ((),) its))) $ xpElem (dataFormName "x") @@ -113,10 +110,10 @@ xpForm = xpWrap (\(tp , (title, instructions, fields, reported, items)) -> (xpElems (dataFormName "item") xpUnit xpFields)) xpFields :: PU [XML.Node] [Field] -xpFields = xpWrap (map $ \((var, tp, label),(desc, req, vals, opts)) - -> Field var label tp desc req vals opts) - (map $ \(Field var label tp desc req vals opts) - -> ((var, tp, label),(desc, req, vals, opts))) $ +xpFields = xpWrap (map $ \((var, tp, lbl),(desc, req, vals, opts)) + -> Field var lbl tp desc req vals opts) + (map $ \(Field var lbl tp desc req vals opts) + -> ((var, tp, lbl),(desc, req, vals, opts))) $ xpElems (dataFormName "field") (xp3Tuple (xpAttrImplied "var" xpId )