asakul
/
pontarius-xmpp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

clear modules necessare for cabal install of warnings 

clear Network.Xmpp of warnings
clear Network.XMpp.Tls of Warnings
clear Network.Xmpp.Utilities of Warnings
clear Network.Xmpp.Stream of warnings
clear Network.Xmpp.Sasl of warnings
clear Network.Xmpp.Concurrent of warnings
clear Network.Xmpp.Concurrent.IQ of warnings
clear Network.Xmpp.Concurrent.Message of warnings
clear Network.Xmpp.Concurrent.Monad of warnings
clear Network.Xmpp.Concurrent.Presence of Warnings
clear Network.Xmpp.Concurrent.Threads of warnings
clear Network.Xmpp.Concurrent.Types of warnings
clear Network.Xmpp.IM.Presence of warnings
clear Network.Xmpp.Sasl.Common of warnings
clear Network.Xmpp.Sasl.StringPrep of warnings
clear Network.Xmpp.Sasl.Mechanisms.DIgestMd5 of warnings
clear Network.Xmpp.Sasl.Mechanisms.Plain of warnings
clear Network.Xmpp.Sasl.Mechanisms.Scram of warnings
clear Network.Xmpp.Xep.DataForms of warnings
clear Network.Xmpp.Internal of warnings
master
Philipp Balzarek 13 years ago
parent
477dbc14c7
commit
48f1e515fc
20 changed files with 290 additions and 456 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 4
      source/Network/Xmpp.hs
  2. 22
      source/Network/Xmpp/Concurrent.hs
  3. 8
      source/Network/Xmpp/Concurrent/IQ.hs
  4. 2
      source/Network/Xmpp/Concurrent/Message.hs
  5. 8
      source/Network/Xmpp/Concurrent/Monad.hs
  6. 1
      source/Network/Xmpp/Concurrent/Presence.hs
  7. 29
      source/Network/Xmpp/Concurrent/Threads.hs
  8. 10
      source/Network/Xmpp/Concurrent/Types.hs
  9. 1
      source/Network/Xmpp/IM/Presence.hs
  10. 5
      source/Network/Xmpp/Internal.hs
  11. 96
      source/Network/Xmpp/Sasl.hs
  12. 32
      source/Network/Xmpp/Sasl/Common.hs
  13. 48
      source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs
  14. 53
      source/Network/Xmpp/Sasl/Mechanisms/Plain.hs
  15. 64
      source/Network/Xmpp/Sasl/Mechanisms/Scram.hs
  16. 11
      source/Network/Xmpp/Sasl/StringPrep.hs
  17. 204
      source/Network/Xmpp/Stream.hs
  18. 45
      source/Network/Xmpp/Tls.hs
  19. 80
      source/Network/Xmpp/Utilities.hs
  20. 23
      source/Network/Xmpp/Xep/DataForms.hs

4
source/Network/Xmpp.hs
Unescape View File

@ -138,8 +138,6 @@ module Network.Xmpp @@ -138,8 +138,6 @@ module Network.Xmpp
, sendIQ'
, answerIQ
, listenIQChan
, iqRequestPayload
, iqResultPayload
-- * Errors
, StanzaError(..)
, StanzaErrorType(..)
@ -157,10 +155,8 @@ module Network.Xmpp @@ -157,10 +155,8 @@ module Network.Xmpp
, AuthOtherFailure )
) where
import Network
import Network.Xmpp.Concurrent
import Network.Xmpp.Utilities
import Network.Xmpp.Sasl
import Network.Xmpp.Sasl.Types
import Network.Xmpp.Tls
import Network.Xmpp.Types

22
source/Network/Xmpp/Concurrent.hs
Unescape View File

@ -18,36 +18,28 @@ import Control.Applicative((<$>),(<*>)) @@ -18,36 +18,28 @@ import Control.Applicative((<$>),(<*>))
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Error
import qualified Data.ByteString as BS
import Data.IORef
import qualified Data.Map as Map
import Data.Maybe
import Data.Maybe (fromMaybe)
import Data.Text as Text
import Data.XML.Types
import Network
import qualified Network.TLS as TLS
import Network.Xmpp.Concurrent.Basic
import Network.Xmpp.Concurrent.IQ
import Network.Xmpp.Concurrent.Message
import Network.Xmpp.Concurrent.Monad
import Network.Xmpp.Concurrent.Presence
import Network.Xmpp.Concurrent.Threads
import Network.Xmpp.Concurrent.Threads
import Network.Xmpp.Concurrent.Types
import Network.Xmpp.Marshal
import Network.Xmpp.Sasl
import Network.Xmpp.Sasl.Mechanisms
import Network.Xmpp.Sasl.Types
import Network.Xmpp.Stream
import Network.Xmpp.Tls
import Network.Xmpp.Types
import Network.Xmpp.Utilities
import Control.Monad.Error
import Data.Default
import System.Log.Logger
import Control.Monad.State.Strict
runHandlers :: (TChan Stanza) -> [StanzaHandler] -> Stanza -> IO ()
runHandlers _ [] _ = return ()
@ -96,7 +88,7 @@ handleIQ iqHands outC sta = atomically $ do @@ -96,7 +88,7 @@ handleIQ iqHands outC sta = atomically $ do
_ <- tryPutTMVar tmvar answer -- Don't block.
writeTVar handlers (byNS, byID')
where
iqID (Left err) = iqErrorID err
iqID (Left err') = iqErrorID err'
iqID (Right iq') = iqResultID iq'
-- | Creates and initializes a new Xmpp context.
@ -104,21 +96,21 @@ newSession :: Stream -> SessionConfiguration -> IO (Either XmppFailure Session) @@ -104,21 +96,21 @@ newSession :: Stream -> SessionConfiguration -> IO (Either XmppFailure Session)
newSession stream config = runErrorT $ do
outC <- lift newTChanIO
stanzaChan <- lift newTChanIO
iqHandlers <- lift $ newTVarIO (Map.empty, Map.empty)
iqHands <- lift $ newTVarIO (Map.empty, Map.empty)
eh <- lift $ newTVarIO $ EventHandlers { connectionClosedHandler = sessionClosedHandler config }
let stanzaHandler = runHandlers outC $ Prelude.concat [ [toChan stanzaChan]
, extraStanzaHandlers
config
, [handleIQ iqHandlers]
, [handleIQ iqHands]
]
(kill, wLock, streamState, readerThread) <- ErrorT $ startThreadsWith stanzaHandler eh stream
(kill, wLock, streamState, reader) <- ErrorT $ startThreadsWith stanzaHandler eh stream
writer <- lift $ forkIO $ writeWorker outC wLock
idGen <- liftIO $ sessionStanzaIDs config
return $ Session { stanzaCh = stanzaChan
, outCh = outC
, iqHandlers = iqHandlers
, iqHandlers = iqHands
, writeRef = wLock
, readerThread = readerThread
, readerThread = reader
, idGenerator = idGen
, streamRef = streamState
, eventHandlers = eh

8
source/Network/Xmpp/Concurrent/IQ.hs
Unescape View File

@ -4,8 +4,6 @@ module Network.Xmpp.Concurrent.IQ where @@ -4,8 +4,6 @@ module Network.Xmpp.Concurrent.IQ where
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import qualified Data.Map as Map
import Data.Text (Text)
@ -90,17 +88,17 @@ answerIQ :: IQRequestTicket @@ -90,17 +88,17 @@ answerIQ :: IQRequestTicket
-> Session
-> IO Bool
answerIQ (IQRequestTicket
sentRef
sRef
(IQRequest iqid from _to lang _tp bd))
answer session = do
let response = case answer of
Left err -> IQErrorS $ IQError iqid Nothing from lang err (Just bd)
Right res -> IQResultS $ IQResult iqid Nothing from lang res
atomically $ do
sent <- readTVar sentRef
sent <- readTVar sRef
case sent of
False -> do
writeTVar sentRef True
writeTVar sRef True
writeTChan (outCh session) response
return True

2
source/Network/Xmpp/Concurrent/Message.hs
Unescape View File

@ -3,9 +3,7 @@ module Network.Xmpp.Concurrent.Message where @@ -3,9 +3,7 @@ module Network.Xmpp.Concurrent.Message where
import Network.Xmpp.Concurrent.Types
import Control.Concurrent.STM
import Data.IORef
import Network.Xmpp.Types
import Network.Xmpp.Concurrent.Types
import Network.Xmpp.Concurrent.Basic
-- | Read an element from the inbound stanza channel, discardes any

8
source/Network/Xmpp/Concurrent/Monad.hs
Unescape View File

@ -60,15 +60,15 @@ import Network.Xmpp.Stream @@ -60,15 +60,15 @@ import Network.Xmpp.Stream
-- | Executes a function to update the event handlers.
modifyHandlers :: (EventHandlers -> EventHandlers) -> Session -> IO ()
modifyHandlers f session = atomically $ modifyTVar (eventHandlers session) f
modifyHandlers f session = atomically $ modifyTVar_ (eventHandlers session) f
where
-- Borrowing modifyTVar from
-- http://hackage.haskell.org/packages/archive/stm/2.4/doc/html/src/Control-Concurrent-STM-TVar.html
-- as it's not available in GHC 7.0.
modifyTVar :: TVar a -> (a -> a) -> STM ()
modifyTVar var f = do
modifyTVar_ :: TVar a -> (a -> a) -> STM ()
modifyTVar_ var g = do
x <- readTVar var
writeTVar var (f x)
writeTVar var (g x)
-- | Sets the handler to be executed when the server connection is closed.
setConnectionClosedHandler_ :: (XmppFailure -> Session -> IO ()) -> Session -> IO ()

1
source/Network/Xmpp/Concurrent/Presence.hs
Unescape View File

@ -2,7 +2,6 @@ @@ -2,7 +2,6 @@
module Network.Xmpp.Concurrent.Presence where
import Control.Concurrent.STM
import Data.IORef
import Network.Xmpp.Types
import Network.Xmpp.Concurrent.Types
import Network.Xmpp.Concurrent.Basic

29
source/Network/Xmpp/Concurrent/Threads.hs
Unescape View File

@ -4,25 +4,18 @@ @@ -4,25 +4,18 @@
module Network.Xmpp.Concurrent.Threads where
import Network.Xmpp.Types
import Control.Applicative((<$>))
import Control.Concurrent
import Control.Concurrent.STM
import qualified Control.Exception.Lifted as Ex
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Error
import Control.Monad.State.Strict
import qualified Data.ByteString as BS
import GHC.IO (unsafeUnmask)
import Network.Xmpp.Concurrent.Types
import Network.Xmpp.Stream
import Control.Concurrent.STM.TMVar
import GHC.IO (unsafeUnmask)
import Control.Monad.Error
import Network.Xmpp.Types
import System.Log.Logger
-- Worker to read stanzas from the stream and concurrently distribute them to
@ -38,8 +31,8 @@ readWorker onStanza onConnectionClosed stateRef = @@ -38,8 +31,8 @@ readWorker onStanza onConnectionClosed stateRef =
-- necessarily be interruptible
s <- atomically $ do
s@(Stream con) <- readTMVar stateRef
state <- streamConnectionState <$> readTMVar con
when (state == Closed)
scs <- streamConnectionState <$> readTMVar con
when (scs == Closed)
retry
return s
allowInterrupt
@ -55,7 +48,7 @@ readWorker onStanza onConnectionClosed stateRef = @@ -55,7 +48,7 @@ readWorker onStanza onConnectionClosed stateRef =
]
case res of
Nothing -> return () -- Caught an exception, nothing to do. TODO: Can this happen?
Just (Left e) -> return ()
Just (Left _) -> return ()
Just (Right sta) -> onStanza sta
where
-- Defining an Control.Exception.allowInterrupt equivalent for GHC 7
@ -85,19 +78,19 @@ startThreadsWith :: (Stanza -> IO ()) @@ -85,19 +78,19 @@ startThreadsWith :: (Stanza -> IO ())
TMVar Stream,
ThreadId))
startThreadsWith stanzaHandler eh con = do
read <- withStream' (gets $ streamSend . streamHandle >>= \d -> return $ Right d) con
case read of
rd <- withStream' (gets $ streamSend . streamHandle >>= \d -> return $ Right d) con
case rd of
Left e -> return $ Left e
Right read' -> do
writeLock <- newTMVarIO read'
conS <- newTMVarIO con
-- lw <- forkIO $ writeWorker outC writeLock
cp <- forkIO $ connPersist writeLock
rd <- forkIO $ readWorker stanzaHandler (noCon eh) conS
return $ Right ( killConnection writeLock [rd, cp]
rdw <- forkIO $ readWorker stanzaHandler (noCon eh) conS
return $ Right ( killConnection writeLock [rdw, cp]
, writeLock
, conS
, rd
, rdw
)
where
killConnection writeLock threads = liftIO $ do

10
source/Network/Xmpp/Concurrent/Types.hs
Unescape View File

@ -3,19 +3,13 @@ @@ -3,19 +3,13 @@
module Network.Xmpp.Concurrent.Types where
import qualified Control.Exception.Lifted as Ex
import Control.Concurrent
import Control.Concurrent.STM
import qualified Control.Exception.Lifted as Ex
import qualified Data.ByteString as BS
import Data.Typeable
import Network.Xmpp.Types
import Data.IORef
import qualified Data.Map as Map
import Data.Text (Text)
import Data.Typeable
import Network.Xmpp.Types
-- | Handlers to be run when the Xmpp session ends and when the Xmpp connection is

1
source/Network/Xmpp/IM/Presence.hs
Unescape View File

@ -2,7 +2,6 @@ @@ -2,7 +2,6 @@
module Network.Xmpp.IM.Presence where
import Data.Text(Text)
import Network.Xmpp.Types
-- | An empty presence.

5
source/Network/Xmpp/Internal.hs
Unescape View File

@ -29,7 +29,7 @@ module Network.Xmpp.Internal @@ -29,7 +29,7 @@ module Network.Xmpp.Internal
, pushStanza
, pullStanza
, pushIQ
, SaslHandler(..)
, SaslHandler
, StanzaID(..)
)
@ -37,9 +37,6 @@ module Network.Xmpp.Internal @@ -37,9 +37,6 @@ module Network.Xmpp.Internal
import Network.Xmpp.Stream
import Network.Xmpp.Sasl
import Network.Xmpp.Sasl.Common
import Network.Xmpp.Sasl.Types
import Network.Xmpp.Tls
import Network.Xmpp.Types
import Network.Xmpp.Stream
import Network.Xmpp.Marshal

96
source/Network/Xmpp/Sasl.hs
Unescape View File

@ -1,6 +1,6 @@ @@ -1,6 +1,6 @@
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}
--
-- Submodule for functionality related to SASL negotation:
-- authentication functions, SASL functionality, bind functionality,
-- and the legacy `{urn:ietf:params:xml:ns:xmpp-session}session'
@ -14,51 +14,17 @@ module Network.Xmpp.Sasl @@ -14,51 +14,17 @@ module Network.Xmpp.Sasl
, auth
) where
import Control.Applicative
import Control.Arrow (left)
import Control.Monad
import Control.Monad.Error
import Control.Monad.State.Strict
import Data.Maybe (fromJust, isJust)
import qualified Crypto.Classes as CC
import qualified Data.Binary as Binary
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BL
import qualified Data.Digest.Pure.MD5 as MD5
import qualified Data.List as L
import Data.Word (Word8)
import qualified Data.Text as Text
import Data.Text (Text)
import qualified Data.Text.Encoding as Text
import Network.Xmpp.Stream
import Network.Xmpp.Types
import System.Log.Logger (debugM, errorM)
import qualified System.Random as Random
import Network.Xmpp.Sasl.Types
import Network.Xmpp.Sasl.Mechanisms
import Control.Concurrent.STM.TMVar
import Control.Exception
import Data.XML.Pickle
import Data.XML.Types
import Network.Xmpp.Types
import Network.Xmpp.Marshal
import Control.Monad.State(modify)
import Control.Concurrent.STM.TMVar
import Control.Monad.Error
import Network.Xmpp.Sasl.Mechanisms
import Network.Xmpp.Sasl.Types
import Network.Xmpp.Stream
import Network.Xmpp.Types
import System.Log.Logger (debugM, errorM, infoM)
-- | Uses the first supported mechanism to authenticate, if any. Updates the
-- state with non-password credentials and restarts the stream upon
@ -105,16 +71,18 @@ auth :: [SaslHandler] @@ -105,16 +71,18 @@ auth :: [SaslHandler]
-> Stream
-> IO (Either XmppFailure (Maybe AuthFailure))
auth mechanisms resource con = runErrorT $ do
ErrorT $ xmppSasl mechanisms con
jid <- ErrorT $ xmppBind resource con
ErrorT $ flip withStream con $ do
s <- get
case establishSession $ streamConfiguration s of
False -> return $ Right Nothing
True -> do
_ <- lift $ startSession con
return $ Right Nothing
return Nothing
mbAuthFail <- ErrorT $ xmppSasl mechanisms con
case mbAuthFail of
Nothing -> do
_jid <- ErrorT $ xmppBind resource con
ErrorT $ flip withStream con $ do
s <- get
case establishSession $ streamConfiguration s of
False -> return $ Right Nothing
True -> do
_ <-liftIO $ startSession con
return $ Right Nothing
f -> return f
-- Produces a `bind' element, optionally wrapping a resource.
bindBody :: Maybe Text -> Element
@ -137,16 +105,19 @@ xmppBind rsrc c = runErrorT $ do @@ -137,16 +105,19 @@ xmppBind rsrc c = runErrorT $ do
let jid = unpickleElem xpJid b
case jid of
Right jid' -> do
lift $ debugM "Pontarius.XMPP" $ "xmppBind: JID unpickled: " ++ show jid'
ErrorT $ withStream (do
modify $ \s -> s{streamJid = Just jid'}
return $ Right jid') c -- not pretty
lift $ infoM "Pontarius.XMPP" $ "Bound JID: " ++ show jid'
_ <- lift $ withStream ( do
modify $ \s ->
s{streamJid = Just jid'}
return $ Right ())
c
return jid'
otherwise -> do
lift $ errorM "Pontarius.XMPP" $ "xmppBind: JID could not be unpickled from: "
++ show b
_ -> do
lift $ errorM "Pontarius.XMPP"
$ "xmppBind: JID could not be unpickled from: "
++ show b
throwError $ XmppOtherFailure
otherwise -> do
_ -> do
lift $ errorM "Pontarius.XMPP" "xmppBind: IQ error received."
throwError XmppOtherFailure
where
@ -164,15 +135,6 @@ sessionXml = pickleElem @@ -164,15 +135,6 @@ sessionXml = pickleElem
(xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session")
()
sessionIQ :: Stanza
sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess"
, iqRequestFrom = Nothing
, iqRequestTo = Nothing
, iqRequestLangTag = Nothing
, iqRequestType = Set
, iqRequestPayload = sessionXml
}
-- Sends the session IQ set element and waits for an answer. Throws an error if
-- if an IQ error stanza is returned from the server.
startSession :: Stream -> IO Bool

32
source/Network/Xmpp/Sasl/Common.hs
Unescape View File

@ -4,28 +4,23 @@ @@ -4,28 +4,23 @@
module Network.Xmpp.Sasl.Common where
import Network.Xmpp.Types
import Control.Applicative ((<$>))
import Control.Monad.Error
import Control.Monad.State.Class
import qualified Data.Attoparsec.ByteString.Char8 as AP
import Data.Bits
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import Data.Maybe (fromMaybe)
import Data.Maybe (maybeToList)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Word (Word8)
import Data.XML.Pickle
import Data.XML.Types
import Network.Xmpp.Stream
import Network.Xmpp.Marshal
import Network.Xmpp.Sasl.StringPrep
import Network.Xmpp.Sasl.Types
import Network.Xmpp.Marshal
import Network.Xmpp.Stream
import Network.Xmpp.Types
import qualified System.Random as Random
@ -66,9 +61,9 @@ pairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do @@ -66,9 +61,9 @@ pairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do
AP.skipSpace
name <- AP.takeWhile1 (/= '=')
_ <- AP.char '='
quote <- ((AP.char '"' >> return True) `mplus` return False)
qt <- ((AP.char '"' >> return True) `mplus` return False)
content <- AP.takeWhile1 (AP.notInClass [',', '"'])
when quote . void $ AP.char '"'
when qt . void $ AP.char '"'
return (name, content)
-- Failure element pickler.
@ -108,19 +103,20 @@ xpSaslElement = xpAlt saslSel @@ -108,19 +103,20 @@ xpSaslElement = xpAlt saslSel
quote :: BS.ByteString -> BS.ByteString
quote x = BS.concat ["\"",x,"\""]
saslInit :: Text.Text -> Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) Bool
saslInit :: Text.Text -> Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) ()
saslInit mechanism payload = do
r <- lift . pushElement . saslInitE mechanism $
Text.decodeUtf8 . B64.encode <$> payload
case r of
Left e -> throwError $ AuthStreamFailure e
Right b -> return b
Right True -> return ()
Right False -> throwError $ AuthStreamFailure XmppNoStream
Left e -> throwError $ AuthStreamFailure e
-- | Pull the next element.
pullSaslElement :: ErrorT AuthFailure (StateT StreamState IO) SaslElement
pullSaslElement = do
r <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement)
case r of
mbse <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement)
case mbse of
Left e -> throwError $ AuthStreamFailure e
Right (Left e) -> throwError $ AuthSaslFailure e
Right (Right r) -> return r
@ -173,13 +169,13 @@ toPairs ctext = case pairs ctext of @@ -173,13 +169,13 @@ toPairs ctext = case pairs ctext of
Right r -> return r
-- | Send a SASL response element. The content will be base64-encoded.
respond :: Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) Bool
respond :: Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) ()
respond m = do
r <- lift . pushElement . saslResponseE . fmap (Text.decodeUtf8 . B64.encode) $ m
case r of
Left e -> throwError $ AuthStreamFailure e
Right b -> return b
Right False -> throwError $ AuthStreamFailure XmppNoStream
Right True -> return ()
-- | Run the appropriate stringprep profiles on the credentials.
-- May fail with 'AuthStringPrepFailure'

48
source/Network/Xmpp/Sasl/Mechanisms/DigestMd5.hs
Unescape View File

@ -5,37 +5,21 @@ module Network.Xmpp.Sasl.Mechanisms.DigestMd5 @@ -5,37 +5,21 @@ module Network.Xmpp.Sasl.Mechanisms.DigestMd5
( digestMd5
) where
import Control.Applicative
import Control.Arrow (left)
import Control.Monad
import Control.Monad.Error
import Control.Monad.State.Strict
import Data.Maybe (fromJust, isJust)
import qualified Crypto.Classes as CC
import qualified Data.Binary as Binary
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BL
import qualified Data.Digest.Pure.MD5 as MD5
import qualified Data.List as L
import qualified Data.Text as Text
import Data.Text (Text)
import qualified Data.Text.Encoding as Text
import Data.XML.Pickle
import qualified Data.ByteString as BS
import Data.XML.Types
import Network.Xmpp.Stream
import Network.Xmpp.Types
import Network.Xmpp.Sasl.Common
import Network.Xmpp.Sasl.StringPrep
import Network.Xmpp.Sasl.Types
import Network.Xmpp.Types
@ -43,19 +27,19 @@ xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username) @@ -43,19 +27,19 @@ xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username)
-> Maybe Text -- ^ Authorization identity (authcid)
-> Text -- ^ Password (authzid)
-> ErrorT AuthFailure (StateT StreamState IO) ()
xmppDigestMd5 authcid authzid password = do
(ac, az, pw) <- prepCredentials authcid authzid password
xmppDigestMd5 authcid' authzid' password' = do
(ac, az, pw) <- prepCredentials authcid' authzid' password'
Just address <- gets streamAddress
xmppDigestMd5' address ac az pw
where
xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> ErrorT AuthFailure (StateT StreamState IO) ()
xmppDigestMd5' hostname authcid authzid password = do
xmppDigestMd5' hostname authcid _authzid password = do -- TODO: use authzid?
-- Push element and receive the challenge.
_ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean?
pairs <- toPairs =<< saslFromJust =<< pullChallenge
prs <- toPairs =<< saslFromJust =<< pullChallenge
cnonce <- liftIO $ makeNonce
_b <- respond . Just $ createResponse hostname pairs cnonce
challenge2 <- pullFinalMessage
_b <- respond . Just $ createResponse hostname prs cnonce
_challenge2 <- pullFinalMessage
return ()
where
-- Produce the response to the challenge.
@ -63,19 +47,19 @@ xmppDigestMd5 authcid authzid password = do @@ -63,19 +47,19 @@ xmppDigestMd5 authcid authzid password = do
-> Pairs
-> BS.ByteString -- nonce
-> BS.ByteString
createResponse hostname pairs cnonce = let
Just qop = L.lookup "qop" pairs -- TODO: proper handling
Just nonce = L.lookup "nonce" pairs
createResponse hname prs cnonce = let
Just qop = L.lookup "qop" prs -- TODO: proper handling
Just nonce = L.lookup "nonce" prs
uname_ = Text.encodeUtf8 authcid
passwd_ = Text.encodeUtf8 password
-- Using Int instead of Word8 for random 1.0.0.0 (GHC 7)
-- compatibility.
nc = "00000001"
digestURI = "xmpp/" `BS.append` Text.encodeUtf8 hostname
digestURI = "xmpp/" `BS.append` Text.encodeUtf8 hname
digest = md5Digest
uname_
(lookup "realm" pairs)
(lookup "realm" prs)
passwd_
digestURI
nc
@ -84,7 +68,7 @@ xmppDigestMd5 authcid authzid password = do @@ -84,7 +68,7 @@ xmppDigestMd5 authcid authzid password = do
cnonce
response = BS.intercalate "," . map (BS.intercalate "=") $
[["username", quote uname_]] ++
case L.lookup "realm" pairs of
case L.lookup "realm" prs of
Just realm -> [["realm" , quote realm ]]
Nothing -> [] ++
[ ["nonce" , quote nonce ]
@ -115,8 +99,8 @@ xmppDigestMd5 authcid authzid password = do @@ -115,8 +99,8 @@ xmppDigestMd5 authcid authzid password = do
-> BS8.ByteString
-> BS8.ByteString
-> BS8.ByteString
md5Digest uname realm password digestURI nc qop nonce cnonce =
let ha1 = hash [ hashRaw [uname, maybe "" id realm, password]
md5Digest uname realm pwd digestURI nc qop nonce cnonce =
let ha1 = hash [ hashRaw [uname, maybe "" id realm, pwd]
, nonce
, cnonce
]

53
source/Network/Xmpp/Sasl/Mechanisms/Plain.hs
Unescape View File

@ -8,51 +8,22 @@ module Network.Xmpp.Sasl.Mechanisms.Plain @@ -8,51 +8,22 @@ module Network.Xmpp.Sasl.Mechanisms.Plain
( plain
) where
import Control.Applicative
import Control.Arrow (left)
import Control.Monad
import Control.Monad.Error
import Control.Monad.State.Strict
import Data.Maybe (fromJust, isJust)
import qualified Crypto.Classes as CC
import qualified Data.Binary as Binary
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BL
import qualified Data.Digest.Pure.MD5 as MD5
import qualified Data.List as L
import Data.Word (Word8)
import qualified Data.Text as Text
import Data.Text (Text)
import qualified Data.Text.Encoding as Text
import Data.XML.Pickle
import qualified Data.ByteString as BS
import Data.XML.Types
import Network.Xmpp.Stream
import Network.Xmpp.Types
import qualified System.Random as Random
import Data.Maybe (fromMaybe)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Network.Xmpp.Sasl.Common
import Network.Xmpp.Sasl.Types
import Network.Xmpp.Types
-- TODO: stringprep
xmppPlain :: Text.Text -- ^ Password
-> Maybe Text.Text -- ^ Authorization identity (authzid)
-> Text.Text -- ^ Authentication identity (authcid)
-> ErrorT AuthFailure (StateT StreamState IO) ()
xmppPlain authcid authzid password = do
(ac, az, pw) <- prepCredentials authcid authzid password
xmppPlain authcid' authzid' password = do
(ac, az, pw) <- prepCredentials authcid' authzid' password
_ <- saslInit "PLAIN" ( Just $ plainMessage ac az pw)
_ <- pullSuccess
return ()
@ -63,15 +34,15 @@ xmppPlain authcid authzid password = do @@ -63,15 +34,15 @@ xmppPlain authcid authzid password = do
-> Maybe Text.Text -- Authentication identity (authcid)
-> Text.Text -- Password
-> BS.ByteString -- The PLAIN message
plainMessage authcid authzid passwd = BS.concat $
[ authzid'
, "\NUL"
, Text.encodeUtf8 $ authcid
, "\NUL"
, Text.encodeUtf8 $ passwd
]
plainMessage authcid _authzid passwd = BS.concat $
[ authzid''
, "\NUL"
, Text.encodeUtf8 $ authcid
, "\NUL"
, Text.encodeUtf8 $ passwd
]
where
authzid' = maybe "" Text.encodeUtf8 authzid
authzid'' = maybe "" Text.encodeUtf8 authzid'
plain :: Text.Text -- ^ authentication ID (username)
-> Maybe Text.Text -- ^ authorization ID

64
source/Network/Xmpp/Sasl/Mechanisms/Scram.hs
Unescape View File

@ -8,32 +8,20 @@ module Network.Xmpp.Sasl.Mechanisms.Scram @@ -8,32 +8,20 @@ module Network.Xmpp.Sasl.Mechanisms.Scram
import Control.Applicative ((<$>))
import Control.Monad.Error
import Control.Monad.Trans (liftIO)
import Control.Monad.State.Strict
import qualified Crypto.Classes as Crypto
import qualified Crypto.HMAC as Crypto
import qualified Crypto.Hash.SHA1 as Crypto
import Data.Binary(Binary,encode)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 as BS8 (unpack)
import qualified Data.ByteString.Lazy as LBS
import Data.List (foldl1', genericTake)
import qualified Data.Binary.Builder as Build
import Data.Maybe (maybeToList)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Word(Word8)
import Network.Xmpp.Sasl.Common
import Network.Xmpp.Sasl.StringPrep
import Network.Xmpp.Sasl.Types
import Network.Xmpp.Types
import Control.Monad.State.Strict
-- | A nicer name for undefined, for use as a dummy token to determin
-- the hash function to use
hashToken :: (Crypto.Hash ctx hash) => hash
@ -50,18 +38,18 @@ scram :: (Crypto.Hash ctx hash) @@ -50,18 +38,18 @@ scram :: (Crypto.Hash ctx hash)
-> Maybe Text.Text -- ^ Authorization ID
-> Text.Text -- ^ Password
-> ErrorT AuthFailure (StateT StreamState IO) ()
scram hashToken authcid authzid password = do
scram hToken authcid authzid password = do
(ac, az, pw) <- prepCredentials authcid authzid password
scramhelper hashToken ac az pw
scramhelper ac az pw
where
scramhelper hashToken authcid authzid' password = do
scramhelper authcid' authzid' pwd = do
cnonce <- liftIO $ makeNonce
saslInit "SCRAM-SHA-1" (Just $ cFirstMessage cnonce)
_ <- saslInit "SCRAM-SHA-1" (Just $ cFirstMessage cnonce)
sFirstMessage <- saslFromJust =<< pullChallenge
pairs <- toPairs sFirstMessage
(nonce, salt, ic) <- fromPairs pairs cnonce
prs <- toPairs sFirstMessage
(nonce, salt, ic) <- fromPairs prs cnonce
let (cfm, v) = cFinalMessageAndVerifier nonce salt ic sFirstMessage cnonce
respond $ Just cfm
_ <- respond $ Just cfm
finalPairs <- toPairs =<< saslFromJust =<< pullFinalMessage
unless (lookup "v" finalPairs == Just v) $ throwError AuthOtherFailure -- TODO: Log
return ()
@ -71,27 +59,27 @@ scram hashToken authcid authzid password = do @@ -71,27 +59,27 @@ scram hashToken authcid authzid password = do
encode _hashtoken = Crypto.encode
hash :: BS.ByteString -> BS.ByteString
hash str = encode hashToken $ Crypto.hash' str
hash str = encode hToken $ Crypto.hash' str
hmac :: BS.ByteString -> BS.ByteString -> BS.ByteString
hmac key str = encode hashToken $ Crypto.hmac' (Crypto.MacKey key) str
hmac key str = encode hToken $ Crypto.hmac' (Crypto.MacKey key) str
authzid :: Maybe BS.ByteString
authzid = (\z -> "a=" +++ Text.encodeUtf8 z) <$> authzid'
authzid'' :: Maybe BS.ByteString
authzid'' = (\z -> "a=" +++ Text.encodeUtf8 z) <$> authzid'
gs2CbindFlag :: BS.ByteString
gs2CbindFlag = "n" -- we don't support channel binding yet
gs2Header :: BS.ByteString
gs2Header = merge $ [ gs2CbindFlag
, maybe "" id authzid
, maybe "" id authzid''
, ""
]
cbindData :: BS.ByteString
cbindData = "" -- we don't support channel binding yet
-- cbindData :: BS.ByteString
-- cbindData = "" -- we don't support channel binding yet
cFirstMessageBare :: BS.ByteString -> BS.ByteString
cFirstMessageBare cnonce = merge [ "n=" +++ Text.encodeUtf8 authcid
cFirstMessageBare cnonce = merge [ "n=" +++ Text.encodeUtf8 authcid'
, "r=" +++ cnonce]
cFirstMessage :: BS.ByteString -> BS.ByteString
cFirstMessage cnonce = gs2Header +++ cFirstMessageBare cnonce
@ -99,13 +87,13 @@ scram hashToken authcid authzid password = do @@ -99,13 +87,13 @@ scram hashToken authcid authzid password = do
fromPairs :: Pairs
-> BS.ByteString
-> ErrorT AuthFailure (StateT StreamState IO) (BS.ByteString, BS.ByteString, Integer)
fromPairs pairs cnonce | Just nonce <- lookup "r" pairs
, cnonce `BS.isPrefixOf` nonce
, Just salt' <- lookup "s" pairs
, Right salt <- B64.decode salt'
, Just ic <- lookup "i" pairs
, [(i,"")] <- reads $ BS8.unpack ic
= return (nonce, salt, i)
fromPairs prs cnonce | Just nonce <- lookup "r" prs
, cnonce `BS.isPrefixOf` nonce
, Just salt' <- lookup "s" prs
, Right salt <- B64.decode salt'
, Just ic <- lookup "i" prs
, [(i,"")] <- reads $ BS8.unpack ic
= return (nonce, salt, i)
fromPairs _ _ = throwError $ AuthOtherFailure -- TODO: Log
cFinalMessageAndVerifier :: BS.ByteString
@ -126,7 +114,7 @@ scram hashToken authcid authzid password = do @@ -126,7 +114,7 @@ scram hashToken authcid authzid password = do
, "r=" +++ nonce]
saltedPassword :: BS.ByteString
saltedPassword = hi (Text.encodeUtf8 password) salt ic
saltedPassword = hi (Text.encodeUtf8 pwd) salt ic
clientKey :: BS.ByteString
clientKey = hmac saltedPassword "Client Key"
@ -154,9 +142,9 @@ scram hashToken authcid authzid password = do @@ -154,9 +142,9 @@ scram hashToken authcid authzid password = do
-- helper
hi :: BS.ByteString -> BS.ByteString -> Integer -> BS.ByteString
hi str salt ic = foldl1' xorBS (genericTake ic us)
hi str slt ic' = foldl1' xorBS (genericTake ic' us)
where
u1 = hmac str (salt +++ (BS.pack [0,0,0,1]))
u1 = hmac str (slt +++ (BS.pack [0,0,0,1]))
us = iterate (hmac str) u1
scramSha1 :: Text.Text -- ^ username

11
source/Network/Xmpp/Sasl/StringPrep.hs
Unescape View File

@ -4,27 +4,34 @@ module Network.Xmpp.Sasl.StringPrep where @@ -4,27 +4,34 @@ module Network.Xmpp.Sasl.StringPrep where
import Text.StringPrep
import qualified Data.Set as Set
import Data.Text(singleton)
import Data.Text(Text, singleton)
nonAsciiSpaces :: Set.Set Char
nonAsciiSpaces = Set.fromList [ '\x00A0', '\x1680', '\x2000', '\x2001', '\x2002'
, '\x2003', '\x2004', '\x2005', '\x2006', '\x2007'
, '\x2008', '\x2009', '\x200A', '\x200B', '\x202F'
, '\x205F', '\x3000'
]
toSpace :: Char -> Text
toSpace x = if x `Set.member` nonAsciiSpaces then " " else singleton x
saslPrepQuery :: StringPrepProfile
saslPrepQuery = Profile
[b1, toSpace]
True
[c12, c21, c22, c3, c4, c5, c6, c7, c8, c9]
True
saslPrepStore :: StringPrepProfile
saslPrepStore = Profile
[b1, toSpace]
True
[a1, c12, c21, c22, c3, c4, c5, c6, c7, c8, c9]
True
normalizePassword :: Text -> Maybe Text
normalizePassword = runStringPrep saslPrepStore
normalizeUsername = runStringPrep saslPrepQuery
normalizeUsername :: Text -> Maybe Text
normalizeUsername = runStringPrep saslPrepQuery

204
source/Network/Xmpp/Stream.hs
Unescape View File

@ -7,27 +7,26 @@ @@ -7,27 +7,26 @@
module Network.Xmpp.Stream where
import Control.Applicative ((<$>), (<*>))
import Control.Applicative ((<$>))
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM
import qualified Control.Exception as Ex
import Control.Exception.Base
import qualified Control.Exception.Lifted as ExL
import Control.Monad
import Control.Monad.Error
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.State.Strict
import Control.Monad.Trans.Class
import Control.Monad.Trans.Resource as R
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.ByteString.Base64
import qualified Data.ByteString.Char8 as BSC8
import Data.Conduit
import Data.Conduit.Binary as CB
import qualified Data.Conduit.Internal as DCI
import qualified Data.Conduit.List as CL
import Data.Maybe (fromJust, isJust, isNothing)
import Data.IP
import Data.List
import Data.Maybe
import Data.Ord
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Void (Void)
@ -35,27 +34,18 @@ import Data.XML.Pickle @@ -35,27 +34,18 @@ import Data.XML.Pickle
import Data.XML.Types
import qualified GHC.IO.Exception as GIE
import Network
import Network.DNS hiding (encode, lookup)
import Network.Xmpp.Marshal
import Network.Xmpp.Types
import System.IO
import System.IO.Error (tryIOError)
import System.Log.Logger
import System.Random (randomRIO)
import Text.XML.Stream.Parse as XP
import Text.XML.Unresolved(InvalidEventStream(..))
import Control.Monad.Trans.Resource as R
import Network.Xmpp.Utilities
import Network.DNS hiding (encode, lookup)
import Data.Ord
import Data.Maybe
import Data.List
import Data.IP
import System.Random
import qualified Network.Socket as NS
-- "readMaybe" definition, as readMaybe is not introduced in the `base' package
-- until version 4.6.
readMaybe_ :: (Read a) => String -> Maybe a
@ -73,6 +63,17 @@ lmb :: [t] -> Maybe [t] @@ -73,6 +63,17 @@ lmb :: [t] -> Maybe [t]
lmb [] = Nothing
lmb x = Just x
pushing :: MonadIO m =>
m (Either XmppFailure Bool)
-> ErrorT XmppFailure m ()
pushing m = do
res <- ErrorT m
case res of
True -> return ()
False -> do
liftIO $ debugM "Pontarius.Xmpp" "Failed to send data."
throwError XmppOtherFailure
-- Unpickles and returns a stream element.
streamUnpickleElem :: PU [Node] a
-> Element
@ -115,33 +116,34 @@ openElementFromEvents = do @@ -115,33 +116,34 @@ openElementFromEvents = do
startStream :: StateT StreamState IO (Either XmppFailure ())
startStream = runErrorT $ do
lift $ lift $ debugM "Pontarius.Xmpp" "Starting stream..."
state <- lift $ get
st <- lift $ get
-- Set the `from' (which is also the expected to) attribute depending on the
-- state of the stream.
let expectedTo = case ( streamConnectionState state
, toJid $ streamConfiguration state) of
(Plain, (Just (jid, True))) -> Just jid
(Secured, (Just (jid, _))) -> Just jid
(Plain, Nothing) -> Nothing
(Secured, Nothing) -> Nothing
case streamAddress state of
let expectedTo = case ( streamConnectionState st
, toJid $ streamConfiguration st) of
(Plain , (Just (jid, True))) -> Just jid
(Plain , _ ) -> Nothing
(Secured, (Just (jid, _ ))) -> Just jid
(Secured, Nothing ) -> Nothing
(Closed , _ ) -> Nothing
case streamAddress st of
Nothing -> do
lift $ lift $ errorM "Pontarius.XMPP" "Server sent no hostname."
throwError XmppOtherFailure
Just address -> lift $ do
pushXmlDecl
pushOpenElement $
Just address -> do
pushing pushXmlDecl
pushing . pushOpenElement $
pickleElem xpStream ( "1.0"
, expectedTo
, Just (Jid Nothing address Nothing)
, Nothing
, preferredLang $ streamConfiguration state
, preferredLang $ streamConfiguration st
)
response <- ErrorT $ runEventsSink $ runErrorT $ streamS expectedTo
case response of
Left e -> throwError e
-- Successful unpickling of stream element.
Right (Right (ver, from, to, id, lt, features))
Right (Right (ver, from, to, sid, lt, features))
| (Text.unpack ver) /= "1.0" ->
closeStreamWithError StreamUnsupportedVersion Nothing
"Unknown version"
@ -149,7 +151,7 @@ startStream = runErrorT $ do @@ -149,7 +151,7 @@ startStream = runErrorT $ do
closeStreamWithError StreamInvalidXml Nothing
"Stream has no language tag"
-- If `from' is set, we verify that it's the correct one. TODO: Should we check against the realm instead?
| isJust from && (from /= Just (Jid Nothing (fromJust $ streamAddress state) Nothing)) ->
| isJust from && (from /= Just (Jid Nothing (fromJust $ streamAddress st) Nothing)) ->
closeStreamWithError StreamInvalidFrom Nothing
"Stream from is invalid"
| to /= expectedTo ->
@ -158,12 +160,12 @@ startStream = runErrorT $ do @@ -158,12 +160,12 @@ startStream = runErrorT $ do
| otherwise -> do
modify (\s -> s{ streamFeatures = features
, streamLang = lt
, streamId = id
, streamId = sid
, streamFrom = from
} )
return ()
-- Unpickling failed - we investigate the element.
Right (Left (Element name attrs children))
Right (Left (Element name attrs _children))
| (nameLocalName name /= "stream") ->
closeStreamWithError StreamInvalidXml Nothing
"Root element is not stream"
@ -180,10 +182,10 @@ startStream = runErrorT $ do @@ -180,10 +182,10 @@ startStream = runErrorT $ do
closeStreamWithError :: StreamErrorCondition -> Maybe Element -> String
-> ErrorT XmppFailure (StateT StreamState IO) ()
closeStreamWithError sec el msg = do
lift . pushElement . pickleElem xpStreamError
void . lift . pushElement . pickleElem xpStreamError
$ StreamErrorInfo sec Nothing el
lift $ closeStreams'
lift $ lift $ errorM "Pontarius.XMPP" $ "closeStreamWithError: " ++ msg
void . lift $ closeStreams'
liftIO $ errorM "Pontarius.XMPP" $ "closeStreamWithError: " ++ msg
throwError XmppOtherFailure
checkchildren children =
let to' = lookup "to" children
@ -207,12 +209,12 @@ startStream = runErrorT $ do @@ -207,12 +209,12 @@ startStream = runErrorT $ do
""
safeRead x = case reads $ Text.unpack x of
[] -> Nothing
[(y,_),_] -> Just y
((y,_):_) -> Just y
flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)]
flattenAttrs attrs = Prelude.map (\(name, content) ->
flattenAttrs attrs = Prelude.map (\(name, cont) ->
( name
, Text.concat $ Prelude.map uncontentify content)
, Text.concat $ Prelude.map uncontentify cont)
)
attrs
where
@ -230,11 +232,11 @@ restartStream = do @@ -230,11 +232,11 @@ restartStream = do
modify (\s -> s{streamEventSource = newSource })
startStream
where
loopRead read = do
bs <- liftIO (read 4096)
loopRead rd = do
bs <- liftIO (rd 4096)
if BS.null bs
then return ()
else yield bs >> loopRead read
else yield bs >> loopRead rd
-- Reads the (partial) stream:stream and the server features from the stream.
-- Returns the (unvalidated) stream attributes, the unparsed element, or
@ -248,12 +250,12 @@ streamS :: Maybe Jid -> StreamSink (Either Element ( Text @@ -248,12 +250,12 @@ streamS :: Maybe Jid -> StreamSink (Either Element ( Text
, Maybe Text
, Maybe LangTag
, StreamFeatures ))
streamS expectedTo = do
header <- xmppStreamHeader
case header of
Right (version, from, to, id, langTag) -> do
streamS _expectedTo = do -- TODO: check expectedTo
streamHeader <- xmppStreamHeader
case streamHeader of
Right (version, from, to, sid, lTag) -> do
features <- xmppStreamFeatures
return $ Right (version, from, to, id, langTag, features)
return $ Right (version, from, to, sid, lTag, features)
Left el -> return $ Left el
where
xmppStreamHeader :: StreamSink (Either Element (Text, Maybe Jid, Maybe Jid, Maybe Text.Text, Maybe LangTag))
@ -281,7 +283,7 @@ openStream :: HostName -> StreamConfiguration -> IO (Either XmppFailure (Stream) @@ -281,7 +283,7 @@ openStream :: HostName -> StreamConfiguration -> IO (Either XmppFailure (Stream)
openStream realm config = runErrorT $ do
lift $ debugM "Pontarius.XMPP" "Opening stream..."
stream' <- createStream realm config
result <- liftIO $ withStream startStream stream'
ErrorT . liftIO $ withStream startStream stream'
return stream'
-- | Send "</stream:stream>" and wait for the server to finish processing and to
@ -290,14 +292,15 @@ openStream realm config = runErrorT $ do @@ -290,14 +292,15 @@ openStream realm config = runErrorT $ do
closeStreams :: Stream -> IO (Either XmppFailure [Element])
closeStreams = withStream closeStreams'
closeStreams' :: StateT StreamState IO (Either XmppFailure [Element])
closeStreams' = do
lift $ debugM "Pontarius.XMPP" "Closing stream..."
send <- gets (streamSend . streamHandle)
cc <- gets (streamClose . streamHandle)
liftIO $ send "</stream:stream>"
void . liftIO $ send "</stream:stream>"
void $ liftIO $ forkIO $ do
threadDelay 3000000 -- TODO: Configurable value
(Ex.try cc) :: IO (Either Ex.SomeException ())
void ((Ex.try cc) :: IO (Either Ex.SomeException ()))
return ()
collectElems []
where
@ -379,8 +382,8 @@ pullElement = do @@ -379,8 +382,8 @@ pullElement = do
-- Pulls an element and unpickles it.
pullUnpickle :: PU [Node] a -> StateT StreamState IO (Either XmppFailure a)
pullUnpickle p = do
elem <- pullElement
case elem of
el <- pullElement
case el of
Left e -> return $ Left e
Right elem' -> do
let res = unpickleElem p elem'
@ -491,17 +494,17 @@ connect realm config = do @@ -491,17 +494,17 @@ connect realm config = do
UseSrv host -> connectSrv host
UseRealm -> connectSrv realm
where
connectSrv realm = do
case checkHostName (Text.pack realm) of
Just realm' -> do
connectSrv host = do
case checkHostName (Text.pack host) of
Just host' -> do
resolvSeed <- lift $ makeResolvSeed (resolvConf config)
lift $ debugM "Pontarius.Xmpp" "Performing SRV lookup..."
srvRecords <- srvLookup realm' resolvSeed
srvRecords <- srvLookup host' resolvSeed
case srvRecords of
Nothing -> do
lift $ debugM "Pontarius.Xmpp"
"No SRV records, using fallback process."
lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ realm)
lift $ resolvAndConnectTcp resolvSeed (BSC8.pack $ host)
5222
Just srvRecords' -> do
lift $ debugM "Pontarius.Xmpp"
@ -517,10 +520,10 @@ connect realm config = do @@ -517,10 +520,10 @@ connect realm config = do
connectTcp :: [(HostName, PortID)] -> IO (Maybe Handle)
connectTcp [] = return Nothing
connectTcp ((address, port):remainder) = do
result <- try $ (do
result <- Ex.try $ (do
debugM "Pontarius.Xmpp" $ "Connecting to " ++ address ++ " on port " ++
(show port) ++ "."
connectTo address port) :: IO (Either IOException Handle)
connectTo address port) :: IO (Either Ex.IOException Handle)
case result of
Right handle -> do
debugM "Pontarius.Xmpp" "Successfully connected to HostName."
@ -534,23 +537,25 @@ connectTcp ((address, port):remainder) = do @@ -534,23 +537,25 @@ connectTcp ((address, port):remainder) = do
-- Surpresses all IO exceptions.
resolvAndConnectTcp :: ResolvSeed -> Domain -> Int -> IO (Maybe Handle)
resolvAndConnectTcp resolvSeed domain port = do
aaaaResults <- (try $ rethrowErrorCall $ withResolver resolvSeed $
\resolver -> lookupAAAA resolver domain) :: IO (Either IOException (Maybe [IPv6]))
aaaaResults <- (Ex.try $ rethrowErrorCall $ withResolver resolvSeed $
\resolver -> lookupAAAA resolver domain) :: IO (Either Ex.IOException (Maybe [IPv6]))
handle <- case aaaaResults of
Right Nothing -> return Nothing
Right (Just ipv6s) -> connectTcp $
map (\ipv6 -> ( show ipv6
map (\ip -> ( show ip
, PortNumber $ fromIntegral port))
ipv6s
Left e -> return Nothing
Left _e -> return Nothing
case handle of
Nothing -> do
aResults <- (try $ rethrowErrorCall $ withResolver resolvSeed $
\resolver -> lookupA resolver domain) :: IO (Either IOException (Maybe [IPv4]))
aResults <- (Ex.try $ rethrowErrorCall $ withResolver resolvSeed $
\resolver -> lookupA resolver domain) :: IO (Either Ex.IOException (Maybe [IPv4]))
handle' <- case aResults of
Left _ -> return Nothing
Right Nothing -> return Nothing
Right (Just ipv4s) -> connectTcp $
map (\ipv4 -> (show ipv4
map (\ip -> (show ip
, PortNumber
$ fromIntegral port))
ipv4s
@ -574,29 +579,30 @@ resolvSrvsAndConnectTcp resolvSeed ((domain, port):remaining) = do @@ -574,29 +579,30 @@ resolvSrvsAndConnectTcp resolvSeed ((domain, port):remaining) = do
-- exceptions and rethrows them as IOExceptions.
rethrowErrorCall :: IO a -> IO a
rethrowErrorCall action = do
result <- try action
result <- Ex.try action
case result of
Right result' -> return result'
Left (ErrorCall e) -> ioError $ userError $ "rethrowErrorCall: " ++ e
Left e -> throwIO e
Left (Ex.ErrorCall e) -> Ex.ioError $ userError
$ "rethrowErrorCall: " ++ e
-- Provides a list of A(AAA) names and port numbers upon a successful
-- DNS-SRV request, or `Nothing' if the DNS-SRV request failed.
srvLookup :: Text -> ResolvSeed -> ErrorT XmppFailure IO (Maybe [(Domain, Int)])
srvLookup realm resolvSeed = ErrorT $ do
result <- try $ rethrowErrorCall $ withResolver resolvSeed $ \resolver -> do
result <- Ex.try $ rethrowErrorCall $ withResolver resolvSeed
$ \resolver -> do
srvResult <- lookupSRV resolver $ BSC8.pack $ "_xmpp-client._tcp." ++ (Text.unpack realm) ++ "."
case srvResult of
Just srvResult -> do
debugM "Pontarius.Xmpp" $ "SRV result: " ++ (show srvResult)
-- Get [(Domain, PortNumber)] of SRV request, if any.
srvResult' <- orderSrvResult srvResult
return $ Just $ Prelude.map (\(_, _, port, domain) -> (domain, port)) srvResult'
-- The service is not available at this domain.
-- Sorts the records based on the priority value.
Just [(_, _, _, ".")] -> do
debugM "Pontarius.Xmpp" $ "\".\" SRV result returned."
return $ Just []
Just srvResult' -> do
debugM "Pontarius.Xmpp" $ "SRV result: " ++ (show srvResult')
-- Get [(Domain, PortNumber)] of SRV request, if any.
orderedSrvResult <- orderSrvResult srvResult'
return $ Just $ Prelude.map (\(_, _, port, domain) -> (domain, port)) orderedSrvResult
-- The service is not available at this domain.
-- Sorts the records based on the priority value.
Nothing -> do
debugM "Pontarius.Xmpp" "No SRV result returned."
return Nothing
@ -627,7 +633,7 @@ srvLookup realm resolvSeed = ErrorT $ do @@ -627,7 +633,7 @@ srvLookup realm resolvSeed = ErrorT $ do
orderSublist sublist = do
-- Compute the running sum, as well as the total sum of
-- the sublist. Add the running sum to the SRV tuples.
let (total, sublist') = Data.List.mapAccumL (\total (priority, weight, port, domain) -> (total + weight, (priority, weight, port, domain, total + weight))) 0 sublist
let (total, sublist') = Data.List.mapAccumL (\total' (priority, weight, port, domain) -> (total' + weight, (priority, weight, port, domain, total' + weight))) 0 sublist
-- Choose a random number between 0 and the total sum
-- (inclusive).
randomNumber <- randomRIO (0, total)
@ -636,11 +642,11 @@ srvLookup realm resolvSeed = ErrorT $ do @@ -636,11 +642,11 @@ srvLookup realm resolvSeed = ErrorT $ do
let (beginning, ((priority, weight, port, domain, _):end)) = Data.List.break (\(_, _, _, _, running) -> randomNumber <= running) sublist'
-- Remove the running total number from the remaining
-- elements.
let sublist'' = Data.List.map (\(priority, weight, port, domain, _) -> (priority, weight, port, domain)) (Data.List.concat [beginning, end])
let sublist'' = Data.List.map (\(priority', weight', port', domain', _) -> (priority', weight', port', domain')) (Data.List.concat [beginning, end])
-- Repeat the ordering procedure on the remaining
-- elements.
tail <- orderSublist sublist''
return $ ((priority, weight, port, domain):tail)
rest <- orderSublist sublist''
return $ ((priority, weight, port, domain):rest)
-- Closes the connection and updates the XmppConMonad Stream state.
-- killStream :: Stream -> IO (Either ExL.SomeException ())
@ -661,23 +667,24 @@ pushIQ :: StanzaID @@ -661,23 +667,24 @@ pushIQ :: StanzaID
-> Element
-> Stream
-> IO (Either XmppFailure (Either IQError IQResult))
pushIQ iqID to tp lang body stream = do
pushStanza (IQRequestS $ IQRequest iqID Nothing to lang tp body) stream
res <- pullStanza stream
pushIQ iqID to tp lang body stream = runErrorT $ do
pushing $ pushStanza
(IQRequestS $ IQRequest iqID Nothing to lang tp body) stream
res <- lift $ pullStanza stream
case res of
Left e -> return $ Left e
Right (IQErrorS e) -> return $ Right $ Left e
Left e -> throwError e
Right (IQErrorS e) -> return $ Left e
Right (IQResultS r) -> do
unless
(iqID == iqResultID r) $ liftIO $ do
errorM "Pontarius.XMPP" $ "pushIQ: ID mismatch (" ++ (show iqID) ++ " /= " ++ (show $ iqResultID r) ++ ")."
ExL.throwIO XmppOtherFailure
liftIO $ errorM "Pontarius.XMPP" $ "pushIQ: ID mismatch (" ++ (show iqID) ++ " /= " ++ (show $ iqResultID r) ++ ")."
liftIO $ ExL.throwIO XmppOtherFailure
-- TODO: Log: ("In sendIQ' IDs don't match: " ++ show iqID ++
-- " /= " ++ show (iqResultID r) ++ " .")
return $ Right $ Right r
return $ Right r
_ -> do
errorM "Pontarius.XMPP" $ "pushIQ: Unexpected stanza type."
return . Left $ XmppOtherFailure
liftIO $ errorM "Pontarius.XMPP" $ "pushIQ: Unexpected stanza type."
throwError XmppOtherFailure
debugConduit :: Pipe l ByteString ByteString u IO b
debugConduit = forever $ do
@ -695,7 +702,9 @@ elements = do @@ -695,7 +702,9 @@ elements = do
Just (EventBeginElement n as) -> do
goE n as >>= yield
elements
Just (EventEndElement streamName) -> lift $ R.monadThrow StreamEnd
-- This might be an XML error if the end element tag is not
-- "</stream>". TODO: We might want to check this at a later time
Just (EventEndElement _) -> lift $ R.monadThrow StreamEnd
Nothing -> return ()
_ -> lift $ R.monadThrow $ InvalidXmppXml $ "not an element: " ++ show x
where
@ -705,8 +714,8 @@ elements = do @@ -705,8 +714,8 @@ elements = do
go front = do
x <- f
case x of
Left x -> return $ (x, front [])
Right y -> go (front . (:) y)
Left l -> return $ (l, front [])
Right r -> go (front . (:) r)
goE n as = do
(y, ns) <- many' goN
if y == Just (EventEndElement n)
@ -730,11 +739,8 @@ elements = do @@ -730,11 +739,8 @@ elements = do
compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z
compressNodes (x:xs) = x : compressNodes xs
streamName :: Name
streamName = (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream"))
withStream :: StateT StreamState IO (Either XmppFailure c) -> Stream -> IO (Either XmppFailure c)
withStream action (Stream stream) = bracketOnError
withStream action (Stream stream) = Ex.bracketOnError
(atomically $ takeTMVar stream )
(atomically . putTMVar stream)
(\s -> do

45
source/Network/Xmpp/Tls.hs
Unescape View File

@ -4,7 +4,6 @@ @@ -4,7 +4,6 @@
module Network.Xmpp.Tls where
import Control.Concurrent.STM.TMVar
import qualified Control.Exception.Lifted as Ex
import Control.Monad
import Control.Monad.Error
@ -14,16 +13,14 @@ import qualified Data.ByteString as BS @@ -14,16 +13,14 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC8
import qualified Data.ByteString.Lazy as BL
import Data.Conduit
import qualified Data.Conduit.Binary as CB
import Data.IORef
import Data.Typeable
import Data.XML.Types
import Network.TLS
import Network.TLS.Extra
import Network.Xmpp.Stream
import Network.Xmpp.Types
import System.Log.Logger (debugM, errorM)
mkBackend :: StreamHandle -> Backend
mkBackend con = Backend { backendSend = \bs -> void (streamSend con bs)
, backendRecv = streamReceive con
, backendFlush = streamFlush con
@ -61,31 +58,39 @@ tls con = Ex.handle (return . Left . TlsError) @@ -61,31 +58,39 @@ tls con = Ex.handle (return . Left . TlsError)
where
startTls = do
params <- gets $ tlsParams . streamConfiguration
lift $ pushElement starttlsE
sent <- ErrorT $ pushElement starttlsE
unless sent $ do
liftIO $ errorM "Pontarius.XMPP" "startTls: Could not sent stanza."
throwError XmppOtherFailure
answer <- lift $ pullElement
case answer of
Left e -> return $ Left e
Left e -> throwError e
Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] []) ->
return $ Right ()
return ()
Right (Element "{urn:ietf:params:xml:ns:xmpp-tls}failure" _ _) -> do
liftIO $ errorM "Pontarius.XMPP" "startTls: TLS initiation failed."
return . Left $ XmppOtherFailure
throwError XmppOtherFailure
Right r ->
liftIO $ errorM "Pontarius.XMPP" $
"startTls: Unexpected element: " ++ show r
hand <- gets streamHandle
(raw, _snk, psh, read, ctx) <- lift $ tlsinit params (mkBackend hand)
(_raw, _snk, psh, recv, ctx) <- lift $ tlsinit params (mkBackend hand)
let newHand = StreamHandle { streamSend = catchPush . psh
, streamReceive = read
, streamFlush = contextFlush ctx
, streamClose = bye ctx >> streamClose hand
}
, streamReceive = recv
, streamFlush = contextFlush ctx
, streamClose = bye ctx >> streamClose hand
}
lift $ modify ( \x -> x {streamHandle = newHand})
either (lift . Ex.throwIO) return =<< lift restartStream
modify (\s -> s{streamConnectionState = Secured})
return ()
client :: (MonadIO m, CPRG rng) => Params -> rng -> Backend -> m Context
client params gen backend = do
contextNew backend params gen
defaultParams = defaultParamsClient
xmppDefaultParams :: Params
xmppDefaultParams = defaultParamsClient
tlsinit :: (MonadIO m, MonadIO m1) =>
TLSParams
@ -96,10 +101,10 @@ tlsinit :: (MonadIO m, MonadIO m1) => @@ -96,10 +101,10 @@ tlsinit :: (MonadIO m, MonadIO m1) =>
, Int -> m1 BS.ByteString
, Context
)
tlsinit tlsParams backend = do
tlsinit params backend = do
liftIO $ debugM "Pontarius.Xmpp.TLS" "TLS with debug mode enabled."
gen <- liftIO $ getSystemRandomGen -- TODO: Find better random source?
con <- client tlsParams gen backend
con <- client params gen backend
handshake con
let src = forever $ do
dt <- liftIO $ recvData con
@ -114,22 +119,22 @@ tlsinit tlsParams backend = do @@ -114,22 +119,22 @@ tlsinit tlsParams backend = do
liftIO $ debugM "Pontarius.Xmpp.TLS"
("out :" ++ BSC8.unpack x)
snk
read <- liftIO $ mkReadBuffer (recvData con)
readWithBuffer <- liftIO $ mkReadBuffer (recvData con)
return ( src
, snk
, \s -> do
liftIO $ debugM "Pontarius.Xmpp.TLS" ("out :" ++ BSC8.unpack s)
sendData con $ BL.fromChunks [s]
, liftIO . read
, liftIO . readWithBuffer
, con
)
mkReadBuffer :: IO BS.ByteString -> IO (Int -> IO BS.ByteString)
mkReadBuffer read = do
mkReadBuffer recv = do
buffer <- newIORef BS.empty
let read' n = do
nc <- readIORef buffer
bs <- if BS.null nc then read
bs <- if BS.null nc then recv
else return nc
let (result, rest) = BS.splitAt n bs
writeIORef buffer rest

80
source/Network/Xmpp/Utilities.hs
Unescape View File

@ -3,76 +3,27 @@ @@ -3,76 +3,27 @@
{-# OPTIONS_HADDOCK hide #-}
module Network.Xmpp.Utilities (presTo, message, answerMessage, openElementToEvents, renderOpenElement, renderElement) where
import Network.Xmpp.Types
import Control.Monad.STM
import Control.Concurrent.STM.TVar
import Prelude
import Data.XML.Types
import qualified Data.Attoparsec.Text as AP
import qualified Data.Text as Text
module Network.Xmpp.Utilities
( presTo
, message
, answerMessage
, openElementToEvents
, renderOpenElement
, renderElement)
where
import Network.Xmpp.Types
import Prelude
import Data.XML.Types
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 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
-- internal state so that the same ID will not be generated again.
idGenerator :: Text.Text -> IO IdGenerator
idGenerator prefix = atomically $ do
tvar <- newTVar $ ids prefix
return $ IdGenerator $ next tvar
where
-- Transactionally extract the next ID from the infinite list of IDs.
next :: TVar [Text.Text] -> IO Text.Text
next tvar = atomically $ do
list <- readTVar tvar
case list of
[] -> error "empty list in Utilities.hs"
(x:xs) -> do
writeTVar tvar xs
return x
-- Generates an infinite and predictable list of IDs, all beginning with the
-- provided prefix. Adds the prefix to all combinations of IDs (ids').
ids :: Text.Text -> [Text.Text]
ids p = Prelude.map (\ id -> Text.append p id) ids'
where
-- Generate all combinations of IDs, with increasing length.
ids' :: [Text.Text]
ids' = Prelude.map Text.pack $ Prelude.concatMap ids'' [1..]
-- Generates all combinations of IDs with the given length.
ids'' :: Integer -> [String]
ids'' 0 = [""]
ids'' l = [x:xs | x <- repertoire, xs <- ids'' (l - 1)]
-- Characters allowed in IDs.
repertoire :: String
repertoire = ['a'..'z']
-- Constructs a "Version" based on the major and minor version numbers.
versionFromNumbers :: Integer -> Integer -> Version
versionFromNumbers major minor = Version major minor
-- | Add a recipient to a presence notification.
presTo :: Presence -> Jid -> Presence
presTo pres to = pres{presenceTo = Just to}
@ -124,4 +75,5 @@ renderElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO @@ -124,4 +75,5 @@ renderElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO
$ CL.sourceList (elementToEvents e) $$ TXSR.renderText def =$ CL.consume
where
elementToEvents :: Element -> [Event]
elementToEvents e@(Element name _ _) = openElementToEvents e ++ [EventEndElement name]
elementToEvents el@(Element name _ _) = openElementToEvents el
++ [EventEndElement name]

23
source/Network/Xmpp/Xep/DataForms.hs
Unescape View File

@ -7,12 +7,9 @@ @@ -7,12 +7,9 @@
module Network.Xmpp.Xep.DataForms where
import qualified Data.Text as Text
import Data.XML.Pickle
import qualified Data.XML.Types as XML
import Data.XML.Pickle
import qualified Data.Text as Text
import qualified Text.XML.Stream.Parse as Parse
dataFormNs :: Text.Text
dataFormNs = "jabber:x:data"
@ -95,12 +92,12 @@ instance Read FieldType where @@ -95,12 +92,12 @@ instance Read FieldType where
xpForm :: PU [XML.Node] Form
xpForm = xpWrap (\(tp , (title, instructions, fields, reported, items)) ->
Form tp title (map snd instructions) fields reported (map snd items))
(\(Form tp title instructions fields reported items) ->
xpForm = xpWrap (\(tp , (ttl, ins, flds, rpd, its)) ->
Form tp ttl (map snd ins) flds rpd (map snd its))
(\(Form tp ttl ins flds rpd its) ->
(tp ,
(title, map ((),) instructions
, fields, reported, map ((),) items)))
(ttl, map ((),) ins
, flds, rpd, map ((),) its)))
$
xpElem (dataFormName "x")
@ -113,10 +110,10 @@ xpForm = xpWrap (\(tp , (title, instructions, fields, reported, items)) -> @@ -113,10 +110,10 @@ xpForm = xpWrap (\(tp , (title, instructions, fields, reported, items)) ->
(xpElems (dataFormName "item") xpUnit xpFields))
xpFields :: PU [XML.Node] [Field]
xpFields = xpWrap (map $ \((var, tp, label),(desc, req, vals, opts))
-> Field var label tp desc req vals opts)
(map $ \(Field var label tp desc req vals opts)
-> ((var, tp, label),(desc, req, vals, opts))) $
xpFields = xpWrap (map $ \((var, tp, lbl),(desc, req, vals, opts))
-> Field var lbl tp desc req vals opts)
(map $ \(Field var lbl tp desc req vals opts)
-> ((var, tp, lbl),(desc, req, vals, opts))) $
xpElems (dataFormName "field")
(xp3Tuple
(xpAttrImplied "var" xpId )

Write Preview
Loading…
Cancel
Save