diff --git a/import_visualisation-new-full.png b/import_visualisation-new-full.png
new file mode 100644
index 0000000..75b6ba9
Binary files /dev/null and b/import_visualisation-new-full.png differ
diff --git a/import_visualisation-new.png b/import_visualisation-new.png
new file mode 100644
index 0000000..f8c7bdc
Binary files /dev/null and b/import_visualisation-new.png differ
diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal
index 3b71b17..f34e821 100644
--- a/pontarius-xmpp.cabal
+++ b/pontarius-xmpp.cabal
@@ -55,11 +55,9 @@ Library
, stringprep >=0.1.3
, hslogger >=1.1.0
Exposed-modules: Network.Xmpp
- , Network.Xmpp.Connection
+ , Network.Xmpp.Internal
, Network.Xmpp.IM
- Other-modules: Data.Conduit.Tls
- , Network.Xmpp.Bind
- , Network.Xmpp.Concurrent
+ Other-modules: Network.Xmpp.Concurrent
, Network.Xmpp.Concurrent.Types
, Network.Xmpp.Concurrent.Basic
, Network.Xmpp.Concurrent.IQ
@@ -67,14 +65,9 @@ Library
, Network.Xmpp.Concurrent.Presence
, Network.Xmpp.Concurrent.Threads
, Network.Xmpp.Concurrent.Monad
- , Network.Xmpp.Connection_
, Network.Xmpp.IM.Message
, Network.Xmpp.IM.Presence
- , Network.Xmpp.Jid
, Network.Xmpp.Marshal
- , Network.Xmpp.Message
- , Network.Xmpp.Pickle
- , Network.Xmpp.Presence
, Network.Xmpp.Sasl
, Network.Xmpp.Sasl.Common
, Network.Xmpp.Sasl.Mechanisms
@@ -83,12 +76,10 @@ Library
, Network.Xmpp.Sasl.Mechanisms.Scram
, Network.Xmpp.Sasl.StringPrep
, Network.Xmpp.Sasl.Types
- , Network.Xmpp.Session
, Network.Xmpp.Stream
, Network.Xmpp.Tls
, Network.Xmpp.Types
, Network.Xmpp.Xep.ServiceDiscovery
- , Text.Xml.Stream.Elements
GHC-Options: -Wall
Source-Repository head
diff --git a/source/Data/Conduit/Tls.hs b/source/Data/Conduit/Tls.hs
deleted file mode 100644
index 0842ae5..0000000
--- a/source/Data/Conduit/Tls.hs
+++ /dev/null
@@ -1,81 +0,0 @@
-{-# Language NoMonomorphismRestriction #-}
-{-# OPTIONS_HADDOCK hide #-}
-module Data.Conduit.Tls
- ( tlsinit
--- , conduitStdout
- , module TLS
- , module TLSExtra
- )
- where
-
-import Control.Monad
-import Control.Monad (liftM, when)
-import Control.Monad.IO.Class
-
-import Crypto.Random
-
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as BL
-import Data.Conduit
-import qualified Data.Conduit.Binary as CB
-import Data.IORef
-
-import Network.TLS as TLS
-import Crypto.Random.API
-import Network.TLS.Extra as TLSExtra
-
-import System.IO (Handle)
-
-client params gen backend = do
- contextNew backend params gen
-
-defaultParams = defaultParamsClient
-
-tlsinit :: (MonadIO m, MonadIO m1) =>
- Bool
- -> TLSParams
- -> Backend
- -> m ( Source m1 BS.ByteString
- , Sink BS.ByteString m1 ()
- , BS.ByteString -> IO ()
- , Int -> m1 BS.ByteString
- , Context
- )
-tlsinit debug tlsParams backend = do
- when debug . liftIO $ putStrLn "TLS with debug mode enabled"
- gen <- liftIO $ getSystemRandomGen -- TODO: Find better random source?
- con <- client tlsParams gen backend
- handshake con
- let src = forever $ do
- dt <- liftIO $ recvData con
- when debug (liftIO $ putStr "in: " >> BS.putStrLn dt)
- yield dt
- let snk = do
- d <- await
- case d of
- Nothing -> return ()
- Just x -> do
- sendData con (BL.fromChunks [x])
- when debug (liftIO $ putStr "out: " >> BS.putStrLn x)
- snk
- read <- liftIO $ mkReadBuffer (recvData con)
- return ( src
- , snk
- , \s -> do
- when debug (liftIO $ BS.putStrLn s)
- sendData con $ BL.fromChunks [s]
- , liftIO . read
- , con
- )
-
-mkReadBuffer :: IO BS.ByteString -> IO (Int -> IO BS.ByteString)
-mkReadBuffer read = do
- buffer <- newIORef BS.empty
- let read' n = do
- nc <- readIORef buffer
- bs <- if BS.null nc then read
- else return nc
- let (result, rest) = BS.splitAt n bs
- writeIORef buffer rest
- return result
- return read'
diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs
index d0e2e9c..f545cba 100644
--- a/source/Network/Xmpp.hs
+++ b/source/Network/Xmpp.hs
@@ -18,7 +18,7 @@
-- of XMPP (RFC 6120): setup and teardown of XML streams, channel encryption,
-- authentication, error handling, and communication primitives for messaging.
--
--- For low-level access to Pontarius XMPP, see the "Network.Xmpp.Connection"
+-- For low-level access to Pontarius XMPP, see the "Network.Xmpp.Internal"
-- module.
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}
@@ -96,7 +96,7 @@ module Network.Xmpp
, PresenceType(..)
, PresenceError(..)
-- *** Creating
- , module Network.Xmpp.Presence
+ , presTo
-- *** Sending
-- | Sends a presence stanza. In general, the presence stanza should have no
-- 'to' attribute, in which case the server to which the client is connected
@@ -145,7 +145,7 @@ module Network.Xmpp
, AuthFailure( AuthXmlFailure -- Does not export AuthStreamFailure
, AuthNoAcceptableMechanism
, AuthChallengeFailure
- , AuthNoConnection
+ , AuthNoStream
, AuthFailure
, AuthSaslFailure
, AuthStringPrepFailure )
@@ -154,10 +154,8 @@ module Network.Xmpp
import Network
import Network.Xmpp.Concurrent
-import Network.Xmpp.Message
-import Network.Xmpp.Presence
+import Network.Xmpp.Utilities
import Network.Xmpp.Sasl
import Network.Xmpp.Sasl.Types
-import Network.Xmpp.Session
import Network.Xmpp.Tls
import Network.Xmpp.Types
diff --git a/source/Network/Xmpp/Bind.hs b/source/Network/Xmpp/Bind.hs
deleted file mode 100644
index a3676e6..0000000
--- a/source/Network/Xmpp/Bind.hs
+++ /dev/null
@@ -1,57 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-{-# OPTIONS_HADDOCK hide #-}
-
-module Network.Xmpp.Bind where
-
-import Control.Exception
-
-import Data.Text as Text
-import Data.XML.Pickle
-import Data.XML.Types
-
-import Network.Xmpp.Connection_
-import Network.Xmpp.Pickle
-import Network.Xmpp.Types
-
-import Control.Monad.State(modify)
-
-import Control.Concurrent.STM.TMVar
-
-import Control.Monad.Error
-
--- Produces a `bind' element, optionally wrapping a resource.
-bindBody :: Maybe Text -> Element
-bindBody = pickleElem $
- -- Pickler to produce a
- -- ""
- -- element, with a possible "[JID]"
- -- child.
- xpBind . xpOption $ xpElemNodes "resource" (xpContent xpId)
-
--- Sends a (synchronous) IQ set request for a (`Just') given or server-generated
--- resource and extract the JID from the non-error response.
-xmppBind :: Maybe Text -> TMVar Connection -> IO (Either XmppFailure Jid)
-xmppBind rsrc c = runErrorT $ do
- answer <- ErrorT $ pushIQ' "bind" Nothing Set Nothing (bindBody rsrc) c
- case answer of
- Right IQResult{iqResultPayload = Just b} -> do
- let jid = unpickleElem xpJid b
- case jid of
- Right jid' -> do
- ErrorT $ withConnection (do
- modify $ \s -> s{cJid = Just jid'}
- return $ Right jid') c -- not pretty
- return jid'
- otherwise -> throwError XmppOtherFailure
- -- TODO: Log: ("Bind couldn't unpickle JID from " ++ show answer)
- otherwise -> throwError XmppOtherFailure
- where
- -- Extracts the character data in the `jid' element.
- xpJid :: PU [Node] Jid
- xpJid = xpBind $ xpElemNodes jidName (xpContent xpPrim)
- jidName = "{urn:ietf:params:xml:ns:xmpp-bind}jid"
-
--- A `bind' element pickler.
-xpBind :: PU [Node] b -> PU [Node] b
-xpBind c = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}bind" c
diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs
index fa94910..b6df58c 100644
--- a/source/Network/Xmpp/Concurrent.hs
+++ b/source/Network/Xmpp/Concurrent.hs
@@ -11,6 +11,7 @@ module Network.Xmpp.Concurrent
, toChans
, newSession
, writeWorker
+ , session
) where
import Network.Xmpp.Concurrent.Monad
@@ -31,9 +32,17 @@ import Network.Xmpp.Concurrent.Presence
import Network.Xmpp.Concurrent.Types
import Network.Xmpp.Concurrent.Threads
import Network.Xmpp.Marshal
-import Network.Xmpp.Pickle
import Network.Xmpp.Types
-import Text.Xml.Stream.Elements
+import Network
+import Data.Text as Text
+import Network.Xmpp.Tls
+import qualified Network.TLS as TLS
+import Network.Xmpp.Sasl
+import Network.Xmpp.Sasl.Mechanisms
+import Network.Xmpp.Sasl.Types
+import Data.Maybe
+import Network.Xmpp.Stream
+import Network.Xmpp.Utilities
import Control.Monad.Error
@@ -74,14 +83,14 @@ toChans stanzaC iqHands sta = atomically $ do
-- | Creates and initializes a new Xmpp context.
-newSession :: TMVar Connection -> IO (Either XmppFailure Session)
-newSession con = runErrorT $ do
+newSession :: TMVar Stream -> IO (Either XmppFailure Session)
+newSession stream = runErrorT $ do
outC <- lift newTChanIO
stanzaChan <- lift newTChanIO
iqHandlers <- lift $ newTVarIO (Map.empty, Map.empty)
eh <- lift $ newTVarIO $ EventHandlers { connectionClosedHandler = \_ -> return () }
let stanzaHandler = toChans stanzaChan iqHandlers
- (kill, wLock, conState, readerThread) <- ErrorT $ startThreadsWith stanzaHandler eh con
+ (kill, wLock, streamState, readerThread) <- ErrorT $ startThreadsWith stanzaHandler eh stream
writer <- lift $ forkIO $ writeWorker outC wLock
idRef <- lift $ newTVarIO 1
let getId = atomically $ do
@@ -94,7 +103,7 @@ newSession con = runErrorT $ do
, writeRef = wLock
, readerThread = readerThread
, idGenerator = getId
- , conRef = conState
+ , streamRef = streamState
, eventHandlers = eh
, stopThreads = kill >> killThread writer
}
@@ -111,3 +120,31 @@ writeWorker stCh writeR = forever $ do
atomically $ unGetTChan stCh next -- If the writing failed, the
-- connection is dead.
threadDelay 250000 -- Avoid free spinning.
+
+-- | Creates a 'Session' object by setting up a connection with an XMPP server.
+--
+-- Will connect to the specified host. If the fourth parameters is a 'Just'
+-- value, @session@ will attempt to secure the connection with TLS. If the fifth
+-- parameters is a 'Just' value, @session@ will attempt to authenticate and
+-- acquire an XMPP resource.
+session :: HostName -- ^ Host to connect to
+ -> Text -- ^ The realm host name (to
+ -- distinguish the XMPP service)
+ -> PortID -- ^ Port to connect to
+ -> Maybe TLS.TLSParams -- ^ TLS settings, if securing the
+ -- connection to the server is
+ -- desired
+ -> Maybe ([SaslHandler], Maybe Text) -- ^ SASL handlers and the desired
+ -- JID resource (or Nothing to let
+ -- the server decide)
+ -> IO (Either XmppFailure (Session, Maybe AuthFailure))
+session hostname realm port tls sasl = runErrorT $ do
+ con <- ErrorT $ openStream hostname port realm
+ if isJust tls
+ then ErrorT $ startTls (fromJust tls) con
+ else return ()
+ aut <- if isJust sasl
+ then ErrorT $ auth (fst $ fromJust sasl) (snd $ fromJust sasl) con
+ else return Nothing
+ ses <- ErrorT $ newSession con
+ return (ses, aut)
diff --git a/source/Network/Xmpp/Concurrent/Monad.hs b/source/Network/Xmpp/Concurrent/Monad.hs
index ff0f07a..5a1d627 100644
--- a/source/Network/Xmpp/Concurrent/Monad.hs
+++ b/source/Network/Xmpp/Concurrent/Monad.hs
@@ -9,7 +9,7 @@ import qualified Control.Exception.Lifted as Ex
import Control.Monad.Reader
import Network.Xmpp.Concurrent.Types
-import Network.Xmpp.Connection_
+import Network.Xmpp.Stream
@@ -94,6 +94,6 @@ closeConnection :: Session -> IO ()
closeConnection session = Ex.mask_ $ do
(_send, connection) <- atomically $ liftM2 (,)
(takeTMVar $ writeRef session)
- (takeTMVar $ conRef session)
+ (takeTMVar $ streamRef session)
_ <- closeStreams connection
return ()
diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs
index c55fc16..452aa4c 100644
--- a/source/Network/Xmpp/Concurrent/Threads.hs
+++ b/source/Network/Xmpp/Concurrent/Threads.hs
@@ -16,7 +16,7 @@ import Control.Monad.State.Strict
import qualified Data.ByteString as BS
import Network.Xmpp.Concurrent.Types
-import Network.Xmpp.Connection_
+import Network.Xmpp.Stream
import Control.Concurrent.STM.TMVar
@@ -28,7 +28,7 @@ import Control.Monad.Error
-- all listener threads.
readWorker :: (Stanza -> IO ())
-> (XmppFailure -> IO ())
- -> TMVar (TMVar Connection)
+ -> TMVar (TMVar Stream)
-> IO a
readWorker onStanza onConnectionClosed stateRef =
Ex.mask_ . forever $ do
@@ -37,8 +37,8 @@ readWorker onStanza onConnectionClosed stateRef =
-- necessarily be interruptible
s <- atomically $ do
con <- readTMVar stateRef
- state <- cState <$> readTMVar con
- when (state == ConnectionClosed)
+ state <- streamState <$> readTMVar con
+ when (state == Closed)
retry
return con
allowInterrupt
@@ -77,13 +77,13 @@ readWorker onStanza onConnectionClosed stateRef =
-- connection.
startThreadsWith :: (Stanza -> IO ())
-> TVar EventHandlers
- -> TMVar Connection
+ -> TMVar Stream
-> IO (Either XmppFailure (IO (),
TMVar (BS.ByteString -> IO Bool),
- TMVar (TMVar Connection),
+ TMVar (TMVar Stream),
ThreadId))
startThreadsWith stanzaHandler eh con = do
- read <- withConnection' (gets $ cSend . cHandle >>= \d -> return $ Right d) con
+ read <- withStream' (gets $ streamSend . streamHandle >>= \d -> return $ Right d) con
case read of
Left e -> return $ Left e
Right read' -> do
diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs
index 0d61e93..e753f05 100644
--- a/source/Network/Xmpp/Concurrent/Types.hs
+++ b/source/Network/Xmpp/Concurrent/Types.hs
@@ -41,10 +41,10 @@ data Session = Session
-- Fields below are from Context.
, writeRef :: TMVar (BS.ByteString -> IO Bool)
, readerThread :: ThreadId
- , idGenerator :: IO StanzaID
- -- | Lock (used by withConnection) to make sure that a maximum of one
- -- XmppConMonad action is executed at any given time.
- , conRef :: TMVar (TMVar Connection)
+ , idGenerator :: IO StanzaId
+ -- | Lock (used by withStream) to make sure that a maximum of one
+ -- Stream action is executed at any given time.
+ , streamRef :: TMVar (TMVar Stream)
, eventHandlers :: TVar EventHandlers
, stopThreads :: IO ()
}
diff --git a/source/Network/Xmpp/IM/Message.hs b/source/Network/Xmpp/IM/Message.hs
index 505a27e..e5aa830 100644
--- a/source/Network/Xmpp/IM/Message.hs
+++ b/source/Network/Xmpp/IM/Message.hs
@@ -11,8 +11,8 @@ import Data.Text (Text)
import Data.XML.Pickle
import Data.XML.Types
+import Network.Xmpp.Marshal
import Network.Xmpp.Types
-import Network.Xmpp.Pickle
data MessageBody = MessageBody { bodyLang :: (Maybe LangTag)
, bodyContent :: Text
diff --git a/source/Network/Xmpp/Connection.hs b/source/Network/Xmpp/Internal.hs
similarity index 56%
rename from source/Network/Xmpp/Connection.hs
rename to source/Network/Xmpp/Internal.hs
index d1dddd5..790deaa 100644
--- a/source/Network/Xmpp/Connection.hs
+++ b/source/Network/Xmpp/Internal.hs
@@ -8,34 +8,37 @@
-- This module allows for low-level access to Pontarius XMPP. Generally, the
-- "Network.Xmpp" module should be used instead.
--
--- The 'Connection' object provides the most low-level access to the XMPP
+-- The 'Stream' object provides the most low-level access to the XMPP
-- stream: a simple and single-threaded interface which exposes the conduit
-- 'Event' source, as well as the input and output byte streams. Custom stateful
--- 'Connection' functions can be executed using 'withConnection'.
+-- 'Stream' functions can be executed using 'withStream'.
--
-- The TLS, SASL, and 'Session' functionalities of Pontarius XMPP are built on
-- top of this API.
-module Network.Xmpp.Connection
- ( Connection(..)
- , ConnectionState(..)
- , ConnectionHandle(..)
- , ServerFeatures(..)
- , connect
- , withConnection
+module Network.Xmpp.Internal
+ ( Stream(..)
+ , StreamState(..)
+ , StreamHandle(..)
+ , StreamFeatures(..)
+ , openStream
+ , withStream
, startTls
- , simpleAuth
, auth
, pushStanza
, pullStanza
- , closeConnection
- , newSession
+ , pushIQ
+ , SaslHandler(..)
+ , StanzaId(..)
)
where
-import Network.Xmpp.Connection_
-import Network.Xmpp.Session
+import Network.Xmpp.Stream
+import Network.Xmpp.Sasl
+import Network.Xmpp.Sasl.Common
+import Network.Xmpp.Sasl.Types
import Network.Xmpp.Tls
import Network.Xmpp.Types
-import Network.Xmpp.Concurrent
+import Network.Xmpp.Stream
+import Network.Xmpp.Marshal
diff --git a/source/Network/Xmpp/Jid.hs b/source/Network/Xmpp/Jid.hs
deleted file mode 100644
index bb80884..0000000
--- a/source/Network/Xmpp/Jid.hs
+++ /dev/null
@@ -1,205 +0,0 @@
-{-# OPTIONS_HADDOCK hide #-}
-
--- This module deals with JIDs, also known as XMPP addresses. For more
--- information on JIDs, see RFC 6122: XMPP: Address Format.
-
-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 qualified Text.NamePrep as SP
-import qualified Text.StringPrep as SP
-
--- | A JID is XMPP\'s native format for addressing entities in the network. It
--- is somewhat similar to an e-mail address but contains three parts instead of
--- two.
-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)
- } deriving Eq
-
-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
-
--- | Converts localpart, domainpart, and resourcepart strings to a JID. Runs the
--- appropriate stringprep profiles and validates the parts.
-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
- validDomainPart :: Text -> Bool
- validDomainPart _s = True -- TODO
-
- validPartLength :: Text -> Bool
- validPartLength p = Text.length p > 0 && Text.length p < 1024
-
--- | 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 = not . isBare
-
--- Parses an JID string and returns its three parts. It performs no validation
--- or transformations.
-jidParts :: AP.Parser (Maybe Text, Text, Maybe Text)
-jidParts = do
- -- Read until we reach an '@', a '/', or EOF.
- 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
- b <- domainPartP
- -- Case 1A: We found a '/' and thus have all the JID parts. Read the '/'
- -- and until EOF.
- do
- 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
- AP.endOfInput
- return (Just a, b, Nothing)
- -- Case 2: We found a '/'; the JID is in the form
- -- domainpart/resourcepart.
- <|> do
- 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
- AP.endOfInput
- return (Nothing, a, Nothing)
- where
- -- Read an '@' and everything until a '/'.
- domainPartP :: AP.Parser Text
- domainPartP = do
- _ <- AP.char '@'
- AP.takeWhile1 (/= '/')
- -- Read everything until a '/'.
- resourcePartP :: AP.Parser Text
- resourcePartP = do
- _ <- AP.char '/'
- AP.takeText
-
--- The `nodeprep' StringPrep profile.
-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 characters needs to be checked for after normalization.
-nodeprepExtraProhibitedCharacters :: [Char]
-nodeprepExtraProhibitedCharacters = ['\x22', '\x26', '\x27', '\x2F', '\x3A',
- '\x3C', '\x3E', '\x40']
-
--- The `resourceprep' StringPrep profile.
-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
- }
\ No newline at end of file
diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs
index 9b78c4c..3e9ab5e 100644
--- a/source/Network/Xmpp/Marshal.hs
+++ b/source/Network/Xmpp/Marshal.hs
@@ -11,7 +11,8 @@ module Network.Xmpp.Marshal where
import Data.XML.Pickle
import Data.XML.Types
-import Network.Xmpp.Pickle
+import Data.Text
+
import Network.Xmpp.Types
xpStreamStanza :: PU [Node] (Either StreamErrorInfo Stanza)
@@ -207,3 +208,73 @@ xpStreamError = ("xpStreamError" , "") xpWrap
(xpOption xpElemVerbatim) -- Application specific error conditions
)
)
+
+xpLangTag :: PU [Attribute] (Maybe LangTag)
+xpLangTag = xpAttrImplied xmlLang xpPrim
+
+xmlLang :: Name
+xmlLang = Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml")
+
+-- Given a pickler and an object, produces an Element.
+pickleElem :: PU [Node] a -> a -> Element
+pickleElem p = pickle $ xpNodeElem p
+
+-- Given a pickler and an element, produces an object.
+unpickleElem :: PU [Node] a -> Element -> Either UnpickleError a
+unpickleElem p x = unpickle (xpNodeElem p) x
+
+xpNodeElem :: PU [Node] a -> PU Element a
+xpNodeElem xp = PU { pickleTree = \x -> Prelude.head $ (pickleTree xp x) >>= \y ->
+ case y of
+ NodeElement e -> [e]
+ _ -> []
+ , unpickleTree = \x -> case unpickleTree xp $ [NodeElement x] of
+ Left l -> Left l
+ Right (a,(_,c)) -> Right (a,(Nothing,c))
+ }
+
+mbl :: Maybe [a] -> [a]
+mbl (Just l) = l
+mbl Nothing = []
+
+lmb :: [t] -> Maybe [t]
+lmb [] = Nothing
+lmb x = Just x
+
+xpStream :: PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
+xpStream = xpElemAttrs
+ (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream"))
+ (xp5Tuple
+ (xpAttr "version" xpId)
+ (xpAttrImplied "from" xpPrim)
+ (xpAttrImplied "to" xpPrim)
+ (xpAttrImplied "id" xpId)
+ xpLangTag
+ )
+
+-- Pickler/Unpickler for the stream features - TLS, SASL, and the rest.
+xpStreamFeatures :: PU [Node] StreamFeatures
+xpStreamFeatures = xpWrap
+ (\(tls, sasl, rest) -> StreamFeatures tls (mbl sasl) rest)
+ (\(StreamFeatures tls sasl rest) -> (tls, lmb sasl, rest))
+ (xpElemNodes
+ (Name
+ "features"
+ (Just "http://etherx.jabber.org/streams")
+ (Just "stream")
+ )
+ (xpTriple
+ (xpOption pickleTlsFeature)
+ (xpOption pickleSaslFeature)
+ (xpAll xpElemVerbatim)
+ )
+ )
+ where
+ pickleTlsFeature :: PU [Node] Bool
+ pickleTlsFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls"
+ (xpElemExists "required")
+ pickleSaslFeature :: PU [Node] [Text]
+ pickleSaslFeature = xpElemNodes
+ "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms"
+ (xpAll $ xpElemNodes
+ "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId))
diff --git a/source/Network/Xmpp/Message.hs b/source/Network/Xmpp/Message.hs
deleted file mode 100644
index 875421f..0000000
--- a/source/Network/Xmpp/Message.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# OPTIONS_HADDOCK hide #-}
-
-module Network.Xmpp.Message
- ( Message(..)
- , MessageError(..)
- , MessageType(..)
- , answerMessage
- , message
- ) where
-
-import Data.XML.Types
-
-import Network.Xmpp.Types
-
--- | An empty message.
-message :: Message
-message = Message { messageID = Nothing
- , messageFrom = Nothing
- , messageTo = Nothing
- , messageLangTag = Nothing
- , messageType = Normal
- , messagePayload = []
- }
-
--- Produce an answer message with the given payload, switching the "from" and
--- "to" attributes in the original message.
-answerMessage :: Message -> [Element] -> Maybe Message
-answerMessage Message{messageFrom = Just frm, ..} payload =
- Just Message{ messageFrom = messageTo
- , messageID = Nothing
- , messageTo = Just frm
- , messagePayload = payload
- , ..
- }
-answerMessage _ _ = Nothing
\ No newline at end of file
diff --git a/source/Network/Xmpp/Presence.hs b/source/Network/Xmpp/Presence.hs
deleted file mode 100644
index c859f14..0000000
--- a/source/Network/Xmpp/Presence.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-{-# OPTIONS_HADDOCK hide #-}
-
-module Network.Xmpp.Presence where
-
-import Data.Text(Text)
-import Network.Xmpp.Types
-
--- | 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/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs
index 2a61ae2..d338c0c 100644
--- a/source/Network/Xmpp/Sasl.hs
+++ b/source/Network/Xmpp/Sasl.hs
@@ -1,11 +1,17 @@
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}
+-- Submodule for functionality related to SASL negotation:
+-- authentication functions, SASL functionality, bind functionality,
+-- and the legacy `{urn:ietf:params:xml:ns:xmpp-session}session'
+-- functionality.
+
module Network.Xmpp.Sasl
( xmppSasl
, digestMd5
, scramSha1
, plain
+ , auth
) where
import Control.Applicative
@@ -29,7 +35,6 @@ import qualified Data.Text as Text
import Data.Text (Text)
import qualified Data.Text.Encoding as Text
-import Network.Xmpp.Connection_
import Network.Xmpp.Stream
import Network.Xmpp.Types
@@ -40,24 +45,38 @@ import Network.Xmpp.Sasl.Mechanisms
import Control.Concurrent.STM.TMVar
+import Control.Exception
+
+import Data.XML.Pickle
+import Data.XML.Types
+
+import Network.Xmpp.Types
+import Network.Xmpp.Marshal
+
+import Control.Monad.State(modify)
+
+import Control.Concurrent.STM.TMVar
+
+import Control.Monad.Error
+
-- | Uses the first supported mechanism to authenticate, if any. Updates the
-- state with non-password credentials and restarts the stream upon
-- success. Returns `Nothing' on success, an `AuthFailure' if
-- authentication fails, or an `XmppFailure' if anything else fails.
xmppSasl :: [SaslHandler] -- ^ Acceptable authentication mechanisms and their
-- corresponding handlers
- -> TMVar Connection
+ -> TMVar Stream
-> IO (Either XmppFailure (Maybe AuthFailure))
-xmppSasl handlers = withConnection $ do
+xmppSasl handlers = withStream $ do
-- Chooses the first mechanism that is acceptable by both the client and the
-- server.
- mechanisms <- gets $ saslMechanisms . cFeatures
+ mechanisms <- gets $ streamSaslMechanisms . streamFeatures
case (filter (\(name, _) -> name `elem` mechanisms)) handlers of
[] -> return $ Right $ Just $ AuthNoAcceptableMechanism mechanisms
(_name, handler):_ -> do
- cs <- gets cState
+ cs <- gets streamState
case cs of
- ConnectionClosed -> return . Right $ Just AuthNoConnection
+ Closed -> return . Right $ Just AuthNoStream
_ -> do
r <- runErrorT handler
case r of
@@ -65,3 +84,74 @@ xmppSasl handlers = withConnection $ do
Right a -> do
_ <- runErrorT $ ErrorT restartStream
return $ Right $ Nothing
+
+-- | Authenticate to the server using the first matching method and bind a
+-- resource.
+auth :: [SaslHandler]
+ -> Maybe Text
+ -> TMVar Stream
+ -> IO (Either XmppFailure (Maybe AuthFailure))
+auth mechanisms resource con = runErrorT $ do
+ ErrorT $ xmppSasl mechanisms con
+ jid <- lift $ xmppBind resource con
+ lift $ startSession con
+ return Nothing
+
+-- Produces a `bind' element, optionally wrapping a resource.
+bindBody :: Maybe Text -> Element
+bindBody = pickleElem $
+ -- Pickler to produce a
+ -- ""
+ -- element, with a possible "[JID]"
+ -- child.
+ xpBind . xpOption $ xpElemNodes "resource" (xpContent xpId)
+
+-- Sends a (synchronous) IQ set request for a (`Just') given or server-generated
+-- resource and extract the JID from the non-error response.
+xmppBind :: Maybe Text -> TMVar Stream -> IO (Either XmppFailure Jid)
+xmppBind rsrc c = runErrorT $ do
+ answer <- ErrorT $ pushIQ "bind" Nothing Set Nothing (bindBody rsrc) c
+ case answer of
+ Right IQResult{iqResultPayload = Just b} -> do
+ let jid = unpickleElem xpJid b
+ case jid of
+ Right jid' -> do
+ ErrorT $ withStream (do
+ modify $ \s -> s{streamJid = Just jid'}
+ return $ Right jid') c -- not pretty
+ return jid'
+ otherwise -> throwError XmppOtherFailure
+ -- TODO: Log: ("Bind couldn't unpickle JID from " ++ show answer)
+ otherwise -> throwError XmppOtherFailure
+ where
+ -- Extracts the character data in the `jid' element.
+ xpJid :: PU [Node] Jid
+ xpJid = xpBind $ xpElemNodes jidName (xpContent xpPrim)
+ jidName = "{urn:ietf:params:xml:ns:xmpp-bind}jid"
+
+-- A `bind' element pickler.
+xpBind :: PU [Node] b -> PU [Node] b
+xpBind c = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}bind" c
+
+sessionXml :: Element
+sessionXml = pickleElem
+ (xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session")
+ ()
+
+sessionIQ :: Stanza
+sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess"
+ , iqRequestFrom = Nothing
+ , iqRequestTo = Nothing
+ , iqRequestLangTag = Nothing
+ , iqRequestType = Set
+ , iqRequestPayload = sessionXml
+ }
+
+-- Sends the session IQ set element and waits for an answer. Throws an error if
+-- if an IQ error stanza is returned from the server.
+startSession :: TMVar Stream -> IO ()
+startSession con = do
+ answer <- pushIQ "session" Nothing Set Nothing sessionXml con
+ case answer of
+ Left e -> error $ show e
+ Right _ -> return ()
diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs
index e3dcc5c..eea0ce7 100644
--- a/source/Network/Xmpp/Sasl/Common.hs
+++ b/source/Network/Xmpp/Sasl/Common.hs
@@ -22,14 +22,16 @@ import Data.Word (Word8)
import Data.XML.Pickle
import Data.XML.Types
-import Network.Xmpp.Connection_
-import Network.Xmpp.Pickle
+import Network.Xmpp.Stream
import Network.Xmpp.Sasl.StringPrep
import Network.Xmpp.Sasl.Types
+import Network.Xmpp.Marshal
import qualified System.Random as Random
---makeNonce :: SaslM BS.ByteString
+import Control.Monad.State.Strict
+
+--makeNonce :: ErrorT AuthFailure (StateT Stream IO) BS.ByteString
makeNonce :: IO BS.ByteString
makeNonce = do
g <- liftIO Random.newStdGen
@@ -106,7 +108,7 @@ xpSaslElement = xpAlt saslSel
quote :: BS.ByteString -> BS.ByteString
quote x = BS.concat ["\"",x,"\""]
-saslInit :: Text.Text -> Maybe BS.ByteString -> SaslM Bool
+saslInit :: Text.Text -> Maybe BS.ByteString -> ErrorT AuthFailure (StateT Stream IO) Bool
saslInit mechanism payload = do
r <- lift . pushElement . saslInitE mechanism $
Text.decodeUtf8 . B64.encode <$> payload
@@ -115,7 +117,7 @@ saslInit mechanism payload = do
Right b -> return b
-- | Pull the next element.
-pullSaslElement :: SaslM SaslElement
+pullSaslElement :: ErrorT AuthFailure (StateT Stream IO) SaslElement
pullSaslElement = do
r <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement)
case r of
@@ -124,7 +126,7 @@ pullSaslElement = do
Right (Right r) -> return r
-- | Pull the next element, checking that it is a challenge.
-pullChallenge :: SaslM (Maybe BS.ByteString)
+pullChallenge :: ErrorT AuthFailure (StateT Stream IO) (Maybe BS.ByteString)
pullChallenge = do
e <- pullSaslElement
case e of
@@ -135,12 +137,12 @@ pullChallenge = do
_ -> throwError AuthChallengeFailure
-- | Extract value from Just, failing with AuthChallengeFailure on Nothing.
-saslFromJust :: Maybe a -> SaslM a
+saslFromJust :: Maybe a -> ErrorT AuthFailure (StateT Stream IO) a
saslFromJust Nothing = throwError $ AuthChallengeFailure
saslFromJust (Just d) = return d
-- | Pull the next element and check that it is success.
-pullSuccess :: SaslM (Maybe Text.Text)
+pullSuccess :: ErrorT AuthFailure (StateT Stream IO) (Maybe Text.Text)
pullSuccess = do
e <- pullSaslElement
case e of
@@ -149,7 +151,7 @@ pullSuccess = do
-- | Pull the next element. When it's success, return it's payload.
-- If it's a challenge, send an empty response and pull success.
-pullFinalMessage :: SaslM (Maybe BS.ByteString)
+pullFinalMessage :: ErrorT AuthFailure (StateT Stream IO) (Maybe BS.ByteString)
pullFinalMessage = do
challenge2 <- pullSaslElement
case challenge2 of
@@ -165,13 +167,13 @@ pullFinalMessage = do
Right x -> return $ Just x
-- | Extract p=q pairs from a challenge.
-toPairs :: BS.ByteString -> SaslM Pairs
+toPairs :: BS.ByteString -> ErrorT AuthFailure (StateT Stream IO) Pairs
toPairs ctext = case pairs ctext of
Left _e -> throwError AuthChallengeFailure
Right r -> return r
-- | Send a SASL response element. The content will be base64-encoded.
-respond :: Maybe BS.ByteString -> SaslM Bool
+respond :: Maybe BS.ByteString -> ErrorT AuthFailure (StateT Stream IO) Bool
respond m = do
r <- lift . pushElement . saslResponseE . fmap (Text.decodeUtf8 . B64.encode) $ m
case r of
@@ -182,7 +184,7 @@ respond m = do
-- | Run the appropriate stringprep profiles on the credentials.
-- May fail with 'AuthStringPrepFailure'
prepCredentials :: Text.Text -> Maybe Text.Text -> Text.Text
- -> SaslM (Text.Text, Maybe Text.Text, Text.Text)
+ -> ErrorT AuthFailure (StateT Stream IO) (Text.Text, Maybe Text.Text, Text.Text)
prepCredentials authcid authzid password = case credentials of
Nothing -> throwError $ AuthStringPrepFailure
Just creds -> return creds
diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs
index f8fc03c..bca3ab5 100644
--- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs
+++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs
@@ -31,8 +31,6 @@ import qualified Data.ByteString as BS
import Data.XML.Types
-import Network.Xmpp.Connection_
-import Network.Xmpp.Pickle
import Network.Xmpp.Stream
import Network.Xmpp.Types
import Network.Xmpp.Sasl.Common
@@ -44,15 +42,15 @@ import Network.Xmpp.Sasl.Types
xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username)
-> Maybe Text -- ^ Authorization identity (authcid)
-> Text -- ^ Password (authzid)
- -> SaslM ()
+ -> ErrorT AuthFailure (StateT Stream IO) ()
xmppDigestMd5 authcid authzid password = do
(ac, az, pw) <- prepCredentials authcid authzid password
- hn <- gets cHostName
+ hn <- gets streamHostname
xmppDigestMd5' (fromJust hn) ac az pw
where
- xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> SaslM ()
+ xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> ErrorT AuthFailure (StateT Stream IO) ()
xmppDigestMd5' hostname authcid authzid password = do
- -- Push element and receive the challenge (in SaslM).
+ -- Push element and receive the challenge.
_ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean?
pairs <- toPairs =<< saslFromJust =<< pullChallenge
cnonce <- liftIO $ makeNonce
diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs
index 6f1626e..3e85a50 100644
--- a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs
+++ b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs
@@ -35,10 +35,8 @@ import qualified Data.ByteString as BS
import Data.XML.Types
-import Network.Xmpp.Connection_
import Network.Xmpp.Stream
import Network.Xmpp.Types
-import Network.Xmpp.Pickle
import qualified System.Random as Random
@@ -52,7 +50,7 @@ import Network.Xmpp.Sasl.Types
xmppPlain :: Text.Text -- ^ Password
-> Maybe Text.Text -- ^ Authorization identity (authzid)
-> Text.Text -- ^ Authentication identity (authcid)
- -> SaslM ()
+ -> ErrorT AuthFailure (StateT Stream IO) ()
xmppPlain authcid authzid password = do
(ac, az, pw) <- prepCredentials authcid authzid password
_ <- saslInit "PLAIN" ( Just $ plainMessage ac az pw)
diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs
index e9cebc7..4262c63 100644
--- a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs
+++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs
@@ -29,6 +29,10 @@ import Data.Word(Word8)
import Network.Xmpp.Sasl.Common
import Network.Xmpp.Sasl.StringPrep
import Network.Xmpp.Sasl.Types
+import Network.Xmpp.Types
+
+
+import Control.Monad.State.Strict
-- | A nicer name for undefined, for use as a dummy token to determin
-- the hash function to use
@@ -45,7 +49,7 @@ scram :: (Crypto.Hash ctx hash)
-> Text.Text -- ^ Authentication ID (user name)
-> Maybe Text.Text -- ^ Authorization ID
-> Text.Text -- ^ Password
- -> SaslM ()
+ -> ErrorT AuthFailure (StateT Stream IO) ()
scram hashToken authcid authzid password = do
(ac, az, pw) <- prepCredentials authcid authzid password
scramhelper hashToken ac az pw
@@ -94,7 +98,7 @@ scram hashToken authcid authzid password = do
fromPairs :: Pairs
-> BS.ByteString
- -> SaslM (BS.ByteString, BS.ByteString, Integer)
+ -> ErrorT AuthFailure (StateT Stream IO) (BS.ByteString, BS.ByteString, Integer)
fromPairs pairs cnonce | Just nonce <- lookup "r" pairs
, cnonce `BS.isPrefixOf` nonce
, Just salt' <- lookup "s" pairs
diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs
index 90f20da..c341585 100644
--- a/source/Network/Xmpp/Sasl/Types.hs
+++ b/source/Network/Xmpp/Sasl/Types.hs
@@ -15,7 +15,7 @@ data AuthFailure = AuthXmlFailure
-- itself
| AuthStreamFailure XmppFailure -- ^ Stream error on stream restart
-- TODO: Rename AuthConnectionFailure?
- | AuthNoConnection
+ | AuthNoStream
| AuthFailure -- General instance used for the Error instance
| AuthSaslFailure SaslFailure -- ^ Defined SASL error condition
| AuthStringPrepFailure -- ^ StringPrep failed
@@ -27,11 +27,9 @@ instance Error AuthFailure where
data SaslElement = SaslSuccess (Maybe Text.Text)
| SaslChallenge (Maybe Text.Text)
--- | SASL mechanism XmppConnection computation, with the possibility of throwing
--- an authentication error.
-type SaslM a = ErrorT AuthFailure (StateT Connection IO) a
-
type Pairs = [(ByteString, ByteString)]
--- | Tuple defining the SASL Handler's name, and a SASL mechanism computation
-type SaslHandler = (Text.Text, SaslM ())
+-- | Tuple defining the SASL Handler's name, and a SASL mechanism computation.
+-- The SASL mechanism is a stateful @Stream@ computation, which has the
+-- possibility of resulting in an authentication error.
+type SaslHandler = (Text.Text, ErrorT AuthFailure (StateT Stream IO) ())
diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs
index 5688dec..769955b 100644
--- a/source/Network/Xmpp/Stream.hs
+++ b/source/Network/Xmpp/Stream.hs
@@ -1,11 +1,14 @@
{-# OPTIONS_HADDOCK hide #-}
+
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Network.Xmpp.Stream where
import Control.Applicative ((<$>), (<*>))
import qualified Control.Exception as Ex
+import Control.Exception.Base
import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State.Strict
@@ -20,13 +23,35 @@ import Data.Void (Void)
import Data.XML.Pickle
import Data.XML.Types
-import Network.Xmpp.Connection_
-import Network.Xmpp.Pickle
import Network.Xmpp.Types
import Network.Xmpp.Marshal
-import Text.Xml.Stream.Elements
import Text.XML.Stream.Parse as XP
+import Control.Concurrent (forkIO, threadDelay)
+
+import Network
+import Control.Concurrent.STM
+
+import Data.ByteString as BS
+import Data.ByteString.Base64
+import System.Log.Logger
+import qualified GHC.IO.Exception as GIE
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import System.IO.Error (tryIOError)
+import System.IO
+import Data.Conduit
+import Data.Conduit.Binary as CB
+import Data.Conduit.Internal as DCI
+import qualified Data.Conduit.List as CL
+import qualified Data.Text as T
+import Data.ByteString.Char8 as BSC8
+import Text.XML.Unresolved(InvalidEventStream(..))
+import qualified Control.Exception.Lifted as ExL
+
+import Control.Monad.Trans.Resource as R
+import Network.Xmpp.Utilities
-- import Text.XML.Stream.Elements
@@ -73,17 +98,17 @@ openElementFromEvents = do
-- server responds in a way that is invalid, an appropriate stream error will be
-- generated, the connection to the server will be closed, and a XmppFailure
-- will be produced.
-startStream :: StateT Connection IO (Either XmppFailure ())
+startStream :: StateT Stream IO (Either XmppFailure ())
startStream = runErrorT $ do
state <- lift $ get
- con <- liftIO $ mkConnection state
+ stream <- liftIO $ mkStream state
-- Set the `from' (which is also the expected to) attribute depending on the
- -- state of the connection.
- let expectedTo = case cState state of
- ConnectionPlain -> if cJidWhenPlain state
- then cJid state else Nothing
- ConnectionSecured -> cJid state
- case cHostName state of
+ -- state of the stream.
+ let expectedTo = case streamState state of
+ Plain -> if includeJidWhenPlain state
+ then toJid state else Nothing
+ Secured -> toJid state
+ case streamHostname state of
Nothing -> throwError XmppOtherFailure -- TODO: When does this happen?
Just hostname -> lift $ do
pushXmlDecl
@@ -92,62 +117,62 @@ startStream = runErrorT $ do
, expectedTo
, Just (Jid Nothing hostname Nothing)
, Nothing
- , cPreferredLang state
+ , preferredLang state
)
response <- ErrorT $ runEventsSink $ runErrorT $ streamS expectedTo
case response of
Left e -> throwError e
-- Successful unpickling of stream element.
Right (Right (ver, from, to, id, lt, features))
- | (unpack ver) /= "1.0" ->
- closeStreamWithError con StreamUnsupportedVersion Nothing
+ | (T.unpack ver) /= "1.0" ->
+ closeStreamWithError stream StreamUnsupportedVersion Nothing
| lt == Nothing ->
- closeStreamWithError con StreamInvalidXml Nothing
+ closeStreamWithError stream StreamInvalidXml Nothing
-- If `from' is set, we verify that it's the correct one. TODO: Should we check against the realm instead?
- | isJust from && (from /= Just (Jid Nothing (fromJust $ cHostName state) Nothing)) ->
- closeStreamWithError con StreamInvalidFrom Nothing
+ | isJust from && (from /= Just (Jid Nothing (fromJust $ streamHostname state) Nothing)) ->
+ closeStreamWithError stream StreamInvalidFrom Nothing
| to /= expectedTo ->
- closeStreamWithError con StreamUndefinedCondition (Just $ Element "invalid-to" [] []) -- TODO: Suitable?
+ closeStreamWithError stream StreamUndefinedCondition (Just $ Element "invalid-to" [] []) -- TODO: Suitable?
| otherwise -> do
- modify (\s -> s{ cFeatures = features
- , cStreamLang = lt
- , cStreamId = id
- , cFrom = from
+ modify (\s -> s{ streamFeatures = features
+ , streamLang = lt
+ , streamId = id
+ , streamFrom = from
} )
return ()
-- Unpickling failed - we investigate the element.
Right (Left (Element name attrs children))
| (nameLocalName name /= "stream") ->
- closeStreamWithError con StreamInvalidXml Nothing
+ closeStreamWithError stream StreamInvalidXml Nothing
| (nameNamespace name /= Just "http://etherx.jabber.org/streams") ->
- closeStreamWithError con StreamInvalidNamespace Nothing
+ closeStreamWithError stream StreamInvalidNamespace Nothing
| (isJust $ namePrefix name) && (fromJust (namePrefix name) /= "stream") ->
- closeStreamWithError con StreamBadNamespacePrefix Nothing
- | otherwise -> ErrorT $ checkchildren con (flattenAttrs attrs)
+ closeStreamWithError stream StreamBadNamespacePrefix Nothing
+ | otherwise -> ErrorT $ checkchildren stream (flattenAttrs attrs)
where
- -- closeStreamWithError :: MonadIO m => TMVar Connection -> StreamErrorCondition ->
+ -- closeStreamWithError :: MonadIO m => TMVar Stream -> StreamErrorCondition ->
-- Maybe Element -> ErrorT XmppFailure m ()
- closeStreamWithError con sec el = do
+ closeStreamWithError stream sec el = do
liftIO $ do
- withConnection (pushElement . pickleElem xpStreamError $
- StreamErrorInfo sec Nothing el) con
- closeStreams con
+ withStream (pushElement . pickleElem xpStreamError $
+ StreamErrorInfo sec Nothing el) stream
+ closeStreams stream
throwError XmppOtherFailure
- checkchildren con children =
+ checkchildren stream children =
let to' = lookup "to" children
ver' = lookup "version" children
xl = lookup xmlLang children
in case () of () | Just (Nothing :: Maybe Jid) == (safeRead <$> to') ->
- runErrorT $ closeStreamWithError con
+ runErrorT $ closeStreamWithError stream
StreamBadNamespacePrefix Nothing
| Nothing == ver' ->
- runErrorT $ closeStreamWithError con
+ runErrorT $ closeStreamWithError stream
StreamUnsupportedVersion Nothing
| Just (Nothing :: Maybe LangTag) == (safeRead <$> xl) ->
- runErrorT $ closeStreamWithError con
+ runErrorT $ closeStreamWithError stream
StreamInvalidXml Nothing
| otherwise ->
- runErrorT $ closeStreamWithError con
+ runErrorT $ closeStreamWithError stream
StreamBadFormat Nothing
safeRead x = case reads $ Text.unpack x of
[] -> Nothing
@@ -165,12 +190,12 @@ flattenAttrs attrs = Prelude.map (\(name, content) ->
-- Sets a new Event source using the raw source (of bytes)
-- and calls xmppStartStream.
-restartStream :: StateT Connection IO (Either XmppFailure ())
+restartStream :: StateT Stream IO (Either XmppFailure ())
restartStream = do
- raw <- gets (cRecv . cHandle)
+ raw <- gets (streamReceive . streamHandle)
let newSource = DCI.ResumableSource (loopRead raw $= XP.parseBytes def)
(return ())
- modify (\s -> s{cEventSource = newSource })
+ modify (\s -> s{streamEventSource = newSource })
startStream
where
loopRead read = do
@@ -190,7 +215,7 @@ streamS :: Maybe Jid -> StreamSink (Either Element ( Text
, Maybe Jid
, Maybe Text
, Maybe LangTag
- , ServerFeatures ))
+ , StreamFeatures ))
streamS expectedTo = do
header <- xmppStreamHeader
case header of
@@ -209,48 +234,327 @@ streamS expectedTo = do
case unpickleElem xpStream el of
Left _ -> return $ Left el
Right r -> return $ Right r
- xmppStreamFeatures :: StreamSink ServerFeatures
+ xmppStreamFeatures :: StreamSink StreamFeatures
xmppStreamFeatures = do
e <- lift $ elements =$ CL.head
case e of
Nothing -> throwError XmppOtherFailure
Just r -> streamUnpickleElem xpStreamFeatures r
+-- | Connects to the XMPP server and opens the XMPP stream against the given
+-- host name, port, and realm.
+openStream :: HostName -> PortID -> Text -> IO (Either XmppFailure (TMVar Stream))
+openStream address port hostname = do
+ stream <- connectTcp address port hostname
+ case stream of
+ Right stream' -> do
+ result <- withStream startStream stream'
+ return $ Right stream'
+ Left e -> do
+ return $ Left e
-xpStream :: PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
-xpStream = ("xpStream","") xpElemAttrs
- (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream"))
- (xp5Tuple
- (xpAttr "version" xpId)
- (xpAttrImplied "from" xpPrim)
- (xpAttrImplied "to" xpPrim)
- (xpAttrImplied "id" xpId)
- xpLangTag
- )
+-- | Send "" and wait for the server to finish processing and to
+-- close the connection. Any remaining elements from the server are returned.
+-- Surpresses StreamEndFailure exceptions, but may throw a StreamCloseError.
+closeStreams :: TMVar Stream -> IO (Either XmppFailure [Element])
+closeStreams = withStream $ do
+ send <- gets (streamSend . streamHandle)
+ cc <- gets (streamClose . streamHandle)
+ liftIO $ send ""
+ void $ liftIO $ forkIO $ do
+ threadDelay 3000000 -- TODO: Configurable value
+ (Ex.try cc) :: IO (Either Ex.SomeException ())
+ return ()
+ collectElems []
+ where
+ -- Pulls elements from the stream until the stream ends, or an error is
+ -- raised.
+ collectElems :: [Element] -> StateT Stream IO (Either XmppFailure [Element])
+ collectElems es = do
+ result <- pullElement
+ case result of
+ Left StreamEndFailure -> return $ Right es
+ Left e -> return $ Left $ StreamCloseError (es, e)
+ Right e -> collectElems (e:es)
+
+-- Enable/disable debug output
+-- This will dump all incoming and outgoing network taffic to the console,
+-- prefixed with "in: " and "out: " respectively
+debug :: Bool
+debug = False
+
+-- TODO: Can the TLS send/recv functions throw something other than an IO error?
+
+wrapIOException :: IO a -> StateT Stream IO (Either XmppFailure a)
+wrapIOException action = do
+ r <- liftIO $ tryIOError action
+ case r of
+ Right b -> return $ Right b
+ Left e -> return $ Left $ XmppIOException e
+
+pushElement :: Element -> StateT Stream IO (Either XmppFailure Bool)
+pushElement x = do
+ send <- gets (streamSend . streamHandle)
+ wrapIOException $ send $ renderElement x
+
+-- | Encode and send stanza
+pushStanza :: Stanza -> TMVar Stream -> IO (Either XmppFailure Bool)
+pushStanza s = withStream' . pushElement $ pickleElem xpStanza s
+
+-- XML documents and XMPP streams SHOULD be preceeded by an XML declaration.
+-- UTF-8 is the only supported XMPP encoding. The standalone document
+-- declaration (matching "SDDecl" in the XML standard) MUST NOT be included in
+-- XMPP streams. RFC 6120 defines XMPP only in terms of XML 1.0.
+pushXmlDecl :: StateT Stream IO (Either XmppFailure Bool)
+pushXmlDecl = do
+ con <- gets streamHandle
+ wrapIOException $ (streamSend con) ""
+
+pushOpenElement :: Element -> StateT Stream IO (Either XmppFailure Bool)
+pushOpenElement e = do
+ sink <- gets (streamSend . streamHandle)
+ wrapIOException $ sink $ renderOpenElement e
+
+-- `Connect-and-resumes' the given sink to the stream source, and pulls a
+-- `b' value.
+runEventsSink :: Sink Event IO b -> StateT Stream IO (Either XmppFailure b)
+runEventsSink snk = do -- TODO: Wrap exceptions?
+ source <- gets streamEventSource
+ (src', r) <- lift $ source $$++ snk
+ modify (\s -> s{streamEventSource = src'})
+ return $ Right r
+
+pullElement :: StateT Stream IO (Either XmppFailure Element)
+pullElement = do
+ ExL.catches (do
+ e <- runEventsSink (elements =$ await)
+ case e of
+ Left f -> return $ Left f
+ Right Nothing -> return $ Left XmppOtherFailure -- TODO
+ Right (Just r) -> return $ Right r
+ )
+ [ ExL.Handler (\StreamEnd -> return $ Left StreamEndFailure)
+ , ExL.Handler (\(InvalidXmppXml s) -- Invalid XML `Event' encountered, or missing element close tag
+ -> return $ Left XmppOtherFailure) -- TODO: Log: s
+ , ExL.Handler $ \(e :: InvalidEventStream) -- xml-conduit exception
+ -> return $ Left XmppOtherFailure -- TODO: Log: (show e)
+ ]
--- Pickler/Unpickler for the stream features - TLS, SASL, and the rest.
-xpStreamFeatures :: PU [Node] ServerFeatures
-xpStreamFeatures = ("xpStreamFeatures", "") xpWrap
- (\(tls, sasl, rest) -> SF tls (mbl sasl) rest)
- (\(SF tls sasl rest) -> (tls, lmb sasl, rest))
- (xpElemNodes
- (Name
- "features"
- (Just "http://etherx.jabber.org/streams")
- (Just "stream")
- )
- (xpTriple
- (xpOption pickleTlsFeature)
- (xpOption pickleSaslFeature)
- (xpAll xpElemVerbatim)
- )
+-- Pulls an element and unpickles it.
+pullUnpickle :: PU [Node] a -> StateT Stream IO (Either XmppFailure a)
+pullUnpickle p = do
+ elem <- pullElement
+ case elem of
+ Left e -> return $ Left e
+ Right elem' -> do
+ let res = unpickleElem p elem'
+ case res of
+ Left e -> return $ Left XmppOtherFailure -- TODO: Log
+ Right r -> return $ Right r
+
+-- | Pulls a stanza (or stream error) from the stream.
+pullStanza :: TMVar Stream -> IO (Either XmppFailure Stanza)
+pullStanza = withStream' $ do
+ res <- pullUnpickle xpStreamStanza
+ case res of
+ Left e -> return $ Left e
+ Right (Left e) -> return $ Left $ StreamErrorFailure e
+ Right (Right r) -> return $ Right r
+
+-- Performs the given IO operation, catches any errors and re-throws everything
+-- except 'ResourceVanished' and IllegalOperation, in which case it will return False instead
+catchPush :: IO () -> IO Bool
+catchPush p = ExL.catch
+ (p >> return True)
+ (\e -> case GIE.ioe_type e of
+ GIE.ResourceVanished -> return False
+ GIE.IllegalOperation -> return False
+ _ -> ExL.throwIO e
)
+
+-- Stream state used when there is no connection.
+xmppNoStream :: Stream
+xmppNoStream = Stream {
+ streamState = Closed
+ , streamHandle = StreamHandle { streamSend = \_ -> return False
+ , streamReceive = \_ -> ExL.throwIO
+ XmppOtherFailure
+ , streamFlush = return ()
+ , streamClose = return ()
+ }
+ , streamEventSource = DCI.ResumableSource zeroSource (return ())
+ , streamFeatures = StreamFeatures Nothing [] []
+ , streamHostname = Nothing
+ , streamFrom = Nothing
+ , streamId = Nothing
+ , streamLang = Nothing
+ , streamJid = Nothing
+ , preferredLang = Nothing
+ , toJid = Nothing
+ , includeJidWhenPlain = False
+ }
+ where
+ zeroSource :: Source IO output
+ zeroSource = liftIO . ExL.throwIO $ XmppOtherFailure
+
+connectTcp :: HostName -> PortID -> Text -> IO (Either XmppFailure (TMVar Stream))
+connectTcp host port hostname = do
+ let PortNumber portNumber = port
+ debugM "Pontarius.Xmpp" $ "Connecting to " ++ host ++ " on port " ++
+ (show portNumber) ++ " through the realm " ++ (T.unpack hostname) ++ "."
+ h <- connectTo host port
+ debugM "Pontarius.Xmpp" "Setting NoBuffering mode on handle."
+ hSetBuffering h NoBuffering
+ let eSource = DCI.ResumableSource
+ ((sourceHandle h $= logConduit) $= XP.parseBytes def)
+ (return ())
+ let hand = StreamHandle { streamSend = \d -> do
+ let d64 = encode d
+ debugM "Pontarius.Xmpp" $
+ "Sending TCP data: " ++ (BSC8.unpack d64)
+ ++ "."
+ catchPush $ BS.hPut h d
+ , streamReceive = \n -> do
+ d <- BS.hGetSome h n
+ let d64 = encode d
+ debugM "Pontarius.Xmpp" $
+ "Received TCP data: " ++
+ (BSC8.unpack d64) ++ "."
+ return d
+ , streamFlush = hFlush h
+ , streamClose = hClose h
+ }
+ let stream = Stream
+ { streamState = Plain
+ , streamHandle = hand
+ , streamEventSource = eSource
+ , streamFeatures = StreamFeatures Nothing [] []
+ , streamHostname = (Just hostname)
+ , streamFrom = Nothing
+ , streamId = Nothing
+ , streamLang = Nothing
+ , streamJid = Nothing
+ , preferredLang = Nothing -- TODO: Allow user to set
+ , toJid = Nothing -- TODO: Allow user to set
+ , includeJidWhenPlain = False -- TODO: Allow user to set
+ }
+ stream' <- mkStream stream
+ return $ Right stream'
where
- pickleTlsFeature :: PU [Node] Bool
- pickleTlsFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls"
- (xpElemExists "required")
- pickleSaslFeature :: PU [Node] [Text]
- pickleSaslFeature = xpElemNodes
- "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms"
- (xpAll $ xpElemNodes
- "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId))
+ logConduit :: Conduit ByteString IO ByteString
+ logConduit = CL.mapM $ \d -> do
+ let d64 = encode d
+ debugM "Pontarius.Xmpp" $ "Received TCP data: " ++ (BSC8.unpack d64) ++
+ "."
+ return d
+
+
+-- Closes the connection and updates the XmppConMonad Stream state.
+-- killStream :: TMVar Stream -> IO (Either ExL.SomeException ())
+killStream :: TMVar Stream -> IO (Either XmppFailure ())
+killStream = withStream $ do
+ cc <- gets (streamClose . streamHandle)
+ err <- wrapIOException cc
+ -- (ExL.try cc :: IO (Either ExL.SomeException ()))
+ put xmppNoStream
+ return err
+
+-- Sends an IQ request and waits for the response. If the response ID does not
+-- match the outgoing ID, an error is thrown.
+pushIQ :: StanzaId
+ -> Maybe Jid
+ -> IQRequestType
+ -> Maybe LangTag
+ -> Element
+ -> TMVar Stream
+ -> IO (Either XmppFailure (Either IQError IQResult))
+pushIQ iqID to tp lang body stream = do
+ pushStanza (IQRequestS $ IQRequest iqID Nothing to lang tp body) stream
+ res <- pullStanza stream
+ case res of
+ Left e -> return $ Left e
+ Right (IQErrorS e) -> return $ Right $ Left e
+ Right (IQResultS r) -> do
+ unless
+ (iqID == iqResultID r) . liftIO . ExL.throwIO $
+ XmppOtherFailure
+ -- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++
+ -- " /= " ++ show (iqResultID r) ++ " .")
+ return $ Right $ Right r
+ _ -> return $ Left XmppOtherFailure
+ -- TODO: Log: "sendIQ': unexpected stanza type "
+
+debugConduit :: Pipe l ByteString ByteString u IO b
+debugConduit = forever $ do
+ s' <- await
+ case s' of
+ Just s -> do
+ liftIO $ BS.putStrLn (BS.append "in: " s)
+ yield s
+ Nothing -> return ()
+
+elements :: R.MonadThrow m => Conduit Event m Element
+elements = do
+ x <- await
+ case x of
+ Just (EventBeginElement n as) -> do
+ goE n as >>= yield
+ elements
+ Just (EventEndElement streamName) -> lift $ R.monadThrow StreamEnd
+ Nothing -> return ()
+ _ -> lift $ R.monadThrow $ InvalidXmppXml $ "not an element: " ++ show x
+ where
+ many' f =
+ go id
+ where
+ go front = do
+ x <- f
+ case x of
+ Left x -> return $ (x, front [])
+ Right y -> go (front . (:) y)
+ goE n as = do
+ (y, ns) <- many' goN
+ if y == Just (EventEndElement n)
+ then return $ Element n as $ compressNodes ns
+ else lift $ R.monadThrow $ InvalidXmppXml $
+ "Missing close tag: " ++ show n
+ goN = do
+ x <- await
+ case x of
+ Just (EventBeginElement n as) -> (Right . NodeElement) <$> goE n as
+ Just (EventInstruction i) -> return $ Right $ NodeInstruction i
+ Just (EventContent c) -> return $ Right $ NodeContent c
+ Just (EventComment t) -> return $ Right $ NodeComment t
+ Just (EventCDATA t) -> return $ Right $ NodeContent $ ContentText t
+ _ -> return $ Left x
+
+ compressNodes :: [Node] -> [Node]
+ compressNodes [] = []
+ compressNodes [x] = [x]
+ compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) =
+ compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z
+ compressNodes (x:xs) = x : compressNodes xs
+
+ streamName :: Name
+ streamName = (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream"))
+
+withStream :: StateT Stream IO (Either XmppFailure c) -> TMVar Stream -> IO (Either XmppFailure c)
+withStream action stream = bracketOnError
+ (atomically $ takeTMVar stream)
+ (atomically . putTMVar stream)
+ (\s -> do
+ (r, s') <- runStateT action s
+ atomically $ putTMVar stream s'
+ return r
+ )
+
+-- nonblocking version. Changes to the connection are ignored!
+withStream' :: StateT Stream IO (Either XmppFailure b) -> TMVar Stream -> IO (Either XmppFailure b)
+withStream' action stream = do
+ stream_ <- atomically $ readTMVar stream
+ (r, _) <- runStateT action stream_
+ return r
+
+
+mkStream :: Stream -> IO (TMVar Stream)
+mkStream con = {- Stream `fmap` -} (atomically $ newTMVar con)
diff --git a/source/Network/Xmpp/Tls.hs b/source/Network/Xmpp/Tls.hs
index 0d5754e..88cf37e 100644
--- a/source/Network/Xmpp/Tls.hs
+++ b/source/Network/Xmpp/Tls.hs
@@ -13,20 +13,23 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.Conduit
import qualified Data.Conduit.Binary as CB
-import Data.Conduit.Tls as TLS
import Data.Typeable
import Data.XML.Types
-import Network.Xmpp.Connection_
import Network.Xmpp.Stream
import Network.Xmpp.Types
import Control.Concurrent.STM.TMVar
-mkBackend con = Backend { backendSend = \bs -> void (cSend con bs)
- , backendRecv = cRecv con
- , backendFlush = cFlush con
- , backendClose = cClose con
+import Data.IORef
+import Crypto.Random.API
+import Network.TLS
+import Network.TLS.Extra
+
+mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs)
+ , backendRecv = streamReceive con
+ , backendFlush = streamFlush con
+ , backendClose = streamClose con
}
where
cutBytes n = do
@@ -62,44 +65,98 @@ cutBytes n = do
starttlsE :: Element
starttlsE = Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] []
-exampleParams :: TLS.TLSParams
-exampleParams = TLS.defaultParamsClient
- { pConnectVersion = TLS.TLS10
- , pAllowedVersions = [TLS.SSL3, TLS.TLS10, TLS.TLS11]
- , pCiphers = [TLS.cipher_AES128_SHA1]
- , pCompressions = [TLS.nullCompression]
+exampleParams :: TLSParams
+exampleParams = defaultParamsClient
+ { pConnectVersion = TLS10
+ , pAllowedVersions = [SSL3, TLS10, TLS11]
+ , pCiphers = [cipher_AES128_SHA1]
+ , pCompressions = [nullCompression]
, pUseSecureRenegotiation = False -- No renegotiation
, onCertificatesRecv = \_certificate ->
- return TLS.CertificateUsageAccept
+ return CertificateUsageAccept
}
-- Pushes ", waits for "", performs the TLS handshake, and
-- restarts the stream.
-startTls :: TLS.TLSParams -> TMVar Connection -> IO (Either XmppFailure ())
+startTls :: TLSParams -> TMVar Stream -> IO (Either XmppFailure ())
startTls params con = Ex.handle (return . Left . TlsError)
- . flip withConnection con
+ . flip withStream con
. runErrorT $ do
- features <- lift $ gets cFeatures
- state <- gets cState
+ features <- lift $ gets streamFeatures
+ state <- gets streamState
case state of
- ConnectionPlain -> return ()
- ConnectionClosed -> throwError XmppNoConnection
- ConnectionSecured -> throwError TlsConnectionSecured
- con <- lift $ gets cHandle
- when (stls features == Nothing) $ throwError TlsNoServerSupport
+ Plain -> return ()
+ Closed -> throwError XmppNoStream
+ Secured -> throwError TlsStreamSecured
+ con <- lift $ gets streamHandle
+ when (streamTls features == Nothing) $ throwError TlsNoServerSupport
lift $ pushElement starttlsE
answer <- lift $ pullElement
case answer of
Left e -> return $ Left e
Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] []) -> return $ Right ()
Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _) -> return $ Left XmppOtherFailure
- (raw, _snk, psh, read, ctx) <- lift $ TLS.tlsinit debug params (mkBackend con)
- let newHand = ConnectionHandle { cSend = catchPush . psh
- , cRecv = read
- , cFlush = contextFlush ctx
- , cClose = bye ctx >> cClose con
+ (raw, _snk, psh, read, ctx) <- lift $ tlsinit debug params (mkBackend con)
+ let newHand = StreamHandle { streamSend = catchPush . psh
+ , streamReceive = read
+ , streamFlush = contextFlush ctx
+ , streamClose = bye ctx >> streamClose con
}
- lift $ modify ( \x -> x {cHandle = newHand})
+ lift $ modify ( \x -> x {streamHandle = newHand})
either (lift . Ex.throwIO) return =<< lift restartStream
- modify (\s -> s{cState = ConnectionSecured})
+ modify (\s -> s{streamState = Secured})
return ()
+
+client params gen backend = do
+ contextNew backend params gen
+
+defaultParams = defaultParamsClient
+
+tlsinit :: (MonadIO m, MonadIO m1) =>
+ Bool
+ -> TLSParams
+ -> Backend
+ -> m ( Source m1 BS.ByteString
+ , Sink BS.ByteString m1 ()
+ , BS.ByteString -> IO ()
+ , Int -> m1 BS.ByteString
+ , Context
+ )
+tlsinit debug tlsParams backend = do
+ when debug . liftIO $ putStrLn "TLS with debug mode enabled"
+ gen <- liftIO $ getSystemRandomGen -- TODO: Find better random source?
+ con <- client tlsParams gen backend
+ handshake con
+ let src = forever $ do
+ dt <- liftIO $ recvData con
+ when debug (liftIO $ putStr "in: " >> BS.putStrLn dt)
+ yield dt
+ let snk = do
+ d <- await
+ case d of
+ Nothing -> return ()
+ Just x -> do
+ sendData con (BL.fromChunks [x])
+ when debug (liftIO $ putStr "out: " >> BS.putStrLn x)
+ snk
+ read <- liftIO $ mkReadBuffer (recvData con)
+ return ( src
+ , snk
+ , \s -> do
+ when debug (liftIO $ BS.putStrLn s)
+ sendData con $ BL.fromChunks [s]
+ , liftIO . read
+ , con
+ )
+
+mkReadBuffer :: IO BS.ByteString -> IO (Int -> IO BS.ByteString)
+mkReadBuffer read = do
+ buffer <- newIORef BS.empty
+ let read' n = do
+ nc <- readIORef buffer
+ bs <- if BS.null nc then read
+ else return nc
+ let (result, rest) = BS.splitAt n bs
+ writeIORef buffer rest
+ return result
+ return read'
diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs
index f36548d..182a47b 100644
--- a/source/Network/Xmpp/Types.hs
+++ b/source/Network/Xmpp/Types.hs
@@ -22,7 +22,7 @@ module Network.Xmpp.Types
, PresenceType(..)
, SaslError(..)
, SaslFailure(..)
- , ServerFeatures(..)
+ , StreamFeatures(..)
, Stanza(..)
, StanzaError(..)
, StanzaErrorCondition(..)
@@ -31,19 +31,20 @@ module Network.Xmpp.Types
, XmppFailure(..)
, StreamErrorCondition(..)
, Version(..)
- , ConnectionHandle(..)
- , Connection(..)
- , withConnection
- , withConnection'
- , mkConnection
- , ConnectionState(..)
+ , StreamHandle(..)
+ , Stream(..)
+ , StreamState(..)
, StreamErrorInfo(..)
, langTag
- , module Network.Xmpp.Jid
+ , Jid(..)
+ , isBare
+ , isFull
+ , fromString
+ , StreamEnd(..)
+ , InvalidXmppXml(..)
)
where
-import Control.Applicative ((<$>), many)
import Control.Concurrent.STM
import Control.Exception
import Control.Monad.Error
@@ -65,24 +66,30 @@ import qualified Network.TLS as TLS
import qualified Network as N
-import Network.Xmpp.Jid
-
import System.IO
+import Control.Applicative ((<$>), (<|>), many)
+import Control.Monad(guard)
+
+import qualified Data.Set as Set
+import Data.String (IsString(..))
+import qualified Text.NamePrep as SP
+import qualified Text.StringPrep as SP
+
-- |
-- Wraps a string of random characters that, when using an appropriate
--- @IDGenerator@, is guaranteed to be unique for the Xmpp session.
+-- @IdGenerator@, is guaranteed to be unique for the Xmpp session.
-data StanzaID = SI !Text deriving (Eq, Ord)
+data StanzaId = StanzaId !Text deriving (Eq, Ord)
-instance Show StanzaID where
- show (SI s) = Text.unpack s
+instance Show StanzaId where
+ show (StanzaId s) = Text.unpack s
-instance Read StanzaID where
- readsPrec _ x = [(SI $ Text.pack x, "")]
+instance Read StanzaId where
+ readsPrec _ x = [(StanzaId $ Text.pack x, "")]
-instance IsString StanzaID where
- fromString = SI . Text.pack
+instance IsString StanzaId where
+ fromString = StanzaId . Text.pack
-- | The Xmpp communication primities (Message, Presence and Info/Query) are
-- called stanzas.
@@ -644,8 +651,8 @@ data XmppFailure = StreamErrorFailure StreamErrorInfo -- ^ An error XML stream
-- far.
| TlsError TLS.TLSError
| TlsNoServerSupport
- | XmppNoConnection
- | TlsConnectionSecured -- ^ Connection already secured
+ | XmppNoStream
+ | TlsStreamSecured -- ^ Connection already secured
| XmppOtherFailure -- ^ Undefined condition. More
-- information should be available
-- in the log.
@@ -747,71 +754,253 @@ langTagParser = do
tagChars :: [Char]
tagChars = ['a'..'z'] ++ ['A'..'Z']
-data ServerFeatures = SF
- { stls :: !(Maybe Bool)
- , saslMechanisms :: ![Text.Text]
- , other :: ![Element]
+data StreamFeatures = StreamFeatures
+ { streamTls :: !(Maybe Bool)
+ , streamSaslMechanisms :: ![Text.Text]
+ , streamOtherFeatures :: ![Element] -- TODO: All feature elements instead?
} deriving Show
--- | Signals the state of the connection.
-data ConnectionState
- = ConnectionClosed -- ^ No connection at this point.
- | ConnectionPlain -- ^ Connection established, but not secured.
- | ConnectionSecured -- ^ Connection established and secured via TLS.
+-- | Signals the state of the stream connection.
+data StreamState
+ = Closed -- ^ No stream has been established
+ | Plain -- ^ Stream established, but not secured via TLS
+ | Secured -- ^ Stream established and secured via TLS
deriving (Show, Eq, Typeable)
-- | Defines operations for sending, receiving, flushing, and closing on a
--- connection.
-data ConnectionHandle =
- ConnectionHandle { cSend :: BS.ByteString -> IO Bool
- , cRecv :: Int -> IO BS.ByteString
- -- This is to hold the state of the XML parser (otherwise
- -- we will receive EventBeginDocument events and forget
- -- about name prefixes).
- , cFlush :: IO ()
- , cClose :: IO ()
- }
-
-data Connection = Connection
- { cState :: !ConnectionState -- ^ State of connection
- , cHandle :: ConnectionHandle -- ^ Handle to send, receive, flush, and close
- -- on the connection.
- , cEventSource :: ResumableSource IO Event -- ^ Event conduit source, and
- -- its associated finalizer
- , cFeatures :: !ServerFeatures -- ^ Features as advertised by the server
- , cHostName :: !(Maybe Text) -- ^ Hostname of the server
- , cJid :: !(Maybe Jid) -- ^ Our JID
- , cPreferredLang :: !(Maybe LangTag) -- ^ Default language when no explicit
+-- stream.
+data StreamHandle =
+ StreamHandle { streamSend :: BS.ByteString -> IO Bool
+ , streamReceive :: Int -> IO BS.ByteString
+ -- This is to hold the state of the XML parser (otherwise we
+ -- will receive EventBeginDocument events and forget about
+ -- name prefixes). (TODO: Clarify)
+ , streamFlush :: IO ()
+ , streamClose :: IO ()
+ }
+
+data Stream = Stream
+ { -- | State of the stream - 'Closed', 'Plain', or 'Secured'
+ streamState :: !StreamState -- ^ State of connection
+ -- | Functions to send, receive, flush, and close on the stream
+ , streamHandle :: StreamHandle
+ -- | Event conduit source, and its associated finalizer
+ , streamEventSource :: ResumableSource IO Event
+ -- | Stream features advertised by the server
+ , streamFeatures :: !StreamFeatures -- TODO: Maybe?
+ -- | The hostname we specified for the connection
+ , streamHostname :: !(Maybe Text)
+ -- | The hostname specified in the server's stream element's
+ -- `from' attribute
+ , streamFrom :: !(Maybe Jid)
+ -- | The identifier specified in the server's stream element's
+ -- `id' attribute
+ , streamId :: !(Maybe Text)
+ -- | The language tag value specified in the server's stream
+ -- element's `langtag' attribute; will be a `Just' value once
+ -- connected to the server
+ -- TODO: Verify
+ , streamLang :: !(Maybe LangTag)
+ -- | Our JID as assigned by the server
+ , streamJid :: !(Maybe Jid)
+ -- TODO: Move the below fields to a configuration record
+ , preferredLang :: !(Maybe LangTag) -- ^ Default language when no explicit
-- language tag is set
- , cStreamLang :: !(Maybe LangTag) -- ^ Will be a `Just' value once connected
- -- to the server.
- , cStreamId :: !(Maybe Text) -- ^ Stream ID as specified by the server.
- , cToJid :: !(Maybe Jid) -- ^ JID to include in the stream element's `to'
+ , toJid :: !(Maybe Jid) -- ^ JID to include in the stream element's `to'
-- attribute when the connection is secured. See
-- also below.
- , cJidWhenPlain :: !Bool -- ^ Whether or not to also include the Jid when
+ , includeJidWhenPlain :: !Bool -- ^ Whether or not to also include the Jid when
-- the connection is plain.
- , cFrom :: !(Maybe Jid) -- ^ From as specified by the server in the stream
- -- element's `from' attribute.
}
-withConnection :: StateT Connection IO (Either XmppFailure c) -> TMVar Connection -> IO (Either XmppFailure c)
-withConnection action con = bracketOnError
- (atomically $ takeTMVar con)
- (atomically . putTMVar con )
- (\c -> do
- (r, c') <- runStateT action c
- atomically $ putTMVar con c'
- return r
- )
-
--- nonblocking version. Changes to the connection are ignored!
-withConnection' :: StateT Connection IO (Either XmppFailure b) -> TMVar Connection -> IO (Either XmppFailure b)
-withConnection' action con = do
- con_ <- atomically $ readTMVar con
- (r, _) <- runStateT action con_
- return r
-
-
-mkConnection :: Connection -> IO (TMVar Connection)
-mkConnection con = {- Connection `fmap` -} (atomically $ newTMVar con)
+---------------
+-- JID
+---------------
+
+-- | A JID is XMPP\'s native format for addressing entities in the network. It
+-- is somewhat similar to an e-mail address but contains three parts instead of
+-- two.
+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)
+ } deriving Eq
+
+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
+
+-- | Converts localpart, domainpart, and resourcepart strings to a JID. Runs the
+-- appropriate stringprep profiles and validates the parts.
+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
+ validDomainPart :: Text -> Bool
+ validDomainPart _s = True -- TODO
+
+ validPartLength :: Text -> Bool
+ validPartLength p = Text.length p > 0 && Text.length p < 1024
+
+-- | 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 = not . isBare
+
+-- Parses an JID string and returns its three parts. It performs no validation
+-- or transformations.
+jidParts :: AP.Parser (Maybe Text, Text, Maybe Text)
+jidParts = do
+ -- Read until we reach an '@', a '/', or EOF.
+ 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
+ b <- domainPartP
+ -- Case 1A: We found a '/' and thus have all the JID parts. Read the '/'
+ -- and until EOF.
+ do
+ 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
+ AP.endOfInput
+ return (Just a, b, Nothing)
+ -- Case 2: We found a '/'; the JID is in the form
+ -- domainpart/resourcepart.
+ <|> do
+ 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
+ AP.endOfInput
+ return (Nothing, a, Nothing)
+ where
+ -- Read an '@' and everything until a '/'.
+ domainPartP :: AP.Parser Text
+ domainPartP = do
+ _ <- AP.char '@'
+ AP.takeWhile1 (/= '/')
+ -- Read everything until a '/'.
+ resourcePartP :: AP.Parser Text
+ resourcePartP = do
+ _ <- AP.char '/'
+ AP.takeText
+
+-- The `nodeprep' StringPrep profile.
+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 characters needs to be checked for after normalization.
+nodeprepExtraProhibitedCharacters :: [Char]
+nodeprepExtraProhibitedCharacters = ['\x22', '\x26', '\x27', '\x2F', '\x3A',
+ '\x3C', '\x3E', '\x40']
+
+-- The `resourceprep' StringPrep profile.
+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
+ }
+
+data StreamEnd = StreamEnd deriving (Typeable, Show)
+instance Exception StreamEnd
+
+data InvalidXmppXml = InvalidXmppXml String deriving (Show, Typeable)
+
+instance Exception InvalidXmppXml
diff --git a/source/Network/Xmpp/Utilities.hs b/source/Network/Xmpp/Utilities.hs
index 11441a8..8b4864f 100644
--- a/source/Network/Xmpp/Utilities.hs
+++ b/source/Network/Xmpp/Utilities.hs
@@ -1,8 +1,9 @@
-{-# OPTIONS_HADDOCK hide #-}
-
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
-module Network.Xmpp.Utilities (idGenerator) where
+{-# OPTIONS_HADDOCK hide #-}
+
+module Network.Xmpp.Utilities (presTo, message, answerMessage, openElementToEvents, renderOpenElement, renderElement) where
import Network.Xmpp.Types
@@ -10,10 +11,29 @@ import Control.Monad.STM
import Control.Concurrent.STM.TVar
import Prelude
+import Data.XML.Types
+
import qualified Data.Attoparsec.Text as AP
import qualified Data.Text as Text
+import qualified Data.ByteString as BS
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import System.IO.Unsafe(unsafePerformIO)
+import Data.Conduit.List as CL
+-- import Data.Typeable
+import Control.Applicative ((<$>))
+import Control.Exception
+import Control.Monad.Trans.Class
+
+import Data.Conduit as C
+import Data.XML.Types
+
+import qualified Text.XML.Stream.Render as TXSR
+import Text.XML.Unresolved as TXU
+
+-- TODO: Not used, and should probably be removed.
-- | Creates a new @IdGenerator@. Internally, it will maintain an infinite list
-- of IDs ('[\'a\', \'b\', \'c\'...]'). The argument is a prefix to prepend the
-- IDs with. Calling the function will extract an ID and update the generator's
@@ -36,11 +56,11 @@ idGenerator prefix = atomically $ do
-- Generates an infinite and predictable list of IDs, all beginning with the
-- provided prefix. Adds the prefix to all combinations of IDs (ids').
ids :: Text.Text -> [Text.Text]
- ids p = map (\ id -> Text.append p id) ids'
+ ids p = Prelude.map (\ id -> Text.append p id) ids'
where
-- Generate all combinations of IDs, with increasing length.
ids' :: [Text.Text]
- ids' = map Text.pack $ concatMap ids'' [1..]
+ ids' = Prelude.map Text.pack $ Prelude.concatMap ids'' [1..]
-- Generates all combinations of IDs with the given length.
ids'' :: Integer -> [String]
ids'' 0 = [""]
@@ -52,3 +72,55 @@ idGenerator prefix = atomically $ do
-- Constructs a "Version" based on the major and minor version numbers.
versionFromNumbers :: Integer -> Integer -> Version
versionFromNumbers major minor = Version major minor
+
+-- | Add a recipient to a presence notification.
+presTo :: Presence -> Jid -> Presence
+presTo pres to = pres{presenceTo = Just to}
+
+-- | An empty message.
+message :: Message
+message = Message { messageID = Nothing
+ , messageFrom = Nothing
+ , messageTo = Nothing
+ , messageLangTag = Nothing
+ , messageType = Normal
+ , messagePayload = []
+ }
+
+-- Produce an answer message with the given payload, switching the "from" and
+-- "to" attributes in the original message.
+answerMessage :: Message -> [Element] -> Maybe Message
+answerMessage Message{messageFrom = Just frm, ..} payload =
+ Just Message{ messageFrom = messageTo
+ , messageID = Nothing
+ , messageTo = Just frm
+ , messagePayload = payload
+ , ..
+ }
+answerMessage _ _ = Nothing
+
+openElementToEvents :: Element -> [Event]
+openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns []
+ where
+ goE (Element name' as' ns') =
+ (EventBeginElement name' as' :)
+ . goN ns'
+ . (EventEndElement name' :)
+ goN [] = id
+ goN [x] = goN' x
+ goN (x:xs) = goN' x . goN xs
+ goN' (NodeElement e) = goE e
+ goN' (NodeInstruction i) = (EventInstruction i :)
+ goN' (NodeContent c) = (EventContent c :)
+ goN' (NodeComment t) = (EventComment t :)
+
+renderOpenElement :: Element -> BS.ByteString
+renderOpenElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO
+ $ CL.sourceList (openElementToEvents e) $$ TXSR.renderText def =$ CL.consume
+
+renderElement :: Element -> BS.ByteString
+renderElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO
+ $ CL.sourceList (elementToEvents e) $$ TXSR.renderText def =$ CL.consume
+ where
+ elementToEvents :: Element -> [Event]
+ elementToEvents e@(Element name _ _) = openElementToEvents e ++ [EventEndElement name]
diff --git a/source/Network/Xmpp/Xep/InbandRegistration.hs b/source/Network/Xmpp/Xep/InbandRegistration.hs
index 27deeb8..bbbc1a5 100644
--- a/source/Network/Xmpp/Xep/InbandRegistration.hs
+++ b/source/Network/Xmpp/Xep/InbandRegistration.hs
@@ -19,11 +19,7 @@ import qualified Data.Text as Text
import Data.XML.Pickle
import qualified Data.XML.Types as XML
-import Network.Xmpp.Connection_
-import Network.Xmpp.Pickle
-import Network.Xmpp.Types
-import Network.Xmpp.Basic
-import Network.Xmpp
+import Network.Xmpp.Internal
import Network.Xmpp.Xep.ServiceDiscovery
@@ -34,7 +30,7 @@ ibrns = "jabber:iq:register"
ibrName x = (XML.Name x (Just ibrns) Nothing)
data IbrError = IbrNotSupported
- | IbrNoConnection
+ | IbrNoStream
| IbrIQError IQError
| IbrTimeout
@@ -50,9 +46,33 @@ data Query = Query { instructions :: Maybe Text.Text
emptyQuery = Query Nothing False False []
-query :: IQRequestType -> Query -> TMVar Connection -> IO (Either IbrError Query)
+-- supported :: XmppConMonad (Either IbrError Bool)
+-- supported = runErrorT $ fromFeatures <+> fromDisco
+-- where
+-- fromFeatures = do
+-- fs <- other <$> gets sFeatures
+-- let fe = XML.Element
+-- "{http://jabber.org/features/iq-register}register"
+-- []
+-- []
+-- return $ fe `elem` fs
+-- fromDisco = do
+-- hn' <- gets sHostname
+-- hn <- case hn' of
+-- Just h -> return (Jid Nothing h Nothing)
+-- Nothing -> throwError IbrNoStream
+-- qi <- lift $ xmppQueryInfo Nothing Nothing
+-- case qi of
+-- Left e -> return False
+-- Right qir -> return $ "jabber:iq:register" `elem` qiFeatures qir
+-- f <+> g = do
+-- r <- f
+-- if r then return True else g
+
+
+query :: IQRequestType -> Query -> TMVar Stream -> IO (Either IbrError Query)
query queryType x con = do
- answer <- pushIQ' "ibr" Nothing queryType Nothing (pickleElem xpQuery x) con
+ answer <- pushIQ "ibr" Nothing queryType Nothing (pickleElem xpQuery x) con
case answer of
Right IQResult{iqResultPayload = Just b} ->
case unpickleElem xpQuery b of
@@ -93,7 +113,7 @@ mapError f = mapErrorT (liftM $ left f)
-- | Retrieve the necessary fields and fill them in to register an account with
-- the server.
registerWith :: [(Field, Text.Text)]
- -> TMVar Connection
+ -> TMVar Stream
-> IO (Either RegisterError Query)
registerWith givenFields con = runErrorT $ do
fs <- mapError IbrError . ErrorT $ requestFields con
@@ -125,7 +145,7 @@ deleteAccount host hostname port username password = do
-- | Terminate your account on the server. You have to be logged in for this to
-- work. You connection will most likely be terminated after unregistering.
-unregister :: TMVar Connection -> IO (Either IbrError Query)
+unregister :: TMVar Stream -> IO (Either IbrError Query)
unregister = query Set $ emptyQuery {remove = True}
unregister' :: Session -> IO (Either IbrError Query)
@@ -216,3 +236,6 @@ instance Read Field where
-- Registered
-- Instructions
+
+ppElement :: Element -> String
+ppElement = Text.unpack . Text.decodeUtf8 . renderElement
diff --git a/source/Network/Xmpp/Xep/ServiceDiscovery.hs b/source/Network/Xmpp/Xep/ServiceDiscovery.hs
index d5325e0..be654ff 100644
--- a/source/Network/Xmpp/Xep/ServiceDiscovery.hs
+++ b/source/Network/Xmpp/Xep/ServiceDiscovery.hs
@@ -25,11 +25,7 @@ import Data.XML.Pickle
import Data.XML.Types
import Network.Xmpp
-import Network.Xmpp.Concurrent
-import Network.Xmpp.Concurrent.Types
-import Network.Xmpp.Connection_
-import Network.Xmpp.Pickle
-import Network.Xmpp.Types
+import Network.Xmpp.Internal
import Control.Concurrent.STM.TMVar
data DiscoError = DiscoNoQueryElement
@@ -105,10 +101,10 @@ queryInfo to node context = do
xmppQueryInfo :: Maybe Jid
-> Maybe Text.Text
- -> TMVar Connection
+ -> TMVar Stream
-> IO (Either DiscoError QueryInfoResult)
xmppQueryInfo to node con = do
- res <- pushIQ' "info" to Get Nothing queryBody con
+ res <- pushIQ "info" to Get Nothing queryBody con
return $ case res of
Left e -> Left $ DiscoIQError Nothing
Right res' -> case res' of
@@ -167,3 +163,27 @@ queryItems to node session = do
Right r -> Right r
where
queryBody = pickleElem xpQueryItems (node, [])
+
+-- Given a pickler and an object, produces an Element.
+pickleElem :: PU [Node] a -> a -> Element
+pickleElem p = pickle $ xpNodeElem p
+
+-- Given a pickler and an element, produces an object.
+unpickleElem :: PU [Node] a -> Element -> Either UnpickleError a
+unpickleElem p x = unpickle (xpNodeElem p) x
+
+xpNodeElem :: PU [Node] a -> PU Element a
+xpNodeElem xp = PU { pickleTree = \x -> Prelude.head $ (pickleTree xp x) >>= \y ->
+ case y of
+ NodeElement e -> [e]
+ _ -> []
+ , unpickleTree = \x -> case unpickleTree xp $ [NodeElement x] of
+ Left l -> Left l
+ Right (a,(_,c)) -> Right (a,(Nothing,c))
+ }
+
+xpLangTag :: PU [Attribute] (Maybe LangTag)
+xpLangTag = xpAttrImplied xmlLang xpPrim
+
+xmlLang :: Name
+xmlLang = Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml")
diff --git a/source/Text/Xml/Stream/Elements.hs b/source/Text/Xml/Stream/Elements.hs
deleted file mode 100644
index a357607..0000000
--- a/source/Text/Xml/Stream/Elements.hs
+++ /dev/null
@@ -1,108 +0,0 @@
-{-# OPTIONS_HADDOCK hide #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Text.Xml.Stream.Elements where
-
-import Control.Applicative ((<$>))
-import Control.Exception
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Resource as R
-
-import qualified Data.ByteString as BS
-import Data.Conduit as C
-import Data.Conduit.List as CL
-import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text
-import Data.Typeable
-import Data.XML.Types
-
-import System.IO.Unsafe(unsafePerformIO)
-
-import qualified Text.XML.Stream.Render as TXSR
-import Text.XML.Unresolved as TXU
-
-compressNodes :: [Node] -> [Node]
-compressNodes [] = []
-compressNodes [x] = [x]
-compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) =
- compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z
-compressNodes (x:xs) = x : compressNodes xs
-
-streamName :: Name
-streamName =
- (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream"))
-
-data StreamEnd = StreamEnd deriving (Typeable, Show)
-instance Exception StreamEnd
-
-data InvalidXmppXml = InvalidXmppXml String deriving (Show, Typeable)
-
-instance Exception InvalidXmppXml
-
-parseElement txt = documentRoot $ TXU.parseText_ TXU.def txt
-
-elements :: R.MonadThrow m => C.Conduit Event m Element
-elements = do
- x <- C.await
- case x of
- Just (EventBeginElement n as) -> do
- goE n as >>= C.yield
- elements
- Just (EventEndElement streamName) -> lift $ R.monadThrow StreamEnd
- Nothing -> return ()
- _ -> lift $ R.monadThrow $ InvalidXmppXml $ "not an element: " ++ show x
- where
- many' f =
- go id
- where
- go front = do
- x <- f
- case x of
- Left x -> return $ (x, front [])
- Right y -> go (front . (:) y)
- goE n as = do
- (y, ns) <- many' goN
- if y == Just (EventEndElement n)
- then return $ Element n as $ compressNodes ns
- else lift $ R.monadThrow $ InvalidXmppXml $
- "Missing close tag: " ++ show n
- goN = do
- x <- await
- case x of
- Just (EventBeginElement n as) -> (Right . NodeElement) <$> goE n as
- Just (EventInstruction i) -> return $ Right $ NodeInstruction i
- Just (EventContent c) -> return $ Right $ NodeContent c
- Just (EventComment t) -> return $ Right $ NodeComment t
- Just (EventCDATA t) -> return $ Right $ NodeContent $ ContentText t
- _ -> return $ Left x
-
-
-openElementToEvents :: Element -> [Event]
-openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns []
- where
- goE (Element name' as' ns') =
- (EventBeginElement name' as' :)
- . goN ns'
- . (EventEndElement name' :)
- goN [] = id
- goN [x] = goN' x
- goN (x:xs) = goN' x . goN xs
- goN' (NodeElement e) = goE e
- goN' (NodeInstruction i) = (EventInstruction i :)
- goN' (NodeContent c) = (EventContent c :)
- goN' (NodeComment t) = (EventComment t :)
-
-elementToEvents :: Element -> [Event]
-elementToEvents e@(Element name _ _) = openElementToEvents e ++ [EventEndElement name]
-
-
-renderOpenElement :: Element -> BS.ByteString
-renderOpenElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO
- $ CL.sourceList (openElementToEvents e) $$ TXSR.renderText def =$ CL.consume
-
-renderElement :: Element -> BS.ByteString
-renderElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO
- $ CL.sourceList (elementToEvents e) $$ TXSR.renderText def =$ CL.consume
-
-ppElement :: Element -> String
-ppElement = Text.unpack . Text.decodeUtf8 . renderElement
\ No newline at end of file