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
Unified 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
, sendIQ' , sendIQ'
, answerIQ , answerIQ
, listenIQChan , listenIQChan
, iqRequestPayload
, iqResultPayload
-- * Errors -- * Errors
, StanzaError(..) , StanzaError(..)
, StanzaErrorType(..) , StanzaErrorType(..)
@ -157,10 +155,8 @@ module Network.Xmpp
, AuthOtherFailure ) , AuthOtherFailure )
) where ) where
import Network
import Network.Xmpp.Concurrent import Network.Xmpp.Concurrent
import Network.Xmpp.Utilities import Network.Xmpp.Utilities
import Network.Xmpp.Sasl import Network.Xmpp.Sasl
import Network.Xmpp.Sasl.Types import Network.Xmpp.Sasl.Types
import Network.Xmpp.Tls
import Network.Xmpp.Types import Network.Xmpp.Types

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

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

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

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

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

@ -3,9 +3,7 @@ module Network.Xmpp.Concurrent.Message where
import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Types
import Control.Concurrent.STM import Control.Concurrent.STM
import Data.IORef
import Network.Xmpp.Types import Network.Xmpp.Types
import Network.Xmpp.Concurrent.Types
import Network.Xmpp.Concurrent.Basic import Network.Xmpp.Concurrent.Basic
-- | Read an element from the inbound stanza channel, discardes any -- | 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
-- | Executes a function to update the event handlers. -- | Executes a function to update the event handlers.
modifyHandlers :: (EventHandlers -> EventHandlers) -> Session -> IO () modifyHandlers :: (EventHandlers -> EventHandlers) -> Session -> IO ()
modifyHandlers f session = atomically $ modifyTVar (eventHandlers session) f modifyHandlers f session = atomically $ modifyTVar_ (eventHandlers session) f
where where
-- Borrowing modifyTVar from -- Borrowing modifyTVar from
-- http://hackage.haskell.org/packages/archive/stm/2.4/doc/html/src/Control-Concurrent-STM-TVar.html -- 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. -- as it's not available in GHC 7.0.
modifyTVar :: TVar a -> (a -> a) -> STM () modifyTVar_ :: TVar a -> (a -> a) -> STM ()
modifyTVar var f = do modifyTVar_ var g = do
x <- readTVar var x <- readTVar var
writeTVar var (f x) writeTVar var (g x)
-- | Sets the handler to be executed when the server connection is closed. -- | Sets the handler to be executed when the server connection is closed.
setConnectionClosedHandler_ :: (XmppFailure -> Session -> IO ()) -> Session -> IO () setConnectionClosedHandler_ :: (XmppFailure -> Session -> IO ()) -> Session -> IO ()

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

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

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

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

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

@ -3,19 +3,13 @@
module Network.Xmpp.Concurrent.Types where module Network.Xmpp.Concurrent.Types where
import qualified Control.Exception.Lifted as Ex
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.STM import Control.Concurrent.STM
import qualified Control.Exception.Lifted as Ex
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Typeable
import Network.Xmpp.Types
import Data.IORef
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Text (Text) import Data.Text (Text)
import Data.Typeable
import Network.Xmpp.Types import Network.Xmpp.Types
-- | Handlers to be run when the Xmpp session ends and when the Xmpp connection is -- | 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 @@
module Network.Xmpp.IM.Presence where module Network.Xmpp.IM.Presence where
import Data.Text(Text)
import Network.Xmpp.Types import Network.Xmpp.Types
-- | An empty presence. -- | An empty presence.

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

@ -29,7 +29,7 @@ module Network.Xmpp.Internal
, pushStanza , pushStanza
, pullStanza , pullStanza
, pushIQ , pushIQ
, SaslHandler(..) , SaslHandler
, StanzaID(..) , StanzaID(..)
) )
@ -37,9 +37,6 @@ module Network.Xmpp.Internal
import Network.Xmpp.Stream import Network.Xmpp.Stream
import Network.Xmpp.Sasl import Network.Xmpp.Sasl
import Network.Xmpp.Sasl.Common
import Network.Xmpp.Sasl.Types import Network.Xmpp.Sasl.Types
import Network.Xmpp.Tls import Network.Xmpp.Tls
import Network.Xmpp.Types 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 @@
{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}
--
-- Submodule for functionality related to SASL negotation: -- Submodule for functionality related to SASL negotation:
-- authentication functions, SASL functionality, bind functionality, -- authentication functions, SASL functionality, bind functionality,
-- and the legacy `{urn:ietf:params:xml:ns:xmpp-session}session' -- and the legacy `{urn:ietf:params:xml:ns:xmpp-session}session'
@ -14,51 +14,17 @@ module Network.Xmpp.Sasl
, auth , auth
) where ) where
import Control.Applicative
import Control.Arrow (left)
import Control.Monad
import Control.Monad.Error import Control.Monad.Error
import Control.Monad.State.Strict 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 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.Pickle
import Data.XML.Types import Data.XML.Types
import Network.Xmpp.Types
import Network.Xmpp.Marshal import Network.Xmpp.Marshal
import Network.Xmpp.Sasl.Mechanisms
import Control.Monad.State(modify) import Network.Xmpp.Sasl.Types
import Network.Xmpp.Stream
import Control.Concurrent.STM.TMVar import Network.Xmpp.Types
import System.Log.Logger (debugM, errorM, infoM)
import Control.Monad.Error
-- | Uses the first supported mechanism to authenticate, if any. Updates the -- | Uses the first supported mechanism to authenticate, if any. Updates the
-- state with non-password credentials and restarts the stream upon -- state with non-password credentials and restarts the stream upon
@ -105,16 +71,18 @@ auth :: [SaslHandler]
-> Stream -> Stream
-> IO (Either XmppFailure (Maybe AuthFailure)) -> IO (Either XmppFailure (Maybe AuthFailure))
auth mechanisms resource con = runErrorT $ do auth mechanisms resource con = runErrorT $ do
ErrorT $ xmppSasl mechanisms con mbAuthFail <- ErrorT $ xmppSasl mechanisms con
jid <- ErrorT $ xmppBind resource con case mbAuthFail of
ErrorT $ flip withStream con $ do Nothing -> do
s <- get _jid <- ErrorT $ xmppBind resource con
case establishSession $ streamConfiguration s of ErrorT $ flip withStream con $ do
False -> return $ Right Nothing s <- get
True -> do case establishSession $ streamConfiguration s of
_ <- lift $ startSession con False -> return $ Right Nothing
return $ Right Nothing True -> do
return Nothing _ <-liftIO $ startSession con
return $ Right Nothing
f -> return f
-- Produces a `bind' element, optionally wrapping a resource. -- Produces a `bind' element, optionally wrapping a resource.
bindBody :: Maybe Text -> Element bindBody :: Maybe Text -> Element
@ -137,16 +105,19 @@ xmppBind rsrc c = runErrorT $ do
let jid = unpickleElem xpJid b let jid = unpickleElem xpJid b
case jid of case jid of
Right jid' -> do Right jid' -> do
lift $ debugM "Pontarius.XMPP" $ "xmppBind: JID unpickled: " ++ show jid' lift $ infoM "Pontarius.XMPP" $ "Bound JID: " ++ show jid'
ErrorT $ withStream (do _ <- lift $ withStream ( do
modify $ \s -> s{streamJid = Just jid'} modify $ \s ->
return $ Right jid') c -- not pretty s{streamJid = Just jid'}
return $ Right ())
c
return jid' return jid'
otherwise -> do _ -> do
lift $ errorM "Pontarius.XMPP" $ "xmppBind: JID could not be unpickled from: " lift $ errorM "Pontarius.XMPP"
++ show b $ "xmppBind: JID could not be unpickled from: "
++ show b
throwError $ XmppOtherFailure throwError $ XmppOtherFailure
otherwise -> do _ -> do
lift $ errorM "Pontarius.XMPP" "xmppBind: IQ error received." lift $ errorM "Pontarius.XMPP" "xmppBind: IQ error received."
throwError XmppOtherFailure throwError XmppOtherFailure
where where
@ -164,15 +135,6 @@ sessionXml = pickleElem
(xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session") (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 -- 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. -- if an IQ error stanza is returned from the server.
startSession :: Stream -> IO Bool startSession :: Stream -> IO Bool

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

@ -4,28 +4,23 @@
module Network.Xmpp.Sasl.Common where module Network.Xmpp.Sasl.Common where
import Network.Xmpp.Types
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Monad.Error import Control.Monad.Error
import Control.Monad.State.Class
import qualified Data.Attoparsec.ByteString.Char8 as AP import qualified Data.Attoparsec.ByteString.Char8 as AP
import Data.Bits import Data.Bits
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64 as B64
import Data.Maybe (fromMaybe)
import Data.Maybe (maybeToList) import Data.Maybe (maybeToList)
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding as Text
import Data.Word (Word8) import Data.Word (Word8)
import Data.XML.Pickle import Data.XML.Pickle
import Data.XML.Types import Data.XML.Types
import Network.Xmpp.Marshal
import Network.Xmpp.Stream
import Network.Xmpp.Sasl.StringPrep import Network.Xmpp.Sasl.StringPrep
import Network.Xmpp.Sasl.Types import Network.Xmpp.Sasl.Types
import Network.Xmpp.Marshal import Network.Xmpp.Stream
import Network.Xmpp.Types
import qualified System.Random as Random import qualified System.Random as Random
@ -66,9 +61,9 @@ pairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do
AP.skipSpace AP.skipSpace
name <- AP.takeWhile1 (/= '=') name <- AP.takeWhile1 (/= '=')
_ <- AP.char '=' _ <- AP.char '='
quote <- ((AP.char '"' >> return True) `mplus` return False) qt <- ((AP.char '"' >> return True) `mplus` return False)
content <- AP.takeWhile1 (AP.notInClass [',', '"']) content <- AP.takeWhile1 (AP.notInClass [',', '"'])
when quote . void $ AP.char '"' when qt . void $ AP.char '"'
return (name, content) return (name, content)
-- Failure element pickler. -- Failure element pickler.
@ -108,19 +103,20 @@ xpSaslElement = xpAlt saslSel
quote :: BS.ByteString -> BS.ByteString quote :: BS.ByteString -> BS.ByteString
quote x = BS.concat ["\"",x,"\""] 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 saslInit mechanism payload = do
r <- lift . pushElement . saslInitE mechanism $ r <- lift . pushElement . saslInitE mechanism $
Text.decodeUtf8 . B64.encode <$> payload Text.decodeUtf8 . B64.encode <$> payload
case r of case r of
Left e -> throwError $ AuthStreamFailure e Right True -> return ()
Right b -> return b Right False -> throwError $ AuthStreamFailure XmppNoStream
Left e -> throwError $ AuthStreamFailure e
-- | Pull the next element. -- | Pull the next element.
pullSaslElement :: ErrorT AuthFailure (StateT StreamState IO) SaslElement pullSaslElement :: ErrorT AuthFailure (StateT StreamState IO) SaslElement
pullSaslElement = do pullSaslElement = do
r <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement) mbse <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement)
case r of case mbse of
Left e -> throwError $ AuthStreamFailure e Left e -> throwError $ AuthStreamFailure e
Right (Left e) -> throwError $ AuthSaslFailure e Right (Left e) -> throwError $ AuthSaslFailure e
Right (Right r) -> return r Right (Right r) -> return r
@ -173,13 +169,13 @@ toPairs ctext = case pairs ctext of
Right r -> return r Right r -> return r
-- | Send a SASL response element. The content will be base64-encoded. -- | 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 respond m = do
r <- lift . pushElement . saslResponseE . fmap (Text.decodeUtf8 . B64.encode) $ m r <- lift . pushElement . saslResponseE . fmap (Text.decodeUtf8 . B64.encode) $ m
case r of case r of
Left e -> throwError $ AuthStreamFailure e 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. -- | Run the appropriate stringprep profiles on the credentials.
-- May fail with 'AuthStringPrepFailure' -- 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
( digestMd5 ( digestMd5
) where ) where
import Control.Applicative
import Control.Arrow (left)
import Control.Monad
import Control.Monad.Error import Control.Monad.Error
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Data.Maybe (fromJust, isJust)
import qualified Crypto.Classes as CC import qualified Crypto.Classes as CC
import qualified Data.Binary as Binary import qualified Data.Binary as Binary
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.Digest.Pure.MD5 as MD5 import qualified Data.Digest.Pure.MD5 as MD5
import qualified Data.List as L import qualified Data.List as L
import qualified Data.Text as Text
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text.Encoding as 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.Common
import Network.Xmpp.Sasl.StringPrep
import Network.Xmpp.Sasl.Types import Network.Xmpp.Sasl.Types
import Network.Xmpp.Types
@ -43,19 +27,19 @@ xmppDigestMd5 :: Text -- ^ Authentication identity (authzid or username)
-> Maybe Text -- ^ Authorization identity (authcid) -> Maybe Text -- ^ Authorization identity (authcid)
-> Text -- ^ Password (authzid) -> Text -- ^ Password (authzid)
-> ErrorT AuthFailure (StateT StreamState IO) () -> ErrorT AuthFailure (StateT StreamState IO) ()
xmppDigestMd5 authcid authzid password = do xmppDigestMd5 authcid' authzid' password' = do
(ac, az, pw) <- prepCredentials authcid authzid password (ac, az, pw) <- prepCredentials authcid' authzid' password'
Just address <- gets streamAddress Just address <- gets streamAddress
xmppDigestMd5' address ac az pw xmppDigestMd5' address ac az pw
where where
xmppDigestMd5' :: Text -> Text -> Maybe Text -> Text -> ErrorT AuthFailure (StateT StreamState IO) () 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. -- Push element and receive the challenge.
_ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean? _ <- saslInit "DIGEST-MD5" Nothing -- TODO: Check boolean?
pairs <- toPairs =<< saslFromJust =<< pullChallenge prs <- toPairs =<< saslFromJust =<< pullChallenge
cnonce <- liftIO $ makeNonce cnonce <- liftIO $ makeNonce
_b <- respond . Just $ createResponse hostname pairs cnonce _b <- respond . Just $ createResponse hostname prs cnonce
challenge2 <- pullFinalMessage _challenge2 <- pullFinalMessage
return () return ()
where where
-- Produce the response to the challenge. -- Produce the response to the challenge.
@ -63,19 +47,19 @@ xmppDigestMd5 authcid authzid password = do
-> Pairs -> Pairs
-> BS.ByteString -- nonce -> BS.ByteString -- nonce
-> BS.ByteString -> BS.ByteString
createResponse hostname pairs cnonce = let createResponse hname prs cnonce = let
Just qop = L.lookup "qop" pairs -- TODO: proper handling Just qop = L.lookup "qop" prs -- TODO: proper handling
Just nonce = L.lookup "nonce" pairs Just nonce = L.lookup "nonce" prs
uname_ = Text.encodeUtf8 authcid uname_ = Text.encodeUtf8 authcid
passwd_ = Text.encodeUtf8 password passwd_ = Text.encodeUtf8 password
-- Using Int instead of Word8 for random 1.0.0.0 (GHC 7) -- Using Int instead of Word8 for random 1.0.0.0 (GHC 7)
-- compatibility. -- compatibility.
nc = "00000001" nc = "00000001"
digestURI = "xmpp/" `BS.append` Text.encodeUtf8 hostname digestURI = "xmpp/" `BS.append` Text.encodeUtf8 hname
digest = md5Digest digest = md5Digest
uname_ uname_
(lookup "realm" pairs) (lookup "realm" prs)
passwd_ passwd_
digestURI digestURI
nc nc
@ -84,7 +68,7 @@ xmppDigestMd5 authcid authzid password = do
cnonce cnonce
response = BS.intercalate "," . map (BS.intercalate "=") $ response = BS.intercalate "," . map (BS.intercalate "=") $
[["username", quote uname_]] ++ [["username", quote uname_]] ++
case L.lookup "realm" pairs of case L.lookup "realm" prs of
Just realm -> [["realm" , quote realm ]] Just realm -> [["realm" , quote realm ]]
Nothing -> [] ++ Nothing -> [] ++
[ ["nonce" , quote nonce ] [ ["nonce" , quote nonce ]
@ -115,8 +99,8 @@ xmppDigestMd5 authcid authzid password = do
-> BS8.ByteString -> BS8.ByteString
-> BS8.ByteString -> BS8.ByteString
-> BS8.ByteString -> BS8.ByteString
md5Digest uname realm password digestURI nc qop nonce cnonce = md5Digest uname realm pwd digestURI nc qop nonce cnonce =
let ha1 = hash [ hashRaw [uname, maybe "" id realm, password] let ha1 = hash [ hashRaw [uname, maybe "" id realm, pwd]
, nonce , nonce
, cnonce , cnonce
] ]

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

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

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

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

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

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

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

@ -3,76 +3,27 @@
{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_HADDOCK hide #-}
module Network.Xmpp.Utilities (presTo, message, answerMessage, openElementToEvents, renderOpenElement, renderElement) where module Network.Xmpp.Utilities
( presTo
import Network.Xmpp.Types , message
, answerMessage
import Control.Monad.STM , openElementToEvents
import Control.Concurrent.STM.TVar , renderOpenElement
import Prelude , renderElement)
where
import Data.XML.Types
import Network.Xmpp.Types
import qualified Data.Attoparsec.Text as AP import Prelude
import qualified Data.Text as Text import Data.XML.Types
import qualified Data.ByteString as BS 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 as Text
import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding as Text
import System.IO.Unsafe(unsafePerformIO) 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 qualified Text.XML.Stream.Render as TXSR
import Text.XML.Unresolved as TXU 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. -- | Add a recipient to a presence notification.
presTo :: Presence -> Jid -> Presence presTo :: Presence -> Jid -> Presence
presTo pres to = pres{presenceTo = Just to} presTo pres to = pres{presenceTo = Just to}
@ -124,4 +75,5 @@ renderElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO
$ CL.sourceList (elementToEvents e) $$ TXSR.renderText def =$ CL.consume $ CL.sourceList (elementToEvents e) $$ TXSR.renderText def =$ CL.consume
where where
elementToEvents :: Element -> [Event] 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 @@
module Network.Xmpp.Xep.DataForms where module Network.Xmpp.Xep.DataForms where
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.XML.Pickle
import qualified Data.XML.Types as XML 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 :: Text.Text
dataFormNs = "jabber:x:data" dataFormNs = "jabber:x:data"
@ -95,12 +92,12 @@ instance Read FieldType where
xpForm :: PU [XML.Node] Form xpForm :: PU [XML.Node] Form
xpForm = xpWrap (\(tp , (title, instructions, fields, reported, items)) -> xpForm = xpWrap (\(tp , (ttl, ins, flds, rpd, its)) ->
Form tp title (map snd instructions) fields reported (map snd items)) Form tp ttl (map snd ins) flds rpd (map snd its))
(\(Form tp title instructions fields reported items) -> (\(Form tp ttl ins flds rpd its) ->
(tp , (tp ,
(title, map ((),) instructions (ttl, map ((),) ins
, fields, reported, map ((),) items))) , flds, rpd, map ((),) its)))
$ $
xpElem (dataFormName "x") xpElem (dataFormName "x")
@ -113,10 +110,10 @@ xpForm = xpWrap (\(tp , (title, instructions, fields, reported, items)) ->
(xpElems (dataFormName "item") xpUnit xpFields)) (xpElems (dataFormName "item") xpUnit xpFields))
xpFields :: PU [XML.Node] [Field] xpFields :: PU [XML.Node] [Field]
xpFields = xpWrap (map $ \((var, tp, label),(desc, req, vals, opts)) xpFields = xpWrap (map $ \((var, tp, lbl),(desc, req, vals, opts))
-> Field var label tp desc req vals opts) -> Field var lbl tp desc req vals opts)
(map $ \(Field var label tp desc req vals opts) (map $ \(Field var lbl tp desc req vals opts)
-> ((var, tp, label),(desc, req, vals, opts))) $ -> ((var, tp, lbl),(desc, req, vals, opts))) $
xpElems (dataFormName "field") xpElems (dataFormName "field")
(xp3Tuple (xp3Tuple
(xpAttrImplied "var" xpId ) (xpAttrImplied "var" xpId )

Write Preview
Loading…
Cancel
Save