diff --git a/.gitignore b/.gitignore index d7ddec5..f684ca1 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,6 @@ dist/ cabal-dev/ +wiki/ *.o *.hi *~ diff --git a/pontarius.cabal b/pontarius.cabal index 5240d2f..ff0b9a8 100644 --- a/pontarius.cabal +++ b/pontarius.cabal @@ -12,7 +12,7 @@ Stability: alpha Bug-Reports: mailto:jon.kristensen@nejla.com -- Package-URL: Synopsis: An incomplete implementation of RFC 6120 (XMPP: Core) -Description: Pontarius is a work in progress of an implementation of +Description: Pontarius is a work in progress implementation of RFC 6120 (XMPP: Core). Category: Network Tested-With: GHC == 7.4.1 @@ -51,17 +51,25 @@ Library , data-default -any , stringprep >= 0.1.5 Exposed-modules: Network.XMPP - , Network.XMPP.Types - , Network.XMPP.SASL - , Network.XMPP.Stream - , Network.XMPP.Pickle + , Network.XMPP.Bind + , Network.XMPP.Concurrent , Network.XMPP.Marshal , Network.XMPP.Monad - , Network.XMPP.Concurrent - , Network.XMPP.TLS - , Network.XMPP.Bind + , Network.XMPP.Message + , Network.XMPP.Pickle + , Network.XMPP.Presence + , Network.XMPP.SASL , Network.XMPP.Session + , Network.XMPP.Stream + , Network.XMPP.TLS + , Network.XMPP.Types + Other-modules: Network.XMPP.JID + , Network.XMPP.Concurrent.Types + , Network.XMPP.Concurrent.IQ + , Network.XMPP.Concurrent.Threads + , Network.XMPP.Concurrent.Monad , Text.XML.Stream.Elements + , Data.Conduit.BufferedSource , Data.Conduit.TLS GHC-Options: -Wall diff --git a/src/Data/Conduit/BufferedSource.hs b/src/Data/Conduit/BufferedSource.hs new file mode 100644 index 0000000..c755509 --- /dev/null +++ b/src/Data/Conduit/BufferedSource.hs @@ -0,0 +1,20 @@ +module Data.Conduit.BufferedSource where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.IORef +import Data.Conduit +import qualified Data.Conduit.List as CL + +-- | Buffered source from conduit 0.3 +bufferSource :: MonadIO m => Source m o -> IO (Source m o) +bufferSource s = do + srcRef <- newIORef s + return $ do + src <- liftIO $ readIORef srcRef + let go src = do + (src', res) <- lift $ src $$+ CL.head + case res of + Nothing -> return () + Just x -> liftIO (writeIORef srcRef src') >> yield x >> go src' + in go src diff --git a/src/Data/Conduit/TLS.hs b/src/Data/Conduit/TLS.hs index 4a7d4f0..4673353 100644 --- a/src/Data/Conduit/TLS.hs +++ b/src/Data/Conduit/TLS.hs @@ -1,4 +1,5 @@ {-# Language NoMonomorphismRestriction #-} +{-# OPTIONS_HADDOCK hide #-} module Data.Conduit.TLS ( tlsinit -- , conduitStdout @@ -26,7 +27,9 @@ tlsinit TLSParams -> Handle -> m ( Source m1 BS.ByteString , Sink BS.ByteString m1 () - , BS.ByteString -> IO ()) + , BS.ByteString -> IO () + , TLSCtx Handle + ) tlsinit tlsParams handle = do gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source? clientContext <- client tlsParams gen handle @@ -41,5 +44,7 @@ tlsinit tlsParams handle = do (\_ -> return ()) return ( src , snk - , \s -> sendData clientContext $ BL.fromChunks [s] ) + , \s -> sendData clientContext $ BL.fromChunks [s] + , clientContext + ) diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index 8c531e3..ecc7e5e 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -13,9 +13,12 @@ -- Stability: unstable -- Portability: portable -- --- XMPP is an open standard, extendable, and secure communications --- protocol designed on top of XML, TLS, and SASL. Pontarius XMPP is --- an XMPP client library, implementing the core capabilities of XMPP +-- The Extensible Messaging and Presence Protocol (XMPP) is an open technology for +-- real-time communication, which powers a wide range of applications including +-- instant messaging, presence, multi-party chat, voice and video calls, +-- collaboration, lightweight middleware, content syndication, and generalized +-- routing of XML data. +-- Pontarius an XMPP client library, implementing the core capabilities of XMPP -- (RFC 6120). -- -- Developers using this library are assumed to understand how XMPP @@ -30,36 +33,147 @@ {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} module Network.XMPP - ( module Network.XMPP.Bind - , module Network.XMPP.Concurrent - , module Network.XMPP.Monad - , module Network.XMPP.SASL - , module Network.XMPP.Session - , module Network.XMPP.Stream - , module Network.XMPP.TLS - , module Network.XMPP.Types + ( -- * Session management + withNewSession + , withSession + , newSession + , withConnection + , connect + , startTLS + , auth + , endSession + , setSessionEndHandler + -- * JID + -- | A JID (historically: Jabber ID) is XMPPs native format + -- for addressing entities in the network. It is somewhat similar to an + -- email-address but contains three parts instead of two: + , JID(..) + -- * Stanzas + -- | @Stanzas@ are the the smallest unit of communication in @XMPP@. They + -- come in 3 flavors: + -- + -- * @'Message'@, for traditional IM-style message passing between peers + -- + -- * @'Presence'@, for communicating status updates + -- + -- * IQ (info/query), with a request-response semantics + -- + -- All stanza types have the following attributes in common: + -- + -- * The /id/ attribute is used by the originating entity to track + -- any response or error stanza that it might receive in relation to + -- the generated stanza from another entity (such as an intermediate + -- server or the intended recipient). It is up to the originating + -- entity whether the value of the 'id' attribute is unique only + -- within its current stream or unique globally. + -- + -- * The /from/ attribute specifies the JID of the sender. + -- + -- * The /to/ attribute specifies the JID of the intended recipient + -- for the stanza. + -- + -- * The /type/ attribute specifies the purpose or context of the + -- message, presence, or IQ stanza. The particular allowable values + -- for the 'type' attribute vary depending on whether the stanza is + -- a message, presence, or IQ stanza. + + -- ** Messages + -- | The /message/ stanza is a /push/ mechanism whereby one entity pushes + -- information to another entity, similar to the communications that occur in + -- a system such as email. + -- + -- + , Message + , MessageError + , MessageType(..) + -- *** creating + , simpleMessage + , answerMessage + -- *** sending + , sendMessage + -- *** receiving + , pullMessage + , waitForMessage + , waitForMessageError + , filterMessages + -- ** Presence + -- | The /presence/ stanza is a specialized /broadcast/ + -- or /publish-subscribe/ mechanism, whereby multiple entities + -- receive information about an entity to which they have + -- subscribed. + -- + -- + , Presence(..) + , PresenceError(..) + , ShowType(..) + -- *** creating , module Network.XMPP.Presence - , module Network.XMPP.Message - , xmppConnect - , xmppNewSession + -- *** sending + , sendPresence + -- *** receiving + , pullPresence + , waitForPresence + -- ** IQ + -- | Info\/Query, or IQ, is a /request-response/ mechanism, similar in some + -- ways to the Hypertext Transfer Protocol @HTTP@. The semantics of IQ enable + -- an entity to make a request of, and receive a response from, another + -- entity. The data content and precise semantics of the request and response + -- is defined by the schema or other structural definition associated with the + -- XML namespace that + -- qualifies the direct child element of the IQ element. IQ interactions + -- follow a common pattern of structured data + -- exchange such as get/result or set/result (although an error can be returned + -- in reply to a request if appropriate) + -- + -- + , IQRequest(..) + , IQRequestType(..) + , IQResult(..) + , IQError(..) + , sendIQ + , sendIQ' + , answerIQ + , listenIQChan + , iqRequestPayload + , iqResultPayload + -- * Threads + , XMPP + , fork + , forkSession + -- * Misc + , exampleParams ) where import Data.Text as Text import Network +import qualified Network.TLS as TLS import Network.XMPP.Bind import Network.XMPP.Concurrent -import Network.XMPP.Message +import Network.XMPP.Message hiding (message) import Network.XMPP.Monad -import Network.XMPP.Presence +import Network.XMPP.Presence hiding (presence) import Network.XMPP.SASL import Network.XMPP.Session import Network.XMPP.Stream import Network.XMPP.TLS import Network.XMPP.Types -xmppConnect :: HostName -> Text -> XMPPConMonad (Either StreamError ()) -xmppConnect address hostname = xmppRawConnect address hostname >> xmppStartStream +import Control.Monad.Error + +-- | Connect to host with given address. +connect :: HostName -> Text -> XMPPConMonad (Either StreamError ()) +connect address hostname = xmppRawConnect address hostname >> xmppStartStream -xmppNewSession :: XMPPThread a -> IO (a, XMPPConState) -xmppNewSession = withNewSession . runThreaded \ No newline at end of file +-- | Authenticate to the server with the given username and password +-- and bind a resource +auth :: Text.Text -- ^ The username + -> Text.Text -- ^ The password + -> Maybe Text -- ^ The desired resource or 'Nothing' to let the server + -- assign one + -> XMPPConMonad (Either AuthError Text.Text) +auth username passwd resource = runErrorT $ do + ErrorT $ xmppSASL username passwd + res <- lift $ xmppBind resource + lift $ xmppStartSession + return res diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index 51be0c3..b371883 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -11,7 +11,7 @@ import Data.XML.Types import Network.XMPP.Types import Network.XMPP.Pickle -import Network.XMPP.Concurrent +import Network.XMPP.Monad -- A `bind' element. @@ -29,7 +29,6 @@ bindBody rsrc = (pickleElem rsrc ) - -- Extracts the character data in the `jid' element. jidP :: PU [Node] JID @@ -39,10 +38,10 @@ jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim) -- Sends a (synchronous) IQ set request for a (`Just') given or -- server-generated resource and extract the JID from the non-error -- response. - -xmppThreadedBind :: Maybe Text -> XMPPThread Text -xmppThreadedBind rsrc = do - answer <- sendIQ' Nothing Set Nothing (bindBody rsrc) +xmppBind :: Maybe Text -> XMPPConMonad Text +xmppBind rsrc = do + answer <- xmppSendIQ' "bind" Nothing Set Nothing (bindBody rsrc) let (Right IQResult{iqResultPayload = Just b}) = answer -- TODO: Error handling let Right (JID _n _d (Just r)) = unpickleElem jidP b return r + diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs index 19f4ef7..2750ff1 100644 --- a/src/Network/XMPP/Concurrent.hs +++ b/src/Network/XMPP/Concurrent.hs @@ -1,18 +1,13 @@ module Network.XMPP.Concurrent -( module Network.XMPP.Concurrent.Types -, module Network.XMPP.Concurrent.Monad -, module Network.XMPP.Concurrent.Threads -, module Network.XMPP.Concurrent.IQ -) where - -import Network.XMPP.Concurrent.Types -import Network.XMPP.Concurrent.Monad -import Network.XMPP.Concurrent.Threads -import Network.XMPP.Concurrent.IQ - - - - - - + ( Session + , XMPP + , module Network.XMPP.Concurrent.Monad + , module Network.XMPP.Concurrent.Threads + , module Network.XMPP.Concurrent.IQ + ) where + +import Network.XMPP.Concurrent.Types +import Network.XMPP.Concurrent.Monad +import Network.XMPP.Concurrent.Threads +import Network.XMPP.Concurrent.IQ diff --git a/src/Network/XMPP/Concurrent/IQ.hs b/src/Network/XMPP/Concurrent/IQ.hs index cc97898..500719c 100644 --- a/src/Network/XMPP/Concurrent/IQ.hs +++ b/src/Network/XMPP/Concurrent/IQ.hs @@ -17,7 +17,7 @@ sendIQ :: Maybe JID -- ^ Recipient (to) -> IQRequestType -- ^ IQ type (Get or Set) -> Maybe LangTag -- ^ Language tag of the payload (Nothing for default) -> Element -- ^ The iq body (there has to be exactly one) - -> XMPPThread (TMVar IQResponse) + -> XMPP (TMVar IQResponse) sendIQ to tp lang body = do -- TODO: add timeout newId <- liftIO =<< asks idGenerator handlers <- asks iqHandlers @@ -27,7 +27,7 @@ sendIQ to tp lang body = do -- TODO: add timeout writeTVar handlers (byNS, Map.insert newId resRef byId) -- TODO: Check for id collisions (shouldn't happen?) return resRef - sendS . IQRequestS $ IQRequest newId Nothing to lang tp body + sendStanza . IQRequestS $ IQRequest newId Nothing to lang tp body return ref -- | like 'sendIQ', but waits for the answer IQ @@ -35,14 +35,14 @@ sendIQ' :: Maybe JID -> IQRequestType -> Maybe LangTag -> Element - -> XMPPThread IQResponse + -> XMPP IQResponse sendIQ' to tp lang body = do ref <- sendIQ to tp lang body liftIO . atomically $ takeTMVar ref answerIQ :: (IQRequest, TVar Bool) -> Either StanzaError (Maybe Element) - -> XMPPThread Bool + -> XMPP Bool answerIQ ((IQRequest iqid from _to lang _tp bd), sentRef) answer = do out <- asks outCh let response = case answer of diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index a39ce1b..748ed9f 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -14,28 +14,33 @@ import qualified Data.Map as Map import Data.Text(Text) import Network.XMPP.Concurrent.Types +import Network.XMPP.Monad + -- | Register a new IQ listener. IQ requests matching the type and namespace will -- be put in the channel. +-- +-- Return the new channel or Nothing if this namespace/'IQRequestType' +-- combination was alread handled listenIQChan :: IQRequestType -- ^ type of IQs to receive (Get / Set) -> Text -- ^ namespace of the child element - -> XMPPThread (Bool, TChan (IQRequest, TVar Bool)) + -> XMPP (Maybe ( TChan (IQRequest, TVar Bool))) listenIQChan tp ns = do handlers <- asks iqHandlers liftIO . atomically $ do (byNS, byID) <- readTVar handlers iqCh <- newTChan - let (present, byNS') = Map.insertLookupWithKey' (\_ new _ -> new) + let (present, byNS') = Map.insertLookupWithKey' (\_ _ old -> old) (tp,ns) iqCh byNS writeTVar handlers (byNS', byID) return $ case present of - Nothing -> (True, iqCh) - Just iqCh' -> (False, iqCh') + Nothing -> Just iqCh + Just _iqCh' -> Nothing -- | get the inbound stanza channel, duplicates from master if necessary -- please note that once duplicated it will keep filling up, call -- 'dropMessageChan' to allow it to be garbage collected -getMessageChan :: XMPPThread (TChan (Either MessageError Message)) +getMessageChan :: XMPP (TChan (Either MessageError Message)) getMessageChan = do mChR <- asks messagesRef mCh <- liftIO $ readIORef mChR @@ -48,7 +53,7 @@ getMessageChan = do Just mCh' -> return mCh' -- | see 'getMessageChan' -getPresenceChan :: XMPPThread (TChan (Either PresenceError Presence)) +getPresenceChan :: XMPP (TChan (Either PresenceError Presence)) getPresenceChan = do pChR <- asks presenceRef pCh <- liftIO $ readIORef pChR @@ -62,51 +67,55 @@ getPresenceChan = do -- | Drop the local end of the inbound stanza channel -- from our context so it can be GC-ed -dropMessageChan :: XMPPThread () +dropMessageChan :: XMPP () dropMessageChan = do r <- asks messagesRef liftIO $ writeIORef r Nothing -- | see 'dropMessageChan' -dropPresenceChan :: XMPPThread () +dropPresenceChan :: XMPP () dropPresenceChan = do r <- asks presenceRef liftIO $ writeIORef r Nothing -- | Read an element from the inbound stanza channel, acquiring a copy -- of the channel as necessary -pullMessage :: XMPPThread (Either MessageError Message) +pullMessage :: XMPP (Either MessageError Message) pullMessage = do c <- getMessageChan liftIO $ atomically $ readTChan c -- | Read an element from the inbound stanza channel, acquiring a copy -- of the channel as necessary -pullPresence :: XMPPThread (Either PresenceError Presence) +pullPresence :: XMPP (Either PresenceError Presence) pullPresence = do c <- getPresenceChan liftIO $ atomically $ readTChan c -- | Send a stanza to the server -sendS :: Stanza -> XMPPThread () -sendS a = do +sendStanza :: Stanza -> XMPP () +sendStanza a = do out <- asks outCh liftIO . atomically $ writeTChan out a return () +-- | Create a forked session object without forking a thread +forkSession :: Session -> IO Session +forkSession sess = do + mCH' <- newIORef Nothing + pCH' <- newIORef Nothing + return $ sess {messagesRef = mCH' ,presenceRef = pCH'} + -- | Fork a new thread -forkXMPP :: XMPPThread () -> XMPPThread ThreadId -forkXMPP a = do - thread <- ask - mCH' <- liftIO $ newIORef Nothing - pCH' <- liftIO $ newIORef Nothing - liftIO $ forkIO $ runReaderT a (thread {messagesRef = mCH' - ,presenceRef = pCH' - }) +fork :: XMPP () -> XMPP ThreadId +fork a = do + sess <- ask + sess' <- liftIO $ forkSession sess + liftIO $ forkIO $ runReaderT a sess' filterMessages :: (MessageError -> Bool) -> (Message -> Bool) - -> XMPPThread (Either MessageError Message) + -> XMPP (Either MessageError Message) filterMessages f g = do s <- pullMessage case s of @@ -115,7 +124,7 @@ filterMessages f g = do Right m | g m -> return $ Right m | otherwise -> filterMessages f g -waitForMessage :: (Message -> Bool) -> XMPPThread Message +waitForMessage :: (Message -> Bool) -> XMPP Message waitForMessage f = do s <- pullMessage case s of @@ -123,7 +132,7 @@ waitForMessage f = do Right m | f m -> return m | otherwise -> waitForMessage f -waitForMessageError :: (MessageError -> Bool) -> XMPPThread MessageError +waitForMessageError :: (MessageError -> Bool) -> XMPP MessageError waitForMessageError f = do s <- pullMessage case s of @@ -131,7 +140,7 @@ waitForMessageError f = do Left m | f m -> return m | otherwise -> waitForMessageError f -waitForPresence :: (Presence -> Bool) -> XMPPThread Presence +waitForPresence :: (Presence -> Bool) -> XMPP Presence waitForPresence f = do s <- pullPresence case s of @@ -143,27 +152,69 @@ waitForPresence f = do -- Reader and writer workers will be temporarily stopped -- and resumed with the new session details once the action returns. -- The Action will run in the calling thread/ --- NB: This will /not/ catch any exceptions. If you action dies, deadlocks --- or otherwisely exits abnormaly the XMPP session will be dead. -withConnection :: XMPPConMonad a -> XMPPThread a +-- Any uncaught exceptions will be interpreted as connection failure +withConnection :: XMPPConMonad a -> XMPP a withConnection a = do readerId <- asks readerThread stateRef <- asks conStateRef write <- asks writeRef wait <- liftIO $ newEmptyTMVarIO - liftIO . throwTo readerId $ Interrupt wait - s <- liftIO . atomically $ do - putTMVar wait () - takeTMVar write - takeTMVar stateRef - (res, s') <- liftIO $ runStateT a s - liftIO . atomically $ do - putTMVar write (sConPushBS s') - putTMVar stateRef s' - return res - -sendPresence :: Presence -> XMPPThread () -sendPresence = sendS . PresenceS + liftIO . Ex.mask_ $ do + throwTo readerId $ Interrupt wait + s <- Ex.catch ( atomically $ do + _ <- takeTMVar write + s <- takeTMVar stateRef + putTMVar wait () + return s + ) + (\e -> atomically (putTMVar wait ()) + >> Ex.throwIO (e :: Ex.SomeException) + -- No MVar taken + ) + Ex.catch ( do + (res, s') <- runStateT a s + atomically $ do + _ <- tryPutTMVar write (sConPushBS s') + _ <- tryPutTMVar stateRef s' + return () + return res + ) + -- we treat all Exceptions as fatal + (\e -> runStateT xmppKillConnection s + >> Ex.throwIO (e :: Ex.SomeException) + ) + +-- | Send a presence Stanza +sendPresence :: Presence -> XMPP () +sendPresence = sendStanza . PresenceS + +-- | Send a Message Stanza +sendMessage :: Message -> XMPP () +sendMessage = sendStanza . MessageS + + +modifyHandlers :: (EventHandlers -> EventHandlers) -> XMPP () +modifyHandlers f = do + eh <- asks eventHandlers + liftIO . atomically $ writeTVar eh . f =<< readTVar eh + +setSessionEndHandler :: XMPP () -> XMPP () +setSessionEndHandler eh = modifyHandlers (\s -> s{sessionEndHandler = eh}) + +-- | run an event handler +runHandler :: (EventHandlers -> XMPP a) -> XMPP a +runHandler h = do + eh <- liftIO . atomically . readTVar =<< asks eventHandlers + h eh + +-- | End the current xmpp session +endSession :: XMPP () +endSession = do -- TODO: This has to be idempotent (is it?) + withConnection xmppKillConnection + liftIO =<< asks stopThreads + runHandler sessionEndHandler + +-- | Close the connection to the server +closeConnection :: XMPP () +closeConnection = withConnection xmppKillConnection -sendMessage :: Message -> XMPPThread () -sendMessage = sendS . MessageS \ No newline at end of file diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index b40024b..f6e397f 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -10,18 +10,13 @@ import Control.Concurrent.STM import qualified Control.Exception.Lifted as Ex import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Trans import Control.Monad.Reader import Control.Monad.State.Strict import qualified Data.ByteString as BS -import Data.Conduit -import qualified Data.Conduit.List as CL -import Data.Default (def) import Data.IORef import qualified Data.Map as Map import Data.Maybe -import qualified Data.Text as Text import Data.XML.Types @@ -31,38 +26,46 @@ import Network.XMPP.Pickle import Network.XMPP.Concurrent.Types import Text.XML.Stream.Elements -import qualified Text.XML.Stream.Render as XR + +import GHC.IO (unsafeUnmask) + +-- While waiting for the first semaphore(s) to flip we might receive +-- another interrupt. When that happens we add it's semaphore to the +-- list and retry waiting +handleInterrupts :: [TMVar ()] -> IO [()] +handleInterrupts ts = + Ex.catch (atomically $ forM ts takeTMVar) + ( \(Interrupt t) -> handleInterrupts (t:ts)) readWorker :: TChan (Either MessageError Message) -> TChan (Either PresenceError Presence) -> TVar IQHandlers - -> TMVar XMPPConState + -> TMVar XmppConnection -> IO () readWorker messageC presenceC handlers stateRef = Ex.mask_ . forever $ do - s <- liftIO . atomically $ takeTMVar stateRef - (sta', s') <- flip runStateT s $ Ex.catch ( do - -- we don't know whether pull will necessarily be interruptible - liftIO $ Ex.allowInterrupt - Just <$> pull - ) - (\(Interrupt t) -> do - liftIO . atomically $ - putTMVar stateRef s - liftIO . atomically $ takeTMVar t - return Nothing - ) + res <- liftIO $ Ex.catch ( do + -- we don't know whether pull will + -- necessarily be interruptible + s <- liftIO . atomically $ readTMVar stateRef + allowInterrupt + Just <$> runStateT pullStanza s + ) + (\(Interrupt t) -> do + void $ handleInterrupts [t] + return Nothing + ) liftIO . atomically $ do - case sta' of + case res of Nothing -> return () - Just sta -> do - putTMVar stateRef s' + Just (sta, _s) -> do case sta of MessageS m -> do writeTChan messageC $ Right m _ <- readTChan messageC -- Sic! return () -- this may seem ridiculous, but to prevent - -- the channel from filling up we immedtiately remove the + -- the channel from filling up we + -- immedtiately remove the -- Stanza we just put in. It will still be -- available in duplicates. MessageErrorS m -> do writeTChan messageC $ Left m @@ -80,8 +83,13 @@ readWorker messageC presenceC handlers stateRef = IQRequestS i -> handleIQRequest handlers i IQResultS i -> handleIQResponse handlers (Right i) IQErrorS i -> handleIQResponse handlers (Left i) + where + -- Defining an Control.Exception.allowInterrupt equivalent for + -- GHC 7 compatibility. + allowInterrupt :: IO () + allowInterrupt = unsafeUnmask $ return () - +handleIQRequest :: TVar IQHandlers -> IQRequest -> STM () handleIQRequest handlers iq = do (byNS, _) <- readTVar handlers let iqNS = fromMaybe "" (nameNamespace . elementName $ iqRequestPayload iq) @@ -91,6 +99,7 @@ handleIQRequest handlers iq = do sent <- newTVar False writeTChan ch (iq, sent) +handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> STM () handleIQResponse handlers iq = do (byNS, byID) <- readTVar handlers case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq) byID of @@ -101,14 +110,14 @@ handleIQResponse handlers iq = do writeTVar handlers (byNS, byID') where iqID (Left err) = iqErrorID err - iqID (Right iq) = iqResultID iq + iqID (Right iq') = iqResultID iq' writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO ()) -> IO () writeWorker stCh writeR = forever $ do (write, next) <- atomically $ (,) <$> takeTMVar writeR <*> readTChan stCh - _ <- write $ renderElement (pickleElem stanzaP next) + _ <- write $ renderElement (pickleElem xpStanza next) atomically $ putTMVar writeR write -- Two streams: input and output. Threads read from input stream and write to output stream. @@ -116,56 +125,58 @@ writeWorker stCh writeR = forever $ do -- returns channel of incoming and outgoing stances, respectively -- and an Action to stop the Threads and close the connection startThreads - :: XMPPConMonad ( TChan (Either MessageError Message) - , TChan (Either PresenceError Presence) - , TVar IQHandlers - , TChan Stanza - , IO () - , TMVar (BS.ByteString -> IO ()) - , TMVar XMPPConState - , ThreadId - ) + :: IO ( TChan (Either MessageError Message) + , TChan (Either PresenceError Presence) + , TVar IQHandlers + , TChan Stanza + , IO () + , TMVar (BS.ByteString -> IO ()) + , TMVar XmppConnection + , ThreadId + , TVar EventHandlers + ) startThreads = do - writeLock <- liftIO . newTMVarIO =<< gets sConPushBS - messageC <- liftIO newTChanIO - presenceC <- liftIO newTChanIO - iqC <- liftIO newTChanIO - outC <- liftIO newTChanIO - handlers <- liftIO $ newTVarIO ( Map.empty, Map.empty) - conS <- liftIO . newTMVarIO =<< get - lw <- liftIO . forkIO $ writeWorker outC writeLock - cp <- liftIO . forkIO $ connPersist writeLock - s <- get - rd <- liftIO . forkIO $ readWorker messageC presenceC handlers conS + writeLock <- newTMVarIO (\_ -> return ()) + messageC <- newTChanIO + presenceC <- newTChanIO + outC <- newTChanIO + handlers <- newTVarIO ( Map.empty, Map.empty) + eh <- newTVarIO zeroEventHandlers + conS <- newTMVarIO xmppNoConnection + lw <- forkIO $ writeWorker outC writeLock + cp <- forkIO $ connPersist writeLock + rd <- forkIO $ readWorker messageC presenceC handlers conS return (messageC, presenceC, handlers, outC , killConnection writeLock [lw, rd, cp] - , writeLock, conS ,rd) + , writeLock, conS ,rd, eh) where killConnection writeLock threads = liftIO $ do _ <- atomically $ takeTMVar writeLock -- Should we put it back? _ <- forM threads killThread return() --- | Start worker threads and run action. The supplied action will run --- in the calling thread. use 'forkXMPP' to start another thread. -runThreaded :: XMPPThread a - -> XMPPConMonad a -runThreaded a = do - liftIO . putStrLn $ "starting threads" - (mC, pC, hand, outC, _stopThreads, writeR, conS, rdr ) <- startThreads - liftIO . putStrLn $ "threads running" - workermCh <- liftIO . newIORef $ Nothing - workerpCh <- liftIO . newIORef $ Nothing - idRef <- liftIO $ newTVarIO 1 +-- | Creates and initializes a new XMPP session. +newSession :: IO Session +newSession = do + (mC, pC, hand, outC, stopThreads', writeR, conS, rdr, eh) <- startThreads + workermCh <- newIORef $ Nothing + workerpCh <- newIORef $ Nothing + idRef <- newTVarIO 1 let getId = atomically $ do curId <- readTVar idRef writeTVar idRef (curId + 1 :: Integer) return . read. show $ curId - s <- get - liftIO . putStrLn $ "starting application" - liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId conS) + return (Session workermCh workerpCh mC pC outC hand writeR rdr getId conS eh stopThreads') + +withNewSession :: XMPP b -> IO (Session, b) +withNewSession a = do + sess <- newSession + ret <- runReaderT a sess + return (sess, ret) +withSession :: Session -> XMPP a -> IO a +withSession = flip runReaderT -- | Sends a blank space every 30 seconds to keep the connection alive connPersist :: TMVar (BS.ByteString -> IO ()) -> IO () @@ -173,5 +184,4 @@ connPersist lock = forever $ do pushBS <- atomically $ takeTMVar lock pushBS " " atomically $ putTMVar lock pushBS --- putStrLn "" threadDelay 30000000 diff --git a/src/Network/XMPP/Concurrent/Types.hs b/src/Network/XMPP/Concurrent/Types.hs index 14f0d04..d075797 100644 --- a/src/Network/XMPP/Concurrent/Types.hs +++ b/src/Network/XMPP/Concurrent/Types.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE DeriveDataTypeable #-} module Network.XMPP.Concurrent.Types where @@ -21,27 +22,40 @@ type IQHandlers = (Map.Map (IQRequestType, Text) (TChan (IQRequest, TVar Bool)) , Map.Map StanzaId (TMVar IQResponse) ) -data Thread = Thread { messagesRef :: IORef (Maybe ( TChan (Either +data EventHandlers = EventHandlers + { sessionEndHandler :: XMPP () + , connectionClosedHandler :: XMPP () + } + +zeroEventHandlers :: EventHandlers +zeroEventHandlers = EventHandlers + { sessionEndHandler = return () + , connectionClosedHandler = return () + } + +data Session = Session { messagesRef :: IORef (Maybe ( TChan (Either MessageError Message - ))) - , presenceRef :: IORef (Maybe (TChan (Either - PresenceError - Presence - ))) - , mShadow :: TChan (Either MessageError - Message) -- the original chan - , pShadow :: TChan (Either PresenceError - Presence) -- the original chan - , outCh :: TChan Stanza - , iqHandlers :: TVar IQHandlers - , writeRef :: TMVar (BS.ByteString -> IO () ) - , readerThread :: ThreadId - , idGenerator :: IO StanzaId - , conStateRef :: TMVar XMPPConState - } - -type XMPPThread a = ReaderT Thread IO a + ))) + , presenceRef :: IORef (Maybe (TChan (Either + PresenceError Presence ))) + , mShadow :: TChan (Either MessageError + Message) + -- the original chan + , pShadow :: TChan (Either PresenceError + Presence) + -- the original chan + , outCh :: TChan Stanza + , iqHandlers :: TVar IQHandlers + , writeRef :: TMVar (BS.ByteString -> IO () ) + , readerThread :: ThreadId + , idGenerator :: IO StanzaId + , conStateRef :: TMVar XmppConnection + , eventHandlers :: TVar EventHandlers + , stopThreads :: IO () + } + +type XMPP a = ReaderT Session IO a data Interrupt = Interrupt (TMVar ()) deriving Typeable instance Show Interrupt where show _ = "" diff --git a/src/Network/XMPP/JID.hs b/src/Network/XMPP/JID.hs index 2076f94..9d44130 100644 --- a/src/Network/XMPP/JID.hs +++ b/src/Network/XMPP/JID.hs @@ -15,183 +15,213 @@ -- -- This module does not internationalize hostnames. +module Network.XMPP.JID + ( JID(..) + , fromText + , fromStrings + , isBare + , isFull) where + +import Control.Applicative ((<$>),(<|>)) +import Control.Monad(guard) + +import qualified Data.Attoparsec.Text as AP +import Data.Maybe(fromJust) +import qualified Data.Set as Set +import Data.String (IsString(..)) +import Data.Text (Text) +import qualified Data.Text as Text + +-- import Network.URI (isIPv4address, isIPv6address) + +import qualified Text.NamePrep as SP +import qualified Text.StringPrep as SP + +data JID = JID { + -- | The @localpart@ of a JID is an optional identifier + -- placed before the domainpart and separated from the + -- latter by a \'\@\' character. Typically a + -- localpart uniquely identifies the entity requesting + -- and using network access provided by a server + -- (i.e., a local account), although it can also + -- represent other kinds of entities (e.g., a chat + -- room associated with a multi-user chat service). + -- The entity represented by an XMPP localpart is + -- addressed within the context of a specific domain + -- (i.e., @localpart\@domainpart@). + + localpart :: !(Maybe Text) + -- | The domainpart typically identifies the /home/ + -- server to which clients connect for XML routing and + -- data management functionality. However, it is not + -- necessary for an XMPP domainpart to identify an + -- entity that provides core XMPP server functionality + -- (e.g., a domainpart can identify an entity such as a + -- multi-user chat service, a publish-subscribe + -- service, or a user directory). + , domainpart :: !Text + -- | The resourcepart of a JID is an optional + -- identifier placed after the domainpart and + -- separated from the latter by the \'\/\' character. A + -- resourcepart can modify either a + -- @localpart\@domainpart@ address or a mere + -- @domainpart@ address. Typically a resourcepart + -- uniquely identifies a specific connection (e.g., a + -- device or location) or object (e.g., an occupant + -- in a multi-user chat room) belonging to the entity + -- associated with an XMPP localpart at a domain + -- (i.e., @localpart\@domainpart/resourcepart@). + , resourcepart :: !(Maybe Text) + } + +instance Show JID where + show (JID nd dmn res) = + maybe "" ((++ "@") . Text.unpack) nd ++ + (Text.unpack dmn) ++ + maybe "" (('/' :) . Text.unpack) res + +instance Read JID where + readsPrec _ x = case fromText (Text.pack x) of + Nothing -> [] + Just j -> [(j,"")] + + +instance IsString JID where + fromString = fromJust . fromText . Text.pack + +-- | Converts a Text to a JID. +fromText :: Text -> Maybe JID +fromText t = do + (l, d, r) <- eitherToMaybe $ AP.parseOnly jidParts t + fromStrings l d r + where + eitherToMaybe = either (const Nothing) Just -module Network.XMPP.JID (fromString, fromStrings, isBare, isFull) where - -import Network.XMPP.Types - -import Data.Maybe (fromJust, isJust) -import Text.Parsec ((<|>), anyToken, char, eof, many, noneOf, parse) -import Text.Parsec.ByteString (GenParser) - -import Text.StringPrep (StringPrepProfile (..), a1, b1, b2, c11, c12, c21, c22, - c3, c4, c5, c6, c7, c8, c9, runStringPrep) -import Text.NamePrep (namePrepProfile) - -import Network.URI (isIPv4address, isIPv6address) - -import qualified Data.ByteString.Char8 as DBC (pack) -import qualified Data.Text as DT (pack, unpack) - - --- | --- Converts a string to a JID. - -fromString :: String -> Maybe JID - -fromString s = fromStrings localpart domainpart resourcepart - where - Right (localpart, domainpart, resourcepart) = - parse jidParts "" (DBC.pack s) - - --- | --- Converts localpart, domainpart, and resourcepart strings to a JID. - +-- | Converts localpart, domainpart, and resourcepart strings to a JID. -- Runs the appropriate stringprep profiles and validates the parts. - -fromStrings :: Maybe String -> String -> Maybe String -> Maybe JID - -fromStrings l s r - | domainpart == Nothing = Nothing - | otherwise = if validateNonDomainpart localpart && - isJust domainpart' && - validateNonDomainpart resourcepart - then Just (JID localpart (fromJust domainpart') resourcepart) - else Nothing +fromStrings :: Maybe Text -> Text -> Maybe Text -> Maybe JID +fromStrings l d r = do + localPart <- case l of + Nothing -> return Nothing + Just l'-> do + l'' <- SP.runStringPrep nodeprepProfile l' + guard $ validPartLength l'' + let prohibMap = Set.fromList nodeprepExtraProhibitedCharacters + guard $ Text.all (`Set.notMember` prohibMap) l'' + return $ Just l'' + domainPart <- SP.runStringPrep (SP.namePrepProfile False) d + guard $ validDomainPart domainPart + resourcePart <- case r of + Nothing -> return Nothing + Just r' -> do + r'' <- SP.runStringPrep resourceprepProfile r' + guard $ validPartLength r'' + return $ Just r'' + return $ JID localPart domainPart resourcePart where - - -- Applies the nodeprep profile on the localpart string, if any. - localpart :: Maybe String - localpart = case l of - Just l' -> case runStringPrep nodeprepProfile (DT.pack l') of - Just l'' -> Just $ DT.unpack l'' - Nothing -> Nothing - Nothing -> Nothing - - -- Applies the nameprep profile on the domainpart string. - -- TODO: Allow unassigned? - domainpart :: Maybe String - domainpart = case runStringPrep (namePrepProfile False) (DT.pack s) of - Just s' -> Just $ DT.unpack s' - Nothing -> Nothing - - -- Applies the resourceprep profile on the resourcepart string, if - -- any. - resourcepart :: Maybe String - resourcepart = case r of - Just r' -> case runStringPrep resourceprepProfile (DT.pack r') of - Just r'' -> Just $ DT.unpack r'' - Nothing -> Nothing - Nothing -> Nothing - -- Returns the domainpart if it was a valid IP or if the toASCII -- function was successful, or Nothing otherwise. - domainpart' :: Maybe String - domainpart' | isIPv4address s || isIPv6address s = Just s - | validHostname s = Just s - | otherwise = Nothing - - -- Validates that non-domainpart strings have an appropriate - -- length. - validateNonDomainpart :: Maybe String -> Bool - validateNonDomainpart Nothing = True - validateNonDomainpart (Just l) = validPartLength l - where - validPartLength :: String -> Bool - validPartLength p = length p > 0 && length p < 1024 + validDomainPart _s = True -- TODO + -- isIPv4address s || isIPv6address s || validHostname s + validPartLength :: Text -> Bool + validPartLength p = Text.length p > 0 && Text.length p < 1024 -- Validates a host name - validHostname :: String -> Bool - validHostname _ = True -- TODO - - --- | Returns True if the JID is `bare', and False otherwise. + -- validHostname :: Text -> Bool + -- validHostname _ = True -- TODO +-- | Returns True if the JID is /bare/, and False otherwise. isBare :: JID -> Bool - isBare j | resourcepart j == Nothing = True | otherwise = False - -- | Returns True if the JID is `full', and False otherwise. - isFull :: JID -> Bool - isFull jid = not $ isBare jid - -- Parses an JID string and returns its three parts. It performs no -- validation or transformations. We are using Parsec to parse the -- JIDs. There is no input for which 'jidParts' fails. - -jidParts :: GenParser Char st (Maybe String, String, Maybe String) - jidParts = do - -- Read until we reach an '@', a '/', or EOF. - a <- many $ noneOf ['@', '/'] - + a <- AP.takeWhile1 (AP.notInClass ['@', '/']) -- Case 1: We found an '@', and thus the localpart. At least the -- domainpart is remaining. Read the '@' and until a '/' or EOF. do - char '@' - b <- many $ noneOf ['/'] - + b <- domainPartP -- Case 1A: We found a '/' and thus have all the JID parts. Read -- the '/' and until EOF. do - char '/' -- Resourcepart remaining - c <- many $ anyToken -- Parse resourcepart - eof + c <- resourcePartP -- Parse resourcepart return (Just a, b, Just c) - -- Case 1B: We have reached EOF; the JID is in the form -- localpart@domainpart. <|> do - eof + AP.endOfInput return (Just a, b, Nothing) - -- Case 2: We found a '/'; the JID is in the form -- domainpart/resourcepart. <|> do - char '/' - b <- many $ anyToken - eof + b <- resourcePartP + AP.endOfInput return (Nothing, a, Just b) - -- Case 3: We have reached EOF; we have an JID consisting of only -- a domainpart. <|> do - eof + AP.endOfInput return (Nothing, a, Nothing) - - -nodeprepProfile :: StringPrepProfile - -nodeprepProfile = Profile { maps = [b1, b2] - , shouldNormalize = True - , prohibited = [a1] ++ [c11, c12, c21, c22, - c3, c4, c5, c6, c7, - c8, c9] - , shouldCheckBidi = True } - + where + domainPartP = do + _ <- AP.char '@' + AP.takeWhile1 (/= '/') + resourcePartP = do + _ <- AP.char '/' + AP.takeText + + +nodeprepProfile :: SP.StringPrepProfile +nodeprepProfile = SP.Profile + { SP.maps = [SP.b1, SP.b2] + , SP.shouldNormalize = True + , SP.prohibited = [SP.a1 + , SP.c11 + , SP.c12 + , SP.c21 + , SP.c22 + , SP.c3 + , SP.c4 + , SP.c5 + , SP.c6 + , SP.c7 + , SP.c8 + , SP.c9 + ] + , SP.shouldCheckBidi = True + } -- These needs to be checked for after normalization. We could also -- look up the Unicode mappings and include a list of characters in -- the prohibited field above. Let's defer that until we know that we -- are going to use stringprep. - +nodeprepExtraProhibitedCharacters :: [Char] nodeprepExtraProhibitedCharacters = ['\x22', '\x26', '\x27', '\x2F', '\x3A', '\x3C', '\x3E', '\x40'] - - -resourceprepProfile :: StringPrepProfile - -resourceprepProfile = Profile { maps = [b1] - , shouldNormalize = True - , prohibited = [a1] ++ [c12, c21, c22, - c3, c4, c5, c6, - c7, c8, c9] - , shouldCheckBidi = True } +resourceprepProfile :: SP.StringPrepProfile +resourceprepProfile = SP.Profile + { SP.maps = [SP.b1] + , SP.shouldNormalize = True + , SP.prohibited = [ SP.a1 + , SP.c12 + , SP.c21 + , SP.c22 + , SP.c3 + , SP.c4 + , SP.c5 + , SP.c6 + , SP.c7 + , SP.c8 + , SP.c9 + ] + , SP.shouldCheckBidi = True + } diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index 6f32fde..165a963 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -5,8 +5,12 @@ module Network.XMPP.Marshal where import Data.XML.Pickle import Data.XML.Types +import Network.XMPP.Pickle import Network.XMPP.Types +xpStreamEntity :: PU [Node] (Either XmppStreamError Stanza) +xpStreamEntity = xpEither xpStreamError xpStanza + stanzaSel :: Stanza -> Int stanzaSel (IQRequestS _) = 0 stanzaSel (IQResultS _) = 1 @@ -16,8 +20,8 @@ stanzaSel (MessageErrorS _) = 4 stanzaSel (PresenceS _) = 5 stanzaSel (PresenceErrorS _) = 6 -stanzaP :: PU [Node] Stanza -stanzaP = xpAlt stanzaSel +xpStanza :: PU [Node] Stanza +xpStanza = xpAlt stanzaSel [ xpWrap IQRequestS (\(IQRequestS x) -> x) xpIQRequest , xpWrap IQResultS (\(IQResultS x) -> x) xpIQResult , xpWrap IQErrorS (\(IQErrorS x) -> x) xpIQError @@ -27,12 +31,6 @@ stanzaP = xpAlt stanzaSel , xpWrap PresenceErrorS (\(PresenceErrorS x) -> x) xpPresenceError ] -xmlLang :: Name -xmlLang = Name "lang" Nothing (Just "xml") - -xpLangTag :: PU [Attribute] (Maybe LangTag) -xpLangTag = xpAttrImplied xmlLang xpPrim - xpMessage :: PU [Node] (Message) xpMessage = xpWrap (\((tp, qid, from, to, lang), (sub, body, thr, ext)) -> Message qid from to lang tp sub thr body ext) @@ -193,3 +191,27 @@ xpIQError = xpWrap (\((qid, from, to, lang, _tp),(err, body)) (xpOption xpElemVerbatim) ) +xpStreamError :: PU [Node] XmppStreamError +xpStreamError = xpWrap + (\((cond,() ,()), txt, el) -> XmppStreamError cond txt el) + (\(XmppStreamError cond txt el) ->((cond,() ,()), txt, el)) + (xpElemNodes + (Name "error" + (Just "http://etherx.jabber.org/streams") + (Just "stream") + ) $ xp3Tuple + (xpElemByNamespace + "urn:ietf:params:xml:ns:xmpp-streams" xpPrim + xpUnit + xpUnit + ) + (xpOption $ xpElem + "{urn:ietf:params:xml:ns:xmpp-streams}text" + xpLangTag + (xpContent xpId)) + ( xpOption xpElemVerbatim + -- application specific error conditions + ) + ) + + diff --git a/src/Network/XMPP/Message.hs b/src/Network/XMPP/Message.hs index 6d1dadc..b472dba 100644 --- a/src/Network/XMPP/Message.hs +++ b/src/Network/XMPP/Message.hs @@ -1,11 +1,21 @@ {-# LANGUAGE RecordWildCards #-} -module Network.XMPP.Message where +-- | Message handling +module Network.XMPP.Message + ( Message(..) + , MessageType(..) + , MessageError(..) + , message + , simpleMessage + , answerMessage + ) + where import Data.Text(Text) import Data.XML.Types import Network.XMPP.Types +-- The empty message message :: Message message = Message { messageID = Nothing , messageFrom = Nothing @@ -18,7 +28,11 @@ message = Message { messageID = Nothing , messagePayload = [] } -simpleMessage :: JID -> Text -> Message + +-- | Create simple message, containing nothing but a body text +simpleMessage :: JID -- ^ Recipient + -> Text -- ^ Myssage body + -> Message simpleMessage to txt = message { messageTo = Just to , messageBody = Just txt } diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index cf3b634..6621f12 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -1,34 +1,33 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} module Network.XMPP.Monad where -import Control.Applicative((<$>)) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class +import Control.Applicative((<$>)) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class --import Control.Monad.Trans.Resource -import Control.Concurrent -import Control.Monad.State.Strict +import qualified Control.Exception as Ex +import Control.Monad.State.Strict -import Data.ByteString as BS -import Data.Conduit -import Data.Conduit.Binary as CB -import Data.Conduit.List as CL -import Data.Text(Text) -import Data.XML.Pickle -import Data.XML.Types +import Data.ByteString as BS +import Data.Conduit +import Data.Conduit.BufferedSource +import Data.Conduit.Binary as CB +import Data.Text(Text) +import Data.XML.Pickle +import Data.XML.Types -import Network -import Network.XMPP.Types -import Network.XMPP.Marshal -import Network.XMPP.Pickle +import Network +import Network.XMPP.Types +import Network.XMPP.Marshal +import Network.XMPP.Pickle -import System.IO - -import Text.XML.Stream.Elements -import Text.XML.Stream.Parse as XP -import Text.XML.Stream.Render as XR +import System.IO +import Text.XML.Stream.Elements +import Text.XML.Stream.Parse as XP pushN :: Element -> XMPPConMonad () pushN x = do @@ -36,7 +35,7 @@ pushN x = do liftIO . sink $ renderElement x push :: Stanza -> XMPPConMonad () -push = pushN . pickleElem stanzaP +push = pushN . pickleElem xpStanza pushOpen :: Element -> XMPPConMonad () pushOpen e = do @@ -44,58 +43,65 @@ pushOpen e = do liftIO . sink $ renderOpenElement e return () -pulls :: Sink Event IO b -> XMPPConMonad b -pulls snk = do +pullSink :: Sink Event IO b -> XMPPConMonad b +pullSink snk = do source <- gets sConSrc - (src', r) <- lift $ source $$+ snk - modify $ (\s -> s {sConSrc = src'}) + (_, r) <- lift $ source $$+ snk return r -pullE :: XMPPConMonad Element -pullE = pulls elementFromEvents +pullElement :: XMPPConMonad Element +pullElement = pullSink elementFromEvents pullPickle :: PU [Node] a -> XMPPConMonad a -pullPickle p = unpickleElem' p <$> pullE - -pull :: XMPPConMonad Stanza -pull = pullPickle stanzaP +pullPickle p = do + res <- unpickleElem p <$> pullElement + case res of + Left e -> liftIO . Ex.throwIO $ StreamXMLError e + Right r -> return r + +pullStanza :: XMPPConMonad Stanza +pullStanza = do + res <- pullPickle xpStreamEntity + case res of + Left e -> liftIO . Ex.throwIO $ StreamError e + Right r -> return r xmppFromHandle :: Handle -> Text - -> Text - -> Maybe Text -> XMPPConMonad a - -> IO (a, XMPPConState) -xmppFromHandle handle hostname username res f = do + -> IO (a, XmppConnection) +xmppFromHandle handle hostname f = do liftIO $ hSetBuffering handle NoBuffering let raw = sourceHandle handle let src = raw $= XP.parseBytes def - let st = XMPPConState + let st = XmppConnection src (raw) (BS.hPut handle) (Just handle) (SF Nothing [] []) - False + XmppConnectionPlain (Just hostname) - (Just username) - res + Nothing + Nothing + (hClose handle) runStateT f st zeroSource :: Source IO output -zeroSource = sourceState () (\_ -> forever $ threadDelay 10000000) +zeroSource = liftIO . Ex.throwIO $ XmppNoConnection -xmppZeroConState :: XMPPConState -xmppZeroConState = XMPPConState +xmppNoConnection :: XmppConnection +xmppNoConnection = XmppConnection { sConSrc = zeroSource , sRawSrc = zeroSource - , sConPushBS = (\_ -> return ()) + , sConPushBS = \_ -> Ex.throwIO $ XmppNoConnection , sConHandle = Nothing , sFeatures = SF Nothing [] [] - , sHaveTLS = False + , sConnectionState = XmppConnectionClosed , sHostname = Nothing , sUsername = Nothing , sResource = Nothing + , sCloseConnection = return () } xmppRawConnect :: HostName -> Text -> XMPPConMonad () @@ -106,19 +112,42 @@ xmppRawConnect host hostname = do hSetBuffering con NoBuffering return con let raw = sourceHandle con - let src = raw $= XP.parseBytes def - let st = XMPPConState + src <- liftIO . bufferSource $ raw $= XP.parseBytes def + let st = XmppConnection src (raw) (BS.hPut con) (Just con) (SF Nothing [] []) - False + XmppConnectionPlain (Just hostname) uname Nothing + (hClose con) put st -withNewSession :: XMPPConMonad a -> IO (a, XMPPConState) -withNewSession action = do - runStateT action xmppZeroConState +xmppNewSession :: XMPPConMonad a -> IO (a, XmppConnection) +xmppNewSession action = do + runStateT action xmppNoConnection + +xmppKillConnection :: XMPPConMonad () +xmppKillConnection = do + cc <- gets sCloseConnection + void . liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ())) + put xmppNoConnection + +xmppSendIQ' :: StanzaId -> Maybe JID -> IQRequestType + -> Maybe LangTag -> Element + -> XMPPConMonad (Either IQError IQResult) +xmppSendIQ' iqID to tp lang body = do + push . IQRequestS $ IQRequest iqID Nothing to lang tp body + res <- pullPickle $ xpEither xpIQError xpIQResult + case res of + Left e -> return $ Left e + Right iq' -> do + unless (iqID == iqResultID iq') . liftIO . Ex.throwIO $ + StreamXMLError + ("In xmppSendIQ' IDs don't match: " ++ show iqID ++ + " /= " ++ show (iqResultID iq') ++ " .") + return $ Right iq' + diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index 97d3989..bc611d8 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -5,11 +5,27 @@ -- Marshalling between XML and Native Types -module Network.XMPP.Pickle where +module Network.XMPP.Pickle + ( mbToBool + , xpElemEmpty + , xmlLang + , xpLangTag + , xpNodeElem + , ignoreAttrs + , mbl + , lmb + , right + , unpickleElem' + , unpickleElem + , pickleElem + , ppElement + ) where import Data.XML.Types import Data.XML.Pickle +import Network.XMPP.Types + import Text.XML.Stream.Elements mbToBool :: Maybe t -> Bool @@ -21,11 +37,11 @@ xpElemEmpty name = xpWrap (\((),()) -> ()) (\() -> ((),())) $ xpElem name xpUnit xpUnit --- xpElemExists :: Name -> PU [Node] Bool --- xpElemExists name = xpWrap (\x -> mbToBool x) --- (\x -> if x then Just () else Nothing) $ --- xpOption (xpElemEmpty name) +xmlLang :: Name +xmlLang = Name "lang" Nothing (Just "xml") +xpLangTag :: PU [Attribute] (Maybe LangTag) +xpLangTag = xpAttrImplied xmlLang xpPrim xpNodeElem :: PU [Node] a -> PU Element a xpNodeElem xp = PU { pickleTree = \x -> head $ (pickleTree xp x) >>= \y -> @@ -63,3 +79,4 @@ unpickleElem p x = unpickle (xpNodeElem p) x pickleElem :: PU [Node] a -> a -> Element pickleElem p = pickle $ xpNodeElem p + diff --git a/src/Network/XMPP/Presence.hs b/src/Network/XMPP/Presence.hs index f948596..501f60f 100644 --- a/src/Network/XMPP/Presence.hs +++ b/src/Network/XMPP/Presence.hs @@ -1,9 +1,10 @@ +{-# OPTIONS_HADDOCK hide #-} module Network.XMPP.Presence where import Data.Text(Text) import Network.XMPP.Types - +-- | The empty presence. presence :: Presence presence = Presence { presenceID = Nothing , presenceFrom = Nothing @@ -16,6 +17,7 @@ presence = Presence { presenceID = Nothing , presencePayload = [] } +-- | Request subscription with an entity presenceSubscribe :: JID -> Presence presenceSubscribe to = presence { presenceTo = Just to , presenceType = Just Subscribe @@ -45,14 +47,15 @@ presenceUnsubscribe to = presence { presenceTo = Just to isPresenceUnsubscribe :: Presence -> Bool isPresenceUnsubscribe pres = presenceType pres == (Just Unsubscribe) --- | Signals to the server that the client is available for communication +-- | Signal to the server that the client is available for communication presenceOnline :: Presence presenceOnline = presence --- | Signals to the server that the client is no longer available for communication. +-- | Signal to the server that the client is no longer available for communication. presenceOffline :: Presence presenceOffline = presence {presenceType = Just Unavailable} +-- Change your status status :: Maybe Text -- ^ Status message -> Maybe ShowType -- ^ Status Type @@ -63,16 +66,16 @@ status txt showType prio = presence { presenceShowType = showType , presenceStatus = txt } --- | Sets the current availability status. This implicitly sets the clients +-- | Set the current availability status. This implicitly sets the clients -- status online presenceAvail :: ShowType -> Presence presenceAvail showType = status Nothing (Just showType) Nothing --- | Sets the current status message. This implicitly sets the clients +-- | Set the current status message. This implicitly sets the clients -- status online presenceMessage :: Text -> Presence presenceMessage txt = status (Just txt) Nothing Nothing --- | Adds a recipient to a presence notification +-- | Add a recipient to a presence notification presTo :: Presence -> JID -> Presence presTo pres to = pres{presenceTo = Just to} \ No newline at end of file diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index c325d89..b5897bf 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -2,8 +2,9 @@ module Network.XMPP.SASL where import Control.Applicative +import Control.Arrow (left) import Control.Monad -import Control.Monad.IO.Class +import Control.Monad.Error import Control.Monad.State.Strict import qualified Crypto.Classes as CC @@ -16,6 +17,7 @@ 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 Data.XML.Pickle import Data.XML.Types @@ -26,6 +28,7 @@ import qualified Data.Text.Encoding as Text import Network.XMPP.Monad import Network.XMPP.Stream import Network.XMPP.Types +import Network.XMPP.Pickle import qualified System.Random as Random @@ -48,35 +51,55 @@ saslResponse2E = [] [] -xmppSASL:: Text -> Text -> XMPPConMonad (Either String Text) -xmppSASL uname passwd = do +data AuthError = AuthXmlError + | AuthMechanismError [Text] + | AuthChallengeError + | AuthStreamError StreamError + | AuthConnectionError + deriving Show + +instance Error AuthError where + noMsg = AuthXmlError + +xmppSASL:: Text -> Text -> XMPPConMonad (Either AuthError Text) +xmppSASL uname passwd = runErrorT $ do realm <- gets sHostname case realm of Just realm' -> do - xmppStartSASL realm' uname passwd + ErrorT $ xmppStartSASL realm' uname passwd modify (\s -> s{sUsername = Just uname}) - return $ Right uname - Nothing -> return $ Left "No connection found" + return uname + Nothing -> throwError AuthConnectionError xmppStartSASL :: Text -> Text -> Text - -> XMPPConMonad () -xmppStartSASL realm username passwd = do + -> XMPPConMonad (Either AuthError ()) +xmppStartSASL realm username passwd = runErrorT $ do mechanisms <- gets $ saslMechanisms . sFeatures - unless ("DIGEST-MD5" `elem` mechanisms) . error $ "No usable auth mechanism: " ++ show mechanisms - pushN $ saslInitE "DIGEST-MD5" - Right challenge <- B64.decode . Text.encodeUtf8<$> pullPickle challengePickle - let Right pairs = toPairs challenge + unless ("DIGEST-MD5" `elem` mechanisms) + . throwError $ AuthMechanismError mechanisms + lift . pushN $ saslInitE "DIGEST-MD5" + challenge' <- lift $ B64.decode . Text.encodeUtf8 + <$> pullPickle challengePickle + challenge <- case challenge' of + Left _e -> throwError AuthChallengeError + Right r -> return r + pairs <- case toPairs challenge of + Left _ -> throwError AuthChallengeError + Right p -> return p g <- liftIO $ Random.newStdGen - pushN . saslResponseE $ createResponse g realm username passwd pairs - challenge2 <- pullPickle (xpEither failurePickle challengePickle) + lift . pushN . saslResponseE $ createResponse g realm username passwd pairs + challenge2 <- lift $ pullPickle (xpEither failurePickle challengePickle) case challenge2 of - Left x -> error $ show x + Left _x -> throwError $ AuthXmlError Right _ -> return () - pushN saslResponse2E - Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pullE - xmppRestartStream + lift $ pushN saslResponse2E + e <- lift pullElement + case e of + Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] -> return () + _ -> throwError AuthXmlError -- TODO: investigate + _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream return () createResponse :: Random.RandomGen g @@ -87,18 +110,19 @@ createResponse :: Random.RandomGen g -> [(BS8.ByteString, BS8.ByteString)] -> Text createResponse g hostname username passwd' pairs = let - Just qop = L.lookup "qop" pairs + Just qop = L.lookup "qop" pairs Just nonce = L.lookup "nonce" pairs - uname = Text.encodeUtf8 username - passwd = Text.encodeUtf8 passwd' - realm = Text.encodeUtf8 hostname - cnonce = BS.tail . BS.init . - B64.encode . BS.pack . take 8 $ Random.randoms g - nc = "00000001" - digestURI = ("xmpp/" `BS.append` realm) - digest = md5Digest + uname = Text.encodeUtf8 username + passwd = Text.encodeUtf8 passwd' + -- Using Int instead of Word8 for random 1.0.0.0 (GHC 7) + -- compatibility. + cnonce = BS.tail . BS.init . + B64.encode . BS.pack . map toWord8 . take 8 $ Random.randoms g + nc = "00000001" + digestURI = ("xmpp/" `BS.append` (Text.encodeUtf8 hostname)) + digest = md5Digest uname - realm + (lookup "realm" pairs) passwd digestURI nc @@ -106,19 +130,23 @@ createResponse g hostname username passwd' pairs = let nonce cnonce response = BS.intercalate"," . map (BS.intercalate "=") $ - [["username" , quote uname ] - ,["realm" , quote realm ] - ,["nonce" , quote nonce ] - ,["cnonce" , quote cnonce ] - ,["nc" , nc ] - ,["qop" , qop ] - ,["digest-uri", quote digestURI ] - ,["response" , digest ] - ,["charset" , "utf-8" ] + [ ["username" , quote uname ]] + ++ case L.lookup "realm" pairs of + Just realm -> [["realm" , quote realm ]] + Nothing -> [] + ++ + [ ["nonce" , quote nonce ] + , ["cnonce" , quote cnonce ] + , ["nc" , nc ] + , ["qop" , qop ] + , ["digest-uri", quote digestURI ] + , ["response" , digest ] + , ["charset" , "utf-8" ] ] in Text.decodeUtf8 $ B64.encode response where quote x = BS.concat ["\"",x,"\""] + toWord8 x = fromIntegral (x :: Int) :: Word8 toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)] toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do @@ -138,13 +166,14 @@ hashRaw :: [BS8.ByteString] -> BS8.ByteString hashRaw = toStrict . Binary.encode . (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":") + toStrict :: BL.ByteString -> BS8.ByteString toStrict = BS.concat . BL.toChunks -- TODO: this only handles MD5-sess md5Digest :: BS8.ByteString - -> BS8.ByteString + -> Maybe BS8.ByteString -> BS8.ByteString -> BS8.ByteString -> BS8.ByteString @@ -153,16 +182,29 @@ md5Digest :: BS8.ByteString -> BS8.ByteString -> BS8.ByteString md5Digest uname realm password digestURI nc qop nonce cnonce= - let ha1 = hash [hashRaw [uname,realm,password], nonce, cnonce] + let ha1 = hash [hashRaw [uname, maybe "" id realm, password], nonce, cnonce] ha2 = hash ["AUTHENTICATE", digestURI] in hash [ha1,nonce, nc, cnonce,qop,ha2] - -- Pickling +failurePickle :: PU [Node] (SaslFailure) +failurePickle = xpWrap (\(txt,(failure,_,_)) + -> SaslFailure failure txt) + (\(SaslFailure failure txt) + -> (txt,(failure,(),()))) + (xpElemNodes + "{urn:ietf:params:xml:ns:xmpp-sasl}failure" + (xp2Tuple + (xpOption $ xpElem + "{urn:ietf:params:xml:ns:xmpp-sasl}text" + xpLangTag + (xpContent xpId)) + (xpElemByNamespace + "urn:ietf:params:xml:ns:xmpp-sasl" + xpPrim + (xpUnit) + (xpUnit)))) -failurePickle :: PU [Node] (Element) -failurePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}failure" - (xpIsolate xpElemVerbatim) challengePickle :: PU [Node] Text.Text challengePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" diff --git a/src/Network/XMPP/Session.hs b/src/Network/XMPP/Session.hs index 7b37a44..e164987 100644 --- a/src/Network/XMPP/Session.hs +++ b/src/Network/XMPP/Session.hs @@ -8,15 +8,14 @@ import Data.XML.Types(Element) import Network.XMPP.Monad import Network.XMPP.Pickle import Network.XMPP.Types +import Network.XMPP.Concurrent + sessionXML :: Element sessionXML = pickleElem (xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session" ) () - - - sessionIQ :: Stanza sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" , iqRequestFrom = Nothing @@ -26,10 +25,17 @@ sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" , iqRequestPayload = sessionXML } -xmppSession :: XMPPConMonad () -xmppSession = do - push $ sessionIQ - answer <- pull - let IQResultS (IQResult "sess" Nothing Nothing _lang _body) = answer - return () +xmppStartSession :: XMPPConMonad () +xmppStartSession = do + answer <- xmppSendIQ' "session" Nothing Set Nothing sessionXML + case answer of + Left e -> error $ show e + Right _ -> return () + +startSession :: XMPP () +startSession = do + answer <- sendIQ' Nothing Set Nothing sessionXML + case answer of + Left e -> error $ show e + Right _ -> return () diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index 6f750e4..80f3462 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -3,13 +3,11 @@ module Network.XMPP.Stream where -import Control.Applicative((<$>)) -import Control.Exception(throwIO) -import Control.Monad(unless) import Control.Monad.Error import Control.Monad.State.Strict import Data.Conduit +import Data.Conduit.BufferedSource import Data.Conduit.List as CL import Data.Text as T import Data.XML.Pickle @@ -30,7 +28,7 @@ streamUnpickleElem :: PU [Node] a -> ErrorT StreamError (Pipe Event Void IO) a streamUnpickleElem p x = do case unpickleElem p x of - Left l -> throwError $ StreamUnpickleError l + Left l -> throwError $ StreamXMLError l Right r -> return r type StreamSink a = ErrorT StreamError (Pipe Event Void IO) a @@ -58,14 +56,14 @@ xmppStartStream = runErrorT $ do Nothing -> throwError StreamConnectionError Just hostname -> lift . pushOpen $ pickleElem pickleStream ("1.0",Nothing, Just hostname) - features <- ErrorT . pulls $ runErrorT xmppStream + features <- ErrorT . pullSink $ runErrorT xmppStream modify (\s -> s {sFeatures = features}) return () xmppRestartStream :: XMPPConMonad (Either StreamError ()) xmppRestartStream = do raw <- gets sRawSrc - let newsrc = raw $= XP.parseBytes def + newsrc <- liftIO . bufferSource $ raw $= XP.parseBytes def modify (\s -> s{sConSrc = newsrc}) xmppStartStream diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index 7b9f159..d4b8ce0 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -3,30 +3,20 @@ module Network.XMPP.TLS where -import Control.Applicative((<$>)) -import Control.Arrow(left) import qualified Control.Exception.Lifted as Ex import Control.Monad import Control.Monad.Error import Control.Monad.State.Strict -import Control.Monad.Trans -import Data.Conduit -import Data.Conduit.List as CL import Data.Conduit.TLS as TLS -import Data.Default import Data.Typeable import Data.XML.Types -import qualified Network.TLS as TLS -import qualified Network.TLS.Extra as TLS import Network.XMPP.Monad +import Network.XMPP.Pickle(ppElement) import Network.XMPP.Stream import Network.XMPP.Types -import qualified Text.XML.Stream.Render as XR - - starttlsE :: Element starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] @@ -41,10 +31,11 @@ exampleParams = TLS.defaultParams , pUseSecureRenegotiation = False -- No renegotiation , pCertificates = [] -- TODO , pLogging = TLS.defaultLogging -- TODO - , onCertificatesRecv = \ certificate -> + , onCertificatesRecv = \ _certificate -> return TLS.CertificateUsageAccept } +-- | Error conditions that may arise during TLS negotiation. data XMPPTLSError = TLSError TLSError | TLSNoServerSupport | TLSNoConnection @@ -53,29 +44,32 @@ data XMPPTLSError = TLSError TLSError instance Error XMPPTLSError where noMsg = TLSNoConnection -- TODO: What should we choose here? -instance Ex.Exception XMPPTLSError - -xmppStartTLS :: TLS.TLSParams -> XMPPConMonad (Either XMPPTLSError ()) -xmppStartTLS params = Ex.handle (return . Left . TLSError) +startTLS :: TLS.TLSParams -> XMPPConMonad (Either XMPPTLSError ()) +startTLS params = Ex.handle (return . Left . TLSError) . runErrorT $ do features <- lift $ gets sFeatures handle' <- lift $ gets sConHandle handle <- maybe (throwError TLSNoConnection) return handle' when (stls features == Nothing) $ throwError TLSNoServerSupport lift $ pushN starttlsE - answer <- lift $ pullE + answer <- lift $ pullElement case answer of Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return () - _ -> throwError $ TLSStreamError StreamXMLError - (raw, snk, psh) <- lift $ TLS.tlsinit params handle + Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _ + -> lift . Ex.throwIO $ StreamConnectionError + -- TODO: find something more suitable + e -> lift . Ex.throwIO . StreamXMLError + $ "Unexpected element: " ++ ppElement e + (raw, _snk, psh, ctx) <- lift $ TLS.tlsinit params handle lift $ modify (\x -> x { sRawSrc = raw -- , sConSrc = -- Note: this momentarily leaves us in an -- inconsistent state , sConPushBS = psh + , sCloseConnection = TLS.bye ctx >> sCloseConnection x }) - ErrorT $ (left TLSStreamError) <$> xmppRestartStream - modify (\s -> s{sHaveTLS = True}) + either (lift . Ex.throwIO) return =<< lift xmppRestartStream + modify (\s -> s{sConnectionState = XmppConnectionSecured}) return () diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index a3e827c..1c86f07 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -11,7 +11,42 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.XMPP.Types where +module Network.XMPP.Types + ( IQError(..) + , IQRequest(..) + , IQRequestType(..) + , IQResponse + , IQResult(..) + , IdGenerator(..) + , LangTag (..) + , Message(..) + , MessageError(..) + , MessageType(..) + , Presence(..) + , PresenceError(..) + , PresenceType(..) + , SaslError(..) + , SaslFailure(..) + , ServerAddress(..) + , ServerFeatures(..) + , ShowType(..) + , Stanza(..) + , StanzaError(..) + , StanzaErrorCondition(..) + , StanzaErrorType(..) + , StanzaId(..) + , StreamError(..) + , Version(..) + , XMPPConMonad + , XmppConnection(..) + , XmppConnectionState(..) + , XmppNoConnection(..) + , XMPPT(..) + , XmppStreamError(..) + , parseLangTag + , module Network.XMPP.JID + ) + where -- import Network.XMPP.Utilities (idGenerator) @@ -24,7 +59,6 @@ import Control.Monad.Error import qualified Data.ByteString as BS import Data.Conduit -import Data.List.Split as L import Data.String(IsString(..)) import Data.Text (Text) import qualified Data.Text as Text @@ -33,16 +67,9 @@ import Data.XML.Types import qualified Network as N -import System.IO - - --- | The string prefix MUST be - -data SessionSettings = - SessionSettings { ssIdPrefix :: String - , ssIdGenerator :: IdGenerator - , ssStreamLang :: LangTag } +import Network.XMPP.JID +import System.IO -- ============================================================================= -- STANZA TYPES @@ -74,38 +101,6 @@ instance Read StanzaId where instance IsString StanzaId where fromString = SI . Text.pack --- | --- @From@ is a readability type synonym for @Address@. - --- | Jabber ID (JID) datatype -data JID = JID { localpart :: !(Maybe Text) - -- ^ Account name - , domainpart :: !Text - -- ^ Server adress - , resourcepart :: !(Maybe Text) - -- ^ Resource name - } - -instance Show JID where - show (JID nd dmn res) = - maybe "" ((++ "@") . Text.unpack) nd ++ - (Text.unpack dmn) ++ - maybe "" (('/' :) . Text.unpack) res - -parseJID :: [Char] -> [JID] -parseJID jid = do - (jid', rst) <- case L.splitOn "@" jid of - [rest] -> [(JID Nothing, rest)] - [nd,rest] -> [(JID (Just (Text.pack nd)), rest)] - _ -> [] - case L.splitOn "/" rst of - [dmn] -> [jid' (Text.pack dmn) Nothing] - [dmn, rsrc] -> [jid' (Text.pack dmn) (Just (Text.pack rsrc))] - _ -> [] - -instance Read JID where - readsPrec _ x = (,"") <$> parseJID x - -- An Info/Query (IQ) stanza is either of the type "request" ("get" or -- "set") or "response" ("result" or "error"). The @IQ@ type wraps -- these two sub-types. @@ -120,14 +115,11 @@ data Stanza = IQRequestS IQRequest | MessageErrorS MessageError | PresenceS Presence | PresenceErrorS PresenceError + deriving Show -- | -- A "request" Info/Query (IQ) stanza is one with either "get" or -- "set" as type. They are guaranteed to always contain a payload. --- --- Objects of this type cannot be generated by Pontarius applications, --- but are only created internally. - data IQRequest = IQRequest { iqRequestID :: StanzaId , iqRequestFrom :: Maybe JID , iqRequestTo :: Maybe JID @@ -137,7 +129,7 @@ data IQRequest = IQRequest { iqRequestID :: StanzaId } deriving (Show) - +-- | The type of request that is made data IQRequestType = Get | Set deriving (Eq, Ord) instance Show IQRequestType where @@ -149,21 +141,12 @@ instance Read IQRequestType where readsPrec _ "set" = [(Set, "")] readsPrec _ _ = [] - --- | --- A "response" Info/Query (IQ) stanza is one with either "result" or --- "error" as type. We have devided IQ responses into two types. --- --- Objects of this type cannot be generated by Pontarius applications, --- but are only created internally. +-- | A "response" Info/Query (IQ) stanza is eitheran 'IQError' or an IQ stanza +-- with the type "result" ('IQResult') type IQResponse = Either IQError IQResult - --- | --- Objects of this type cannot be generated by Pontarius applications, --- but are only created internally. - +-- | The answer to an IQ request data IQResult = IQResult { iqResultID :: StanzaId , iqResultFrom :: Maybe JID , iqResultTo :: Maybe JID @@ -171,11 +154,7 @@ data IQResult = IQResult { iqResultID :: StanzaId , iqResultPayload :: Maybe Element } deriving (Show) - --- | --- Objects of this type cannot be generated by Pontarius applications, --- but are only created internally. - +-- | The answer to an IQ request that generated an error data IQError = IQError { iqErrorID :: StanzaId , iqErrorFrom :: Maybe JID , iqErrorTo :: Maybe JID @@ -185,12 +164,7 @@ data IQError = IQError { iqErrorID :: StanzaId } deriving (Show) --- | --- A non-error message stanza. --- --- Objects of this type cannot be generated by Pontarius applications, --- but are only created internally. - +-- | The message stanza. Used for /push/ type communication data Message = Message { messageID :: Maybe StanzaId , messageFrom :: Maybe JID , messageTo :: Maybe JID @@ -203,13 +177,7 @@ data Message = Message { messageID :: Maybe StanzaId } deriving (Show) - --- | --- An error message stanza. --- --- Objects of this type cannot be generated by Pontarius applications, --- but are only created internally. - +-- | An error stanza generated in response to a 'Message' data MessageError = MessageError { messageErrorID :: Maybe StanzaId , messageErrorFrom :: Maybe JID , messageErrorTo :: Maybe JID @@ -220,15 +188,47 @@ data MessageError = MessageError { messageErrorID :: Maybe StanzaId deriving (Show) --- | --- @MessageType@ holds XMPP message types as defined in XMPP-IM. The --- "error" message type is left out as errors are wrapped in --- @MessageError@. - -data MessageType = Chat | -- ^ - GroupChat | -- ^ - Headline | -- ^ - Normal -- ^ The default message type +-- | The type of a Message being sent +-- () +data MessageType = -- | The message is sent in the context of a one-to-one chat + -- session. Typically an interactive client will present a + -- message of type /chat/ in an interface that enables + -- one-to-one chat between the two parties, including an + -- appropriate conversation history. + Chat + -- | The message is sent in the context of a + -- multi-user chat environment (similar to that of + -- @IRC@). Typically a receiving client will + -- present a message of type /groupchat/ in an + -- interface that enables many-to-many chat + -- between the parties, including a roster of + -- parties in the chatroom and an appropriate + -- conversation history. + | GroupChat + -- | The message provides an alert, a + -- notification, or other transient information to + -- which no reply is expected (e.g., news + -- headlines, sports updates, near-real-time + -- market data, or syndicated content). Because no + -- reply to the message is expected, typically a + -- receiving client will present a message of type + -- /headline/ in an interface that appropriately + -- differentiates the message from standalone + -- messages, chat messages, and groupchat messages + -- (e.g., by not providing the recipient with the + -- ability to reply). + | Headline + -- | The message is a standalone message that is + -- sent outside the context of a one-to-one + -- conversation or groupchat, and to which it is + -- expected that the recipient will + -- reply. Typically a receiving client will + -- present a message of type /normal/ in an + -- interface that enables the recipient to reply, + -- but without a conversation history. + -- + -- This is the /default/ value + | Normal deriving (Eq) @@ -341,7 +341,6 @@ instance Read ShowType where -- wrapped in the @StanzaError@ type. -- TODO: Sender XML is (optional and is) not included. - data StanzaError = StanzaError { stanzaErrorType :: StanzaErrorType , stanzaErrorCondition :: StanzaErrorCondition , stanzaErrorText :: Maybe (Maybe LangTag, Text) @@ -471,81 +470,172 @@ instance Read StanzaErrorCondition where -- OTHER STUFF -- ============================================================================= -data SASLFailure = SASLFailure { saslFailureCondition :: SASLError - , saslFailureText :: Maybe Text } -- TODO: XMLLang +data SaslFailure = SaslFailure { saslFailureCondition :: SaslError + , saslFailureText :: Maybe ( Maybe LangTag + , Text + ) + } deriving Show -data SASLError = -- SASLAborted | -- Client aborted - should not happen - SASLAccountDisabled | -- ^ The account has been temporarily - -- disabled - SASLCredentialsExpired | -- ^ The authentication failed because +data SaslError = SaslAborted -- ^ Client aborted + | SaslAccountDisabled -- ^ The account has been temporarily + -- disabled + | SaslCredentialsExpired -- ^ The authentication failed because -- the credentials have expired - SASLEncryptionRequired | -- ^ The mechanism requested cannot be + | SaslEncryptionRequired -- ^ The mechanism requested cannot be -- used the confidentiality and -- integrity of the underlying -- stream is protected (typically -- with TLS) - -- SASLIncorrectEncoding | -- The base64 encoding is incorrect - -- - should not happen - -- SASLInvalidAuthzid | -- The authzid has an incorrect format, - -- or the initiating entity does not - -- have the appropriate permissions to - -- authorize that ID - SASLInvalidMechanism | -- ^ The mechanism is not supported by - -- the receiving entity - -- SASLMalformedRequest | -- Invalid syntax - should not happen - SASLMechanismTooWeak | -- ^ The receiving entity policy - -- requires a stronger mechanism - SASLNotAuthorized (Maybe Text) | -- ^ Invalid credentials - -- provided, or some - -- generic authentication - -- failure has occurred - SASLTemporaryAuthFailure -- ^ There receiving entity reported a + | SaslIncorrectEncoding -- ^ The base64 encoding is incorrect + | SaslInvalidAuthzid -- ^ The authzid has an incorrect + -- format or the initiating entity does + -- not have the appropriate permissions + -- to authorize that ID + | SaslInvalidMechanism -- ^ The mechanism is not supported by + -- the receiving entity + | SaslMalformedRequest -- ^ Invalid syntax + | SaslMechanismTooWeak -- ^ The receiving entity policy + -- requires a stronger mechanism + | SaslNotAuthorized -- ^ Invalid credentials + -- provided, or some + -- generic authentication + -- failure has occurred + | SaslTemporaryAuthFailure -- ^ There receiving entity reported a -- temporary error condition; the -- initiating entity is recommended -- to try again later +instance Show SaslError where + show SaslAborted = "aborted" + show SaslAccountDisabled = "account-disabled" + show SaslCredentialsExpired = "credentials-expired" + show SaslEncryptionRequired = "encryption-required" + show SaslIncorrectEncoding = "incorrect-encoding" + show SaslInvalidAuthzid = "invalid-authzid" + show SaslInvalidMechanism = "invalid-mechanism" + show SaslMalformedRequest = "malformed-request" + show SaslMechanismTooWeak = "mechanism-too-weak" + show SaslNotAuthorized = "not-authorized" + show SaslTemporaryAuthFailure = "temporary-auth-failure" + +instance Read SaslError where + readsPrec _ "aborted" = [(SaslAborted , "")] + readsPrec _ "account-disabled" = [(SaslAccountDisabled , "")] + readsPrec _ "credentials-expired" = [(SaslCredentialsExpired , "")] + readsPrec _ "encryption-required" = [(SaslEncryptionRequired , "")] + readsPrec _ "incorrect-encoding" = [(SaslIncorrectEncoding , "")] + readsPrec _ "invalid-authzid" = [(SaslInvalidAuthzid , "")] + readsPrec _ "invalid-mechanism" = [(SaslInvalidMechanism , "")] + readsPrec _ "malformed-request" = [(SaslMalformedRequest , "")] + readsPrec _ "mechanism-too-weak" = [(SaslMechanismTooWeak , "")] + readsPrec _ "not-authorized" = [(SaslNotAuthorized , "")] + readsPrec _ "temporary-auth-failure" = [(SaslTemporaryAuthFailure , "")] + readsPrec _ _ = [] -- | Readability type for host name Texts. -- type HostName = Text -- This is defined in Network as well - --- | Readability type for port number Integers. - -type PortNumber = Integer -- We use N(etwork).PortID (PortNumber) internally - - --- | Readability type for user name Texts. - -type UserName = Text - - --- | Readability type for password Texts. - -type Password = Text - - --- | Readability type for (Address) resource identifier Texts. - -type Resource = Text - - -type StreamID = Text - - data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq) -type Timeout = Int - -data StreamError = StreamError String +-- TODO: document the error cases +data StreamErrorCondition = StreamBadFormat + | StreamBadNamespacePrefix + | StreamConflict + | StreamConnectionTimeout + | StreamHostGone + | StreamHostUnknown + | StreamImproperAddressing + | StreamInternalServerError + | StreamInvalidFrom + | StreamInvalidNamespace + | StreamInvalidXml + | StreamNotAuthorized + | StreamNotWellFormed + | StreamPolicyViolation + | StreamRemoteConnectionFailed + | StreamReset + | StreamResourceConstraint + | StreamRestrictedXml + | StreamSeeOtherHost + | StreamSystemShutdown + | StreamUndefinedCondition + | StreamUnsupportedEncoding + | StreamUnsupportedFeature + | StreamUnsupportedStanzaType + | StreamUnsupportedVersion + deriving Eq + +instance Show StreamErrorCondition where + show StreamBadFormat = "bad-format" + show StreamBadNamespacePrefix = "bad-namespace-prefix" + show StreamConflict = "conflict" + show StreamConnectionTimeout = "connection-timeout" + show StreamHostGone = "host-gone" + show StreamHostUnknown = "host-unknown" + show StreamImproperAddressing = "improper-addressing" + show StreamInternalServerError = "internal-server-error" + show StreamInvalidFrom = "invalid-from" + show StreamInvalidNamespace = "invalid-namespace" + show StreamInvalidXml = "invalid-xml" + show StreamNotAuthorized = "not-authorized" + show StreamNotWellFormed = "not-well-formed" + show StreamPolicyViolation = "policy-violation" + show StreamRemoteConnectionFailed = "remote-connection-failed" + show StreamReset = "reset" + show StreamResourceConstraint = "resource-constraint" + show StreamRestrictedXml = "restricted-xml" + show StreamSeeOtherHost = "see-other-host" + show StreamSystemShutdown = "system-shutdown" + show StreamUndefinedCondition = "undefined-condition" + show StreamUnsupportedEncoding = "unsupported-encoding" + show StreamUnsupportedFeature = "unsupported-feature" + show StreamUnsupportedStanzaType = "unsupported-stanza-type" + show StreamUnsupportedVersion = "unsupported-version" + +instance Read StreamErrorCondition where + readsPrec _ "bad-format" = [(StreamBadFormat , "")] + readsPrec _ "bad-namespace-prefix" = [(StreamBadNamespacePrefix , "")] + readsPrec _ "conflict" = [(StreamConflict , "")] + readsPrec _ "connection-timeout" = [(StreamConnectionTimeout , "")] + readsPrec _ "host-gone" = [(StreamHostGone , "")] + readsPrec _ "host-unknown" = [(StreamHostUnknown , "")] + readsPrec _ "improper-addressing" = [(StreamImproperAddressing , "")] + readsPrec _ "internal-server-error" = [(StreamInternalServerError , "")] + readsPrec _ "invalid-from" = [(StreamInvalidFrom , "")] + readsPrec _ "invalid-namespace" = [(StreamInvalidNamespace , "")] + readsPrec _ "invalid-xml" = [(StreamInvalidXml , "")] + readsPrec _ "not-authorized" = [(StreamNotAuthorized , "")] + readsPrec _ "not-well-formed" = [(StreamNotWellFormed , "")] + readsPrec _ "policy-violation" = [(StreamPolicyViolation , "")] + readsPrec _ "remote-connection-failed" = [(StreamRemoteConnectionFailed , "")] + readsPrec _ "reset" = [(StreamReset , "")] + readsPrec _ "resource-constraint" = [(StreamResourceConstraint , "")] + readsPrec _ "restricted-xml" = [(StreamRestrictedXml , "")] + readsPrec _ "see-other-host" = [(StreamSeeOtherHost , "")] + readsPrec _ "system-shutdown" = [(StreamSystemShutdown , "")] + readsPrec _ "undefined-condition" = [(StreamUndefinedCondition , "")] + readsPrec _ "unsupported-encoding" = [(StreamUnsupportedEncoding , "")] + readsPrec _ "unsupported-feature" = [(StreamUnsupportedFeature , "")] + readsPrec _ "unsupported-stanza-type" = [(StreamUnsupportedStanzaType , "")] + readsPrec _ "unsupported-version" = [(StreamUnsupportedVersion , "")] + readsPrec _ _ = [(StreamUndefinedCondition , "")] + +data XmppStreamError = XmppStreamError + { errorCondition :: StreamErrorCondition + , errorText :: Maybe (Maybe LangTag, Text) + , errorXML :: Maybe Element + } deriving (Show, Eq) + + +data StreamError = StreamError XmppStreamError | StreamWrongVersion Text - | StreamXMLError - | StreamUnpickleError String + | StreamXMLError String | StreamConnectionError deriving (Show, Eq, Typeable) instance Exception StreamError -instance Error StreamError where strMsg = StreamError +instance Error StreamError where noMsg = StreamConnectionError -- ============================================================================= -- XML TYPES @@ -610,24 +700,32 @@ instance Read LangTag where -- all (\ (a, b) -> map toLower a == map toLower b) $ zip as bs -- | otherwise = False - - data ServerFeatures = SF { stls :: Maybe Bool , saslMechanisms :: [Text.Text] , other :: [Element] } deriving Show -data XMPPConState = XMPPConState - { sConSrc :: Source IO Event - , sRawSrc :: Source IO BS.ByteString - , sConPushBS :: BS.ByteString -> IO () - , sConHandle :: Maybe Handle - , sFeatures :: ServerFeatures - , sHaveTLS :: Bool - , sHostname :: Maybe Text - , sUsername :: Maybe Text - , sResource :: Maybe Text +data XmppConnectionState = XmppConnectionClosed -- ^ No connection at + -- this point + | XmppConnectionPlain -- ^ Connection + -- established, but + -- not secured + | XmppConnectionSecured -- ^ Connection + -- established and + -- secured via TLS +data XmppConnection = XmppConnection + { sConSrc :: Source IO Event + , sRawSrc :: Source IO BS.ByteString + , sConPushBS :: BS.ByteString -> IO () + , sConHandle :: Maybe Handle + , sFeatures :: ServerFeatures + , sConnectionState :: XmppConnectionState + , sHostname :: Maybe Text + , sUsername :: Maybe Text + , sResource :: Maybe Text + , sCloseConnection :: IO () + -- TODO: add default Language } -- | @@ -635,14 +733,14 @@ data XMPPConState = XMPPConState -- work with Pontarius. Pontarius clients needs to operate in this -- context. -newtype XMPPT m a = XMPPT { runXMPPT :: StateT XMPPConState m a } deriving (Monad, MonadIO) +newtype XMPPT m a = XMPPT { runXMPPT :: StateT XmppConnection m a } deriving (Monad, MonadIO) -type XMPPConMonad a = StateT XMPPConState IO a +type XMPPConMonad a = StateT XmppConnection IO a -- Make XMPPT derive the Monad and MonadIO instances. -deriving instance (Monad m, MonadIO m) => MonadState (XMPPConState) (XMPPT m) +deriving instance (Monad m, MonadIO m) => MonadState (XmppConnection) (XMPPT m) +data XmppNoConnection = XmppNoConnection deriving (Show, Typeable) +instance Exception XmppNoConnection --- We need a channel because multiple threads needs to append events, --- and we need to wait for events when there are none. diff --git a/src/Network/XMPP/Utilities.hs b/src/Network/XMPP/Utilities.hs index 8e53b7c..7be7b6a 100644 --- a/src/Network/XMPP/Utilities.hs +++ b/src/Network/XMPP/Utilities.hs @@ -1,64 +1,62 @@ --- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the --- Pontarius distribution for more details. +-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the Pontarius +-- distribution for more details. --- This module currently converts XML elements to strings. - --- TODO: Use -fno-cse? http://cvs.haskell.org/Hugs/pages/libraries/base/System-IO-Unsafe.html --- TODO: Remove elementsToString? +-- TODO: More efficient to use Text instead of Strings for ID generation? {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-} -module Network.XMPP.Utilities ( idGenerator - , nextId - -- elementToString - -- , elementsToString ) where - ) where +module Network.XMPP.Utilities (idGenerator) where import Network.XMPP.Types -import Prelude hiding (concat) - -import Data.ByteString (ByteString, concat) -import Data.ByteString.Char8 (unpack) - -import Data.Enumerator (($$), Stream (Chunks), Enumerator, Step (Continue), joinI, run_, returnI) -import Data.Enumerator.List (consume) - -import Data.XML.Types (Document (..), Element (..), Event (..), Name (..), Prologue (..)) - -import Data.IORef (atomicModifyIORef, newIORef) - +import Control.Monad.STM +import Control.Concurrent.STM.TVar +import Prelude +import Control.Applicative (many) --- import Text.XML.Enumerator.Render (renderBytes) --- import Text.XML.Enumerator.Document (toEvents) - -import System.IO.Unsafe (unsafePerformIO) +import qualified Data.Attoparsec.Text as AP +import qualified Data.Text as Text -- | --- Creates a new stanza "IdGenerator". Internally, it will maintain an infinite --- list of stanza IDs ('[\'a\', \'b\', \'c\'...]'). +-- 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 :: String -> IO IdGenerator +idGenerator :: Text.Text -> IO IdGenerator -idGenerator p = newIORef (ids p) >>= \ ioRef -> return $ IdGenerator ioRef +idGenerator prefix = atomically $ do + tvar <- newTVar $ ids prefix + return $ IdGenerator $ next tvar where - -- Generates an infinite and predictable list of IDs, all - -- beginning with the provided prefix. + -- 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. - ids :: String -> [String] + ids :: Text.Text -> [Text.Text] -- Adds the prefix to all combinations of IDs (ids'). - ids p = map (\ id -> p ++ id) ids' + ids p = map (\ id -> Text.append p id) ids' where -- Generate all combinations of IDs, with increasing length. - ids' :: [String] - ids' = concatMap ids'' [1..] + ids' :: [Text.Text] + ids' = map Text.pack $ concatMap ids'' [1..] -- Generates all combinations of IDs with the given length. ids'' :: Integer -> [String] @@ -70,46 +68,53 @@ idGenerator p = newIORef (ids p) >>= \ ioRef -> return $ IdGenerator ioRef repertoire = ['a'..'z'] - --- | --- Extracts an ID from the "IDGenerator", and updates the generators internal --- state so that the same ID will not be generated again. - -nextId :: IdGenerator -> IO String - -nextId g = let IdGenerator ioRef = g - in atomicModifyIORef ioRef (\ (i:is) -> (is, i)) - - - --- Converts the Element objects to a document, converts it into Events, strips --- the DocumentBegin event, generates a ByteString, and converts it into a --- String, aggregates the results and returns a string. - --- elementsToString :: [Element] -> String - --- elementsToString [] = "" --- elementsToString (e:es) = (elementToString (Just e)) ++ (elementsToString es) - - --- Converts the Element object to a document, converts it into Events, strips --- the DocumentBegin event, generates a ByteString, and converts it into a --- String. - --- {-# NOINLINE elementToString #-} - --- elementToString :: Maybe Element -> String - --- elementToString Nothing = "" --- elementToString (Just elem) = unpack $ concat $ unsafePerformIO $ do --- r <- run_ $ events $$ (joinI $ renderBytes $$ consume) --- return r --- where - - -- Enumerator that "produces" the events to convert to the document --- events :: Enumerator Event IO [ByteString] --- events (Continue more) = more $ Chunks (tail $ toEvents $ dummyDoc elem) --- events step = returnI step - --- dummyDoc :: Element -> Document --- dummyDoc e = Document (Prologue [] Nothing []) elem [] +-- Converts a "." numeric version number to a @Version@ object. +versionFromString :: Text.Text -> Maybe Version +versionFromString s = case AP.parseOnly versionParser s of + Right version -> Just version + Left _ -> Nothing + + +-- Constructs a "Version" based on the major and minor version numbers. +versionFromNumbers :: Integer -> Integer -> Version +versionFromNumbers major minor = Version major minor + + +-- Read numbers, a dot, more numbers, and end-of-file. +versionParser :: AP.Parser Version +versionParser = do + major <- AP.many1 AP.digit + AP.skip (== '.') + minor <- AP.many1 AP.digit + AP.endOfInput + return $ Version (read major) (read minor) + + +-- | Parses, validates, and possibly constructs a "LangTag" object. +langTag :: Text.Text -> Maybe LangTag +langTag s = case AP.parseOnly langTagParser s of + Right tag -> Just tag + Left _ -> Nothing + + +-- Parses a language tag as defined by RFC 1766 and constructs a LangTag object. +langTagParser :: AP.Parser LangTag +langTagParser = do + -- Read until we reach a '-' character, or EOF. This is the `primary tag'. + primTag <- tag + -- Read zero or more subtags. + subTags <- many subtag + AP.endOfInput + return $ LangTag primTag subTags + where + tag :: AP.Parser Text.Text + tag = do + t <- AP.takeWhile1 $ AP.inClass tagChars + return t + subtag :: AP.Parser Text.Text + subtag = do + AP.skip (== '-') + subtag <- tag + return subtag + tagChars :: [Char] + tagChars = ['a'..'z'] ++ ['A'..'Z'] \ No newline at end of file diff --git a/src/Tests.hs b/src/Tests.hs index 07b5602..d0b8c25 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -28,13 +28,17 @@ supervisor :: JID supervisor = read "uart14@species64739.dyndns.org" -attXmpp :: STM a -> XMPPThread a +attXmpp :: STM a -> XMPP a attXmpp = liftIO . atomically testNS :: Text testNS = "xmpp:library:test" -data Payload = Payload Int Bool Text deriving (Eq, Show) +data Payload = Payload + { payloadCounter ::Int + , payloadFlag :: Bool + , payloadText :: Text + } deriving (Eq, Show) payloadP = xpWrap (\((counter,flag) , message) -> Payload counter flag message) (\(Payload counter flag message) ->((counter,flag) , message)) $ @@ -49,17 +53,20 @@ payloadP = xpWrap (\((counter,flag) , message) -> Payload counter flag message) invertPayload (Payload count flag message) = Payload (count + 1) (not flag) (Text.reverse message) iqResponder = do - (free, chan) <- listenIQChan Get testNS - unless free $ liftIO $ putStrLn "Channel was already taken" - >> error "hanging up" + chan' <- listenIQChan Get testNS + chan <- case chan' of + Nothing -> liftIO $ putStrLn "Channel was already taken" + >> error "hanging up" + Just c -> return c forever $ do next@(iq,_) <- liftIO . atomically $ readTChan chan let Right payload = unpickleElem payloadP $ iqRequestPayload iq let answerPayload = invertPayload payload let answerBody = pickleElem payloadP answerPayload answerIQ next (Right $ Just answerBody) + when (payloadCounter payload == 10) endSession -autoAccept :: XMPPThread () +autoAccept :: XMPP () autoAccept = forever $ do st <- waitForPresence isPresenceSubscribe sendPresence $ presenceSubscribed (fromJust $ presenceFrom st) @@ -84,33 +91,39 @@ runMain debug number = do _ -> error "Need either 1 or 2" let debug' = liftIO . atomically . debug . (("Thread " ++ show number ++ ":") ++) - xmppNewSession $ do + wait <- newEmptyTMVarIO + withNewSession $ do + setSessionEndHandler (liftIO . atomically $ putTMVar wait ()) debug' "running" withConnection $ do - xmppConnect "localhost" "species64739.dyndns.org" - xmppStartTLS exampleParams - saslResponse <- xmppSASL (fromJust $ localpart we) "pwd" - case saslResponse of - Right _ -> return () - Left e -> error e - xmppThreadedBind (resourcepart we) - withConnection $ xmppSession - debug' "session standing" + connect "localhost" "species64739.dyndns.org" + startTLS exampleParams + saslResponse <- auth (fromJust $ localpart we) "pwd" (resourcepart we) + case saslResponse of + Right _ -> return () + Left e -> error $ show e + debug' "session standing" sendPresence presenceOnline - forkXMPP autoAccept - forkXMPP iqResponder - when active . void . forkXMPP $ do - forM [1..10] $ \count -> do - let message = Text.pack . show $ localpart we - let payload = Payload count (even count) (Text.pack $ show count) - let body = pickleElem payloadP payload - Right answer <- sendIQ' (Just them) Get Nothing body - let Right answerPayload = unpickleElem payloadP - (fromJust $ iqResultPayload answer) - expect debug' (invertPayload payload) answerPayload - liftIO $ threadDelay 100000 - sendUser "All tests done" - liftIO . forever $ threadDelay 10000000 + fork autoAccept + sendPresence $ presenceSubscribe them + fork iqResponder + when active $ do + liftIO $ threadDelay 1000000 -- Wait for the other thread to go online + void . fork $ do + forM [1..10] $ \count -> do + let message = Text.pack . show $ localpart we + let payload = Payload count (even count) (Text.pack $ show count) + let body = pickleElem payloadP payload + debug' "sending" + Right answer <- sendIQ' (Just them) Get Nothing body + debug' "received" + let Right answerPayload = unpickleElem payloadP + (fromJust $ iqResultPayload answer) + expect debug' (invertPayload payload) answerPayload + liftIO $ threadDelay 100000 + sendUser "All tests done" + endSession + liftIO . atomically $ takeTMVar wait return () return () diff --git a/src/Text/XML/Stream/Elements.hs b/src/Text/XML/Stream/Elements.hs index 952854d..4be9ff6 100644 --- a/src/Text/XML/Stream/Elements.hs +++ b/src/Text/XML/Stream/Elements.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} module Text.XML.Stream.Elements where import Control.Applicative ((<$>)) diff --git a/tests/Stanzas.hs b/tests/Stanzas.hs new file mode 100644 index 0000000..23f6250 --- /dev/null +++ b/tests/Stanzas.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} +module Tests.Stanzas where + +import Data.Either +import Data.XML.Types +import Network.XMPP +import Network.XMPP.Marshal +import Network.XMPP.Pickle +import Network.XMPP.Types + +xml1 = Element {elementName = Name {nameLocalName = "iq", nameNamespace = Just "jabber:client", namePrefix = Nothing}, elementAttributes = [(Name {nameLocalName = "id", nameNamespace = Nothing, namePrefix = Nothing},[ContentText "2"]), (Name {nameLocalName = "type", nameNamespace = Nothing, namePrefix = Nothing},[ContentText "error"]),(Name {nameLocalName = "to", nameNamespace = Nothing, namePrefix = Nothing},[ContentText "testuser1@species64739.dyndns.org/bot1"]),(Name {nameLocalName = "from", nameNamespace = Nothing, namePrefix = Nothing},[ContentText "testuser2@species64739.dyndns.org/bot2"])], elementNodes = [NodeElement (Element {elementName = Name {nameLocalName = "error", nameNamespace = Just "jabber:client", namePrefix = Nothing}, elementAttributes = [(Name {nameLocalName = "type", nameNamespace = Nothing, namePrefix = Nothing},[ContentText "cancel"])], elementNodes = [NodeElement (Element {elementName = Name {nameLocalName = "service-unavailable", nameNamespace = Just "urn:ietf:params:xml:ns:xmpp-stanzas", namePrefix = Nothing}, elementAttributes = [], elementNodes = []})]})]} + +isRight (Right _) = True +isRight _ = False + + +testXML1 = isRight $ unpickleElem stanzaP xml1 \ No newline at end of file