module Network.XMPiPe.Core.S2S.Client (
Mpi(..), Jid(..), Tags(..), tagsNull, tagsType,
starttls, sasl, begin, input, output,
) where
import "monads-tf" Control.Monad.State
import "monads-tf" Control.Monad.Error
import Data.Pipe
import Text.XML.Pipe
import qualified Data.ByteString as BS
import SaslClient hiding (sasl)
import qualified SaslClient as S
import Xmpp hiding (input, output)
input :: Monad m => [Xmlns] -> Pipe BS.ByteString Mpi m ()
input = inputMpi
output :: Monad m => Pipe Mpi BS.ByteString m ()
output = outputMpi
starttls :: Monad m =>
BS.ByteString -> BS.ByteString -> Pipe BS.ByteString BS.ByteString m ()
starttls fr to = inputP3 =$= processTls fr to =$= outputS
processTls :: Monad m => BS.ByteString -> BS.ByteString -> Pipe Xmpp Xmpp m ()
processTls fr to = do
yield XCDecl
yield $ XCBegin [(From, fr), (To, to), (TagRaw $ nullQ "version", "1.0")]
procTls
procTls :: Monad m => Pipe Xmpp Xmpp m ()
procTls = await >>= \mx -> case mx of
Just (XCBegin _as) -> procTls
Just (XCFeatures [FtStarttls _]) -> do
yield XCStarttls
procTls
Just XCProceed -> return ()
Just _ -> return ()
_ -> return ()
sasl :: (
MonadState m, SaslState (StateType m),
MonadError m, Error (ErrorType m) ) =>
BS.ByteString -> BS.ByteString -> Pipe BS.ByteString BS.ByteString m ()
sasl fr to = inputP3 =$= processSasl fr to =$= outputS
processSasl :: (
MonadState m, SaslState (StateType m),
MonadError m, Error (ErrorType m) ) =>
BS.ByteString -> BS.ByteString -> Pipe Xmpp Xmpp m ()
processSasl fr to = do
yield XCDecl
yield $ XCBegin [ (From, fr), (To, to), (TagRaw $ nullQ "version", "1.0")]
procSasl
procSasl :: (
MonadState m, SaslState (StateType m),
MonadError m, Error (ErrorType m)
) => Pipe Xmpp Xmpp m ()
procSasl = await >>= \mx -> case mx of
Just (XCBegin _as) -> procSasl
Just (XCFeatures [FtMechanisms ["EXTERNAL"]]) -> do
st <- lift $ gets getSaslState
lift . modify . putSaslState $ ("username", "") : st
S.sasl "EXTERNAL"
lift . modify $ putSaslState st
_ -> return ()
begin :: Monad m =>
BS.ByteString -> BS.ByteString -> Pipe BS.ByteString BS.ByteString m [Xmlns]
begin fr to = inputFeature =@= process fr to =$= outputS
process :: Monad m => BS.ByteString -> BS.ByteString -> Pipe Xmpp Xmpp m ()
process fr to = do
yield XCDecl
yield $ XCBegin [(From, fr), (To, to), (TagRaw $ nullQ "version", "1.0")]
Just (XCBegin _as) <- await
Just (XCFeatures []) <- await
_ <- await
return ()