From ec08ba583360c2b3e629ca5f363a29a0ca5a168e Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 28 Nov 2012 14:09:42 +0100 Subject: [PATCH] shape documentation --- pontarius-xmpp.cabal | 9 +- source/Network/Xmpp.hs | 118 +++-------------- source/Network/Xmpp/Concurrent.hs | 1 + source/Network/Xmpp/Concurrent/Channels.hs | 3 +- .../Network/Xmpp/Concurrent/Channels/Basic.hs | 1 + source/Network/Xmpp/Concurrent/Channels/IQ.hs | 1 + .../Xmpp/Concurrent/Channels/Message.hs | 1 + .../Xmpp/Concurrent/Channels/Presence.hs | 1 + .../Network/Xmpp/Concurrent/Channels/Types.hs | 3 +- source/Network/Xmpp/Concurrent/Monad.hs | 1 + source/Network/Xmpp/Concurrent/Threads.hs | 1 + source/Network/Xmpp/IM.hs | 9 +- source/Network/Xmpp/IM/Message.hs | 8 +- source/Network/Xmpp/IM/Presence.hs | 2 + source/Network/Xmpp/Message.hs | 2 + source/Network/Xmpp/Monad.hs | 4 +- source/Network/Xmpp/Pickle.hs | 2 + source/Network/Xmpp/Sasl.hs | 16 ++- source/Network/Xmpp/Sasl/Common.hs | 1 + source/Network/Xmpp/Sasl/Mechanisms.hs | 3 +- .../Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs | 17 ++- source/Network/Xmpp/Sasl/Mechanisms/Plain.hs | 10 +- source/Network/Xmpp/Sasl/Mechanisms/Scram.hs | 5 +- source/Network/Xmpp/Sasl/StringPrep.hs | 1 + source/Network/Xmpp/Sasl/Types.hs | 1 + source/Network/Xmpp/Session.hs | 121 +++++++++++++++--- source/Network/Xmpp/Stream.hs | 1 + source/Network/Xmpp/TLS.hs | 1 + source/Network/Xmpp/Types.hs | 39 +++--- source/Network/Xmpp/Xep/ServiceDiscovery.hs | 1 + 30 files changed, 227 insertions(+), 157 deletions(-) diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 624aa13..af700b9 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -53,9 +53,11 @@ Library , data-default >=0.2 , stringprep >=0.1.3 Exposed-modules: Network.Xmpp - , Network.Xmpp.Bind - , Network.Xmpp.Concurrent , Network.Xmpp.IM + , Network.Xmpp.Basic + Other-modules: + Network.Xmpp.Bind + , Network.Xmpp.Concurrent , Network.Xmpp.IM.Message , Network.Xmpp.IM.Presence , Network.Xmpp.Marshal @@ -74,8 +76,7 @@ Library , Network.Xmpp.TLS , Network.Xmpp.Types , Network.Xmpp.Xep.ServiceDiscovery - Other-modules: - Network.Xmpp.Jid + , Network.Xmpp.Jid , Network.Xmpp.Concurrent.Types , Network.Xmpp.Concurrent.Channels.IQ , Network.Xmpp.Concurrent.Threads diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 0c87fc8..d5f2ea7 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -1,7 +1,6 @@ -- | -- Module: $Header$ --- Description: A work in progress client implementation of RFC 6120 (XMPP: --- Core). +-- Description: RFC 6120 (XMPP: Core). -- License: Apache License 2.0 -- -- Maintainer: info@jonkri.com @@ -37,6 +36,9 @@ module Network.Xmpp , startTLS , simpleAuth , auth + , scramSha1 + , digestMd5 + , plain , closeConnection , endSession , setConnectionClosedHandler @@ -78,11 +80,10 @@ module Network.Xmpp -- or IQ stanza. , getStanzaChan -- ** 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. - -- - -- + -- | 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. It is not to be confused with + -- /instant messaging/ which is handled in the 'Network.Xmpp.IM' module , Message(..) , MessageError(..) , MessageType(..) @@ -101,6 +102,7 @@ module Network.Xmpp -- for communication is signaled end-to-end by means of a dedicated -- communication primitive: the presence stanza. , Presence(..) + , PresenceType(..) , PresenceError(..) -- *** Creating , module Network.Xmpp.Presence @@ -147,10 +149,8 @@ module Network.Xmpp , exampleParams ) where -import Data.Text as Text +import Data.XML.Types (Element) -import Network -import qualified Network.TLS as TLS import Network.Xmpp.Bind import Network.Xmpp.Concurrent import Network.Xmpp.Concurrent.Channels @@ -158,100 +158,20 @@ import Network.Xmpp.Concurrent.Types import Network.Xmpp.Marshal import Network.Xmpp.Message import Network.Xmpp.Monad -import Network.Xmpp.Pickle import Network.Xmpp.Presence import Network.Xmpp.Sasl -import Network.Xmpp.Sasl.Mechanisms -import Network.Xmpp.Sasl.Types import Network.Xmpp.Session +-- import Network.Xmpp.Session import Network.Xmpp.Stream import Network.Xmpp.TLS import Network.Xmpp.Types -import Control.Monad.Error - --- | Connect to host with given address. -connect :: HostName -> PortID -> Text -> XmppConMonad (Either StreamError ()) -connect address port hostname = do - xmppRawConnect address port hostname - result <- xmppStartStream - case result of - Left e -> do - pushElement . pickleElem xpStreamError $ toError e - xmppCloseStreams - return () - Right () -> return () - return result - where - -- TODO: Descriptive texts in stream errors? - toError (StreamNotStreamElement _name) = - XmppStreamError StreamInvalidXml Nothing Nothing - toError (StreamInvalidStreamNamespace _ns) = - XmppStreamError StreamInvalidNamespace Nothing Nothing - toError (StreamInvalidStreamPrefix _prefix) = - XmppStreamError StreamBadNamespacePrefix Nothing Nothing - -- TODO: Catch remaining xmppStartStream errors. - toError (StreamWrongVersion _ver) = - XmppStreamError StreamUnsupportedVersion Nothing Nothing - toError (StreamWrongLangTag _) = - XmppStreamError StreamInvalidXml Nothing Nothing - toError StreamUnknownError = - XmppStreamError StreamBadFormat Nothing Nothing - - --- | Authenticate to the server using the first matching method and bind a --- resource. -auth :: [SaslHandler] - -> Maybe Text - -> XmppConMonad (Either AuthError Jid) -auth mechanisms resource = runErrorT $ do - ErrorT $ xmppSasl mechanisms - jid <- lift $ xmppBind resource - lift $ xmppStartSession - return jid - --- | Authenticate to the server with the given username and password --- and bind a resource. --- --- Prefers SCRAM-SHA1 over DIGEST-MD5. -simpleAuth :: Text.Text -- ^ The username - -> Text.Text -- ^ The password - -> Maybe Text -- ^ The desired resource or 'Nothing' to let the - -- server assign one - -> XmppConMonad (Either AuthError Jid) -simpleAuth username passwd resource = flip auth resource $ - [ -- TODO: scramSha1Plus - scramSha1 username Nothing passwd - , digestMd5 username Nothing passwd - ] - - --- | The quick and easy way to set up a connection to an XMPP server --- --- This will --- * connect to the host --- * secure the connection with TLS --- * authenticate to the server using either SCRAM-SHA1 (preferred) or --- Digest-MD5 --- * bind a resource --- * return the full JID you have been assigned --- --- Note that the server might assign a different resource even when we send --- a preference. -simpleConnect :: HostName -- ^ Host to connect to - -> PortID -- ^ Port to connec to - -> Text -- ^ Hostname of the server (to distinguish the XMPP - -- service) - -> Text -- ^ User name (authcid) - -> Text -- ^ Password - -> Maybe Text -- ^ Desired resource (or Nothing to let the server - -- decide) - -> XmppConMonad Jid -simpleConnect host port hostname username password resource = do - connect host port hostname - startTLS exampleParams - saslResponse <- simpleAuth username password resource - case saslResponse of - Right jid -> return jid - Left e -> error $ show e +-- -- 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 :: Session -> IO () +-- startSession session = do +-- answer <- sendIQ' Nothing Set Nothing sessionXML session +-- case answer of +-- IQResponseResult _ -> return () +-- e -> error $ show e diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index e11c5a7..4ac42aa 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Concurrent ( Session , module Network.Xmpp.Concurrent.Monad diff --git a/source/Network/Xmpp/Concurrent/Channels.hs b/source/Network/Xmpp/Concurrent/Channels.hs index 45afd4c..32d6ae9 100644 --- a/source/Network/Xmpp/Concurrent/Channels.hs +++ b/source/Network/Xmpp/Concurrent/Channels.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-} module Network.Xmpp.Concurrent.Channels ( module Network.Xmpp.Concurrent.Channels.Basic @@ -90,7 +91,7 @@ toChans messageC presenceC stanzaC iqHands sta = atomically $ do iqID (Right iq') = iqResultID iq' --- | Creates and initializes a new concurrent context. +-- | Creates and initializes a new Xmpp context. newContext :: IO Context newContext = do messageC <- newTChanIO diff --git a/source/Network/Xmpp/Concurrent/Channels/Basic.hs b/source/Network/Xmpp/Concurrent/Channels/Basic.hs index 4e1395d..287b089 100644 --- a/source/Network/Xmpp/Concurrent/Channels/Basic.hs +++ b/source/Network/Xmpp/Concurrent/Channels/Basic.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Concurrent.Channels.Basic where import Control.Concurrent.STM diff --git a/source/Network/Xmpp/Concurrent/Channels/IQ.hs b/source/Network/Xmpp/Concurrent/Channels/IQ.hs index 087b91e..c444296 100644 --- a/source/Network/Xmpp/Concurrent/Channels/IQ.hs +++ b/source/Network/Xmpp/Concurrent/Channels/IQ.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Concurrent.Channels.IQ where import Control.Concurrent (forkIO, threadDelay) diff --git a/source/Network/Xmpp/Concurrent/Channels/Message.hs b/source/Network/Xmpp/Concurrent/Channels/Message.hs index 58dbc6d..20d50b9 100644 --- a/source/Network/Xmpp/Concurrent/Channels/Message.hs +++ b/source/Network/Xmpp/Concurrent/Channels/Message.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Concurrent.Channels.Message where import Network.Xmpp.Concurrent.Channels.Types diff --git a/source/Network/Xmpp/Concurrent/Channels/Presence.hs b/source/Network/Xmpp/Concurrent/Channels/Presence.hs index 9c3d878..bf93ecb 100644 --- a/source/Network/Xmpp/Concurrent/Channels/Presence.hs +++ b/source/Network/Xmpp/Concurrent/Channels/Presence.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Concurrent.Channels.Presence where import Network.Xmpp.Concurrent.Channels.Types diff --git a/source/Network/Xmpp/Concurrent/Channels/Types.hs b/source/Network/Xmpp/Concurrent/Channels/Types.hs index fcf4ee7..d02025f 100644 --- a/source/Network/Xmpp/Concurrent/Channels/Types.hs +++ b/source/Network/Xmpp/Concurrent/Channels/Types.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Concurrent.Channels.Types where import Control.Concurrent.STM @@ -7,7 +8,7 @@ import Data.Text (Text) import Network.Xmpp.Concurrent.Types import Network.Xmpp.Types --- | Session with Channels +-- | An XMPP session context data Context = Context { session :: Session -- The original master channels that the reader puts stanzas diff --git a/source/Network/Xmpp/Concurrent/Monad.hs b/source/Network/Xmpp/Concurrent/Monad.hs index 96a1bc2..9046e6f 100644 --- a/source/Network/Xmpp/Concurrent/Monad.hs +++ b/source/Network/Xmpp/Concurrent/Monad.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-} module Network.Xmpp.Concurrent.Monad where diff --git a/source/Network/Xmpp/Concurrent/Threads.hs b/source/Network/Xmpp/Concurrent/Threads.hs index 4100588..64c7c2f 100644 --- a/source/Network/Xmpp/Concurrent/Threads.hs +++ b/source/Network/Xmpp/Concurrent/Threads.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/source/Network/Xmpp/IM.hs b/source/Network/Xmpp/IM.hs index 42c09cc..1f2a61f 100644 --- a/source/Network/Xmpp/IM.hs +++ b/source/Network/Xmpp/IM.hs @@ -1,5 +1,12 @@ module Network.Xmpp.IM - ( module Network.Xmpp.IM.Message + ( -- * Instant Messages + subject + , thread + , body + , newIM + , simpleIM + , answerIM + -- * Presence , module Network.Xmpp.IM.Presence ) where diff --git a/source/Network/Xmpp/IM/Message.hs b/source/Network/Xmpp/IM/Message.hs index 770e59c..2a76a3e 100644 --- a/source/Network/Xmpp/IM/Message.hs +++ b/source/Network/Xmpp/IM/Message.hs @@ -1,4 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_HADDOCK hide #-} + module Network.Xmpp.IM.Message where @@ -89,8 +91,10 @@ newIM t i lang tp sbj thrd bdy payload = Message ++ [payload] } --- | Generate a simple instance message -simpleIM :: Jid -> Text -> Message +-- | Generate a simple message +simpleIM :: Jid -- ^ recipient + -> Text -- ^ body + -> Message simpleIM t bd = newIM t Nothing diff --git a/source/Network/Xmpp/IM/Presence.hs b/source/Network/Xmpp/IM/Presence.hs index a999647..c586a1f 100644 --- a/source/Network/Xmpp/IM/Presence.hs +++ b/source/Network/Xmpp/IM/Presence.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_HADDOCK hide #-} + module Network.Xmpp.IM.Presence where import Data.Text(Text) diff --git a/source/Network/Xmpp/Message.hs b/source/Network/Xmpp/Message.hs index 0e14315..875421f 100644 --- a/source/Network/Xmpp/Message.hs +++ b/source/Network/Xmpp/Message.hs @@ -1,4 +1,6 @@ {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_HADDOCK hide #-} + module Network.Xmpp.Message ( Message(..) , MessageError(..) diff --git a/source/Network/Xmpp/Monad.hs b/source/Network/Xmpp/Monad.hs index a90e059..63503ba 100644 --- a/source/Network/Xmpp/Monad.hs +++ b/source/Network/Xmpp/Monad.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} @@ -44,6 +45,7 @@ pushElement x = do sink <- gets sConPushBS liftIO . sink $ renderElement x +-- | Encode and send stanza pushStanza :: Stanza -> XmppConMonad Bool pushStanza = pushElement . pickleElem xpStanza @@ -93,7 +95,7 @@ pullPickle p = do Left e -> liftIO . Ex.throwIO $ StreamXMLError (show e) Right r -> return r --- Pulls a stanza (or stream error) from the stream. Throws an error on a stream +-- | Pulls a stanza (or stream error) from the stream. Throws an error on a stream -- error. pullStanza :: XmppConMonad Stanza pullStanza = do diff --git a/source/Network/Xmpp/Pickle.hs b/source/Network/Xmpp/Pickle.hs index 2286fea..e00e190 100644 --- a/source/Network/Xmpp/Pickle.hs +++ b/source/Network/Xmpp/Pickle.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_HADDOCK hide #-} + {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} diff --git a/source/Network/Xmpp/Sasl.hs b/source/Network/Xmpp/Sasl.hs index c2b31c2..5f79247 100644 --- a/source/Network/Xmpp/Sasl.hs +++ b/source/Network/Xmpp/Sasl.hs @@ -1,6 +1,12 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} -module Network.Xmpp.Sasl where +module Network.Xmpp.Sasl + ( xmppSasl + , digestMd5 + , scramSha1 + , plain + ) where import Control.Applicative import Control.Arrow (left) @@ -31,11 +37,11 @@ import Network.Xmpp.Pickle import qualified System.Random as Random import Network.Xmpp.Sasl.Types +import Network.Xmpp.Sasl.Mechanisms --- Uses the first supported mechanism to authenticate, if any. Updates the --- XmppConMonad state with non-password credentials and restarts the stream upon --- success. This computation wraps an ErrorT computation, which means that --- catchError can be used to catch any errors. +-- | Uses the first supported mechanism to authenticate, if any. Updates the +-- state with non-password credentials and restarts the stream upon +-- success. xmppSasl :: [SaslHandler] -- ^ Acceptable authentication mechanisms and their -- corresponding handlers -> XmppConMonad (Either AuthError ()) diff --git a/source/Network/Xmpp/Sasl/Common.hs b/source/Network/Xmpp/Sasl/Common.hs index 0adea45..23c3bb7 100644 --- a/source/Network/Xmpp/Sasl/Common.hs +++ b/source/Network/Xmpp/Sasl/Common.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/source/Network/Xmpp/Sasl/Mechanisms.hs b/source/Network/Xmpp/Sasl/Mechanisms.hs index 674d6dd..f604381 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms.hs @@ -1,6 +1,7 @@ +{-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Sasl.Mechanisms ( module Network.Xmpp.Sasl.Mechanisms.DigestMd5 - , module Network.Xmpp.Sasl.Mechanisms.Scram + , scramSha1 , module Network.Xmpp.Sasl.Mechanisms.Plain ) where diff --git a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs index 31e68f8..d8b9a7d 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs @@ -1,6 +1,9 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.Sasl.Mechanisms.DigestMd5 where +module Network.Xmpp.Sasl.Mechanisms.DigestMd5 + ( digestMd5 + ) where import Control.Applicative import Control.Arrow (left) @@ -40,9 +43,9 @@ import Network.Xmpp.Sasl.Types -xmppDigestMd5 :: Text -- Authorization identity (authzid) - -> Maybe Text -- Authentication identity (authzid) - -> Text -- Password (authzid) +xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username) + -> Maybe Text -- ^ Authorization identity (authcid) + -> Text -- ^ Password (authzid) -> SaslM () xmppDigestMd5 authcid authzid password = do (ac, az, pw) <- prepCredentials authcid authzid password @@ -128,9 +131,9 @@ xmppDigestMd5 authcid authzid password = do ha2 = hash ["AUTHENTICATE", digestURI] in hash [ha1, nonce, nc, cnonce, qop, ha2] -digestMd5 :: Text -- Authorization identity (authzid) - -> Maybe Text -- Authentication identity (authzid) - -> Text -- Password (authzid) +digestMd5 :: Text -- ^ Authentication identity (authcid or username) + -> Maybe Text -- ^ Authorization identity (authzid) + -> Text -- ^ Password -> SaslHandler digestMd5 authcid authzid password = ( "DIGEST-MD5" , xmppDigestMd5 authcid authzid password diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs index fcc1e20..8f1ed25 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Plain.hs @@ -1,9 +1,12 @@ +{-# OPTIONS_HADDOCK hide #-} -- Implementation of the PLAIN Simple Authentication and Security Layer (SASL) -- Mechanism, http://tools.ietf.org/html/rfc4616. {-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.Sasl.Mechanisms.Plain where +module Network.Xmpp.Sasl.Mechanisms.Plain + ( plain + ) where import Control.Applicative import Control.Arrow (left) @@ -72,5 +75,8 @@ xmppPlain authcid authzid password = do where authzid' = maybe "" Text.encodeUtf8 authzid -plain :: Text.Text -> Maybe Text.Text -> Text.Text -> SaslHandler +plain :: Text.Text -- ^ authentication ID (username) + -> Maybe Text.Text -- ^ authorization ID + -> Text.Text -- ^ password + -> SaslHandler plain authcid authzid passwd = ("PLAIN", xmppPlain authcid authzid passwd) \ No newline at end of file diff --git a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs index a949239..6cf809d 100644 --- a/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs +++ b/source/Network/Xmpp/Sasl/Mechanisms/Scram.hs @@ -1,8 +1,10 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module Network.Xmpp.Sasl.Mechanisms.Scram where +module Network.Xmpp.Sasl.Mechanisms.Scram + where import Control.Applicative ((<$>)) import Control.Monad.Error @@ -153,7 +155,6 @@ scram hashToken authcid authzid password = do u1 = hmac str (salt +++ (BS.pack [0,0,0,1])) us = iterate (hmac str) u1 --- | 'scram' spezialised to the SHA-1 hash function, packaged as a SaslHandler scramSha1 :: Text.Text -- ^ username -> Maybe Text.Text -- ^ authorization ID -> Text.Text -- ^ password diff --git a/source/Network/Xmpp/Sasl/StringPrep.hs b/source/Network/Xmpp/Sasl/StringPrep.hs index 07442aa..cff48a6 100644 --- a/source/Network/Xmpp/Sasl/StringPrep.hs +++ b/source/Network/Xmpp/Sasl/StringPrep.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-} module Network.Xmpp.Sasl.StringPrep where diff --git a/source/Network/Xmpp/Sasl/Types.hs b/source/Network/Xmpp/Sasl/Types.hs index cc0351f..daa13ec 100644 --- a/source/Network/Xmpp/Sasl/Types.hs +++ b/source/Network/Xmpp/Sasl/Types.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Sasl.Types where import Control.Monad.Error diff --git a/source/Network/Xmpp/Session.hs b/source/Network/Xmpp/Session.hs index b6500f3..a282512 100644 --- a/source/Network/Xmpp/Session.hs +++ b/source/Network/Xmpp/Session.hs @@ -1,14 +1,88 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE OverloadedStrings #-} - module Network.Xmpp.Session where -import Data.XML.Pickle -import Data.XML.Types(Element) +import Control.Monad.Error +import Data.Text as Text +import Data.XML.Pickle +import Data.XML.Types(Element) +import qualified Network.TLS as TLS +import Network.Xmpp.Bind +import Network.Xmpp.Concurrent.Types +import Network.Xmpp.Marshal +import Network.Xmpp.Monad +import Network.Xmpp.Pickle +import Network.Xmpp.Sasl +import Network.Xmpp.Sasl.Mechanisms +import Network.Xmpp.Sasl.Types +import Network.Xmpp.Stream +import Network.Xmpp.Types +import Network +import Network.Xmpp.TLS + +-- | The quick and easy way to set up a connection to an XMPP server +-- +-- This will +-- +-- * connect to the host +-- +-- * secure the connection with TLS +-- +-- * authenticate to the server using either SCRAM-SHA1 (preferred) or +-- Digest-MD5 +-- +-- * bind a resource +-- +-- * return the full JID you have been assigned +-- +-- Note that the server might assign a different resource even when we send +-- a preference. +simpleConnect :: HostName -- ^ Host to connect to + -> PortID -- ^ Port to connec to + -> Text -- ^ Hostname of the server (to distinguish the XMPP + -- service) + -> Text -- ^ User name (authcid) + -> Text -- ^ Password + -> Maybe Text -- ^ Desired resource (or Nothing to let the server + -- decide) + -> XmppConMonad Jid +simpleConnect host port hostname username password resource = do + connect host port hostname + startTLS exampleParams + saslResponse <- simpleAuth username password resource + case saslResponse of + Right jid -> return jid + Left e -> error $ show e + + +-- | Connect to host with given address. +connect :: HostName -> PortID -> Text -> XmppConMonad (Either StreamError ()) +connect address port hostname = do + xmppRawConnect address port hostname + result <- xmppStartStream + case result of + Left e -> do + pushElement . pickleElem xpStreamError $ toError e + xmppCloseStreams + return () + Right () -> return () + return result + where + -- TODO: Descriptive texts in stream errors? + toError (StreamNotStreamElement _name) = + XmppStreamError StreamInvalidXml Nothing Nothing + toError (StreamInvalidStreamNamespace _ns) = + XmppStreamError StreamInvalidNamespace Nothing Nothing + toError (StreamInvalidStreamPrefix _prefix) = + XmppStreamError StreamBadNamespacePrefix Nothing Nothing + -- TODO: Catch remaining xmppStartStream errors. + toError (StreamWrongVersion _ver) = + XmppStreamError StreamUnsupportedVersion Nothing Nothing + toError (StreamWrongLangTag _) = + XmppStreamError StreamInvalidXml Nothing Nothing + toError StreamUnknownError = + XmppStreamError StreamBadFormat Nothing Nothing -import Network.Xmpp.Monad -import Network.Xmpp.Pickle -import Network.Xmpp.Types -import Network.Xmpp.Concurrent sessionXML :: Element sessionXML = pickleElem @@ -33,11 +107,28 @@ xmppStartSession = do Left e -> error $ show e Right _ -> return () --- -- 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 :: Session -> IO () --- startSession session = do --- answer <- sendIQ' Nothing Set Nothing sessionXML session --- case answer of --- IQResponseResult _ -> return () --- e -> error $ show e +-- | Authenticate to the server using the first matching method and bind a +-- resource. +auth :: [SaslHandler] + -> Maybe Text + -> XmppConMonad (Either AuthError Jid) +auth mechanisms resource = runErrorT $ do + ErrorT $ xmppSasl mechanisms + jid <- lift $ xmppBind resource + lift $ xmppStartSession + return jid + +-- | Authenticate to the server with the given username and password +-- and bind a resource. +-- +-- Prefers SCRAM-SHA1 over DIGEST-MD5. +simpleAuth :: Text.Text -- ^ The username + -> Text.Text -- ^ The password + -> Maybe Text -- ^ The desired resource or 'Nothing' to let the + -- server assign one + -> XmppConMonad (Either AuthError Jid) +simpleAuth username passwd resource = flip auth resource $ + [ -- TODO: scramSha1Plus + scramSha1 username Nothing passwd + , digestMd5 username Nothing passwd + ] diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 6fb1dd6..888c2ad 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} {-# LANGUAGE TupleSections #-} diff --git a/source/Network/Xmpp/TLS.hs b/source/Network/Xmpp/TLS.hs index 7c1c2ec..c50aebf 100644 --- a/source/Network/Xmpp/TLS.hs +++ b/source/Network/Xmpp/TLS.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 8d279e9..a357437 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -741,29 +741,36 @@ data XmppConnectionState deriving (Show, Eq, Typeable) data XmppConnection = XmppConnection - { sConSrc :: !(Source IO Event) - , sRawSrc :: !(Source IO BS.ByteString) - , sConPushBS :: !(BS.ByteString -> IO Bool) - , sConHandle :: !(Maybe Handle) - , sFeatures :: !ServerFeatures - , sConnectionState :: !XmppConnectionState - , sHostname :: !(Maybe Text) - , sJid :: !(Maybe Jid) - , sCloseConnection :: !(IO ()) - , sPreferredLang :: !(Maybe LangTag) - , sStreamLang :: !(Maybe LangTag) -- Will be a `Just' value + { sConSrc :: !(Source IO Event) -- ^ inbound connection + , sRawSrc :: !(Source IO BS.ByteString) -- ^ inbound + -- connection + , sConPushBS :: !(BS.ByteString -> IO Bool) -- ^ outbound + -- connection + , sConHandle :: !(Maybe Handle) -- ^ Handle for TLS + , sFeatures :: !ServerFeatures -- ^ Features the server + -- advertised + , sConnectionState :: !XmppConnectionState -- ^ State of connection + , sHostname :: !(Maybe Text) -- ^ Hostname of the server + , sJid :: !(Maybe Jid) -- ^ Our JID + , sCloseConnection :: !(IO ()) -- ^ necessary steps to cleanly + -- close the connection (send TLS + -- bye etc.) + , sPreferredLang :: !(Maybe LangTag) -- ^ Default language when + -- no explicit language + -- tag is set + , sStreamLang :: !(Maybe LangTag) -- ^ Will be a `Just' value -- once connected to the -- server. - , sStreamId :: !(Maybe Text) -- Stream ID as specified by + , sStreamId :: !(Maybe Text) -- ^ Stream ID as specified by -- the server. - , sToJid :: !(Maybe Jid) -- JID to include in the + , sToJid :: !(Maybe Jid) -- ^ JID to include in the -- stream element's `to' -- attribute when the -- connection is secured. See -- also below. - , sJidWhenPlain :: !Bool -- Whether or not to also include the + , sJidWhenPlain :: !Bool -- ^ Whether or not to also include the -- Jid when the connection is plain. - , sFrom :: !(Maybe Jid) -- From as specified by the + , sFrom :: !(Maybe Jid) -- ^ From as specified by the -- server in the stream -- element's `from' -- attribute. @@ -780,4 +787,4 @@ newtype XmppT m a = XmppT { runXmppT :: StateT XmppConnection m a } deriving (Mo type XmppConMonad a = StateT XmppConnection IO a -- Make XmppT derive the Monad and MonadIO instances. -deriving instance (Monad m, MonadIO m) => MonadState (XmppConnection) (XmppT m) \ No newline at end of file +deriving instance (Monad m, MonadIO m) => MonadState (XmppConnection) (XmppT m) diff --git a/source/Network/Xmpp/Xep/ServiceDiscovery.hs b/source/Network/Xmpp/Xep/ServiceDiscovery.hs index 1a6882d..d637107 100644 --- a/source/Network/Xmpp/Xep/ServiceDiscovery.hs +++ b/source/Network/Xmpp/Xep/ServiceDiscovery.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-}