module Network.XMPiPe.Core.C2S.Client (
Mpi(..), Feature, Jid(..), toJid,
Tags(..), tagsNull, tagsType,
starttls, sasl, bind, input, output,
) where
import Control.Monad
import "monads-tf" Control.Monad.State
import "monads-tf" Control.Monad.Writer
import "monads-tf" Control.Monad.Error
import Data.Maybe
import Data.List
import Data.Pipe
import Text.XML.Pipe
import qualified Data.ByteString as BS
import Xmpp hiding (input, output, Feature)
import qualified Xmpp as X
import qualified SaslClient as SASL
input :: Monad m => [Xmlns] -> Pipe BS.ByteString Mpi m ()
input = inputMpi
output :: Monad m => Pipe Mpi BS.ByteString m ()
output = outputMpi
begin :: Monad m => BS.ByteString -> BS.ByteString -> Pipe Xmpp Xmpp m ()
begin h l = do
yield XCDecl
yield $ XCBegin [(To, h), (TagRaw $ nullQ "version", "1.0"), (Lang, l)]
starttls :: Monad m => BS.ByteString -> Pipe BS.ByteString BS.ByteString m ()
starttls hst = inputP3 =$= (begin hst "en" >> starttls_) =$= X.output
starttls_ :: Monad m => Pipe Xmpp Xmpp m ()
starttls_ = do
Just (XCBegin _as) <- await
Just (XCFeatures fs) <- await
unless (any isSt fs) $ fail "starttls_: not support tls"
yield XCStarttls
Just XCProceed <- await
return ()
where isSt (FtStarttls _) = True; isSt _ = False
sasl :: (
MonadState m, SASL.SaslState (StateType m),
MonadError m, Error (ErrorType m)) =>
BS.ByteString -> [BS.ByteString] -> Pipe BS.ByteString BS.ByteString m ()
sasl hst ms = inputP2 =$= sasl' hst ms =$= X.output
sasl' :: (
MonadState m, SASL.SaslState (StateType m),
MonadError m, Error (ErrorType m)) =>
BS.ByteString -> [BS.ByteString] -> Pipe Xmpp Xmpp m ()
sasl' hst ms = begin hst "en" >> sasl_ ms
sasl_ :: (Monad m, MonadState m, SASL.SaslState (StateType m), MonadError m, Error (ErrorType m) ) =>
[BS.ByteString] -> Pipe Xmpp Xmpp m ()
sasl_ sl = do
Just (XCBegin _as) <- await
Just (XCFeatures fs) <- await
let Just (FtMechanisms ms) = find isFtMechanisms fs
Just n = listToMaybe $ sl `intersect` ms
SASL.sasl n
where
isFtMechanisms (FtMechanisms _) = True
isFtMechanisms _ = False
bind :: (Monad m,
MonadWriter m, [Feature] ~ WriterType m,
MonadError m, Error (ErrorType m) ) =>
BS.ByteString -> BS.ByteString -> Pipe BS.ByteString BS.ByteString m [Xmlns]
bind hst r = inputP3 =@= (begin hst "en" >> bind_ r) =$= X.output
bind_ :: (
MonadWriter m, [Feature] ~ (WriterType m),
MonadError m, Error (ErrorType m) ) =>
BS.ByteString -> Pipe Xmpp Xmpp m ()
bind_ r = await >>= \mr -> case mr of
Just (XCFeatures fs) -> do
let (b, fs') = sepBind fs
mapM_ yield . catMaybes $
map (responseToFeature r) $ filter notFtSession b
tell $ map getFeature fs'
bind_ r
Just _ -> bind_ r
_ -> return ()
type Feature = XmlNode
getFeature :: X.Feature -> Feature
getFeature (FtRaw ft) = ft
getFeature _ = error "Network.XMPiPe.Core.C2S.Client.getFeature: bad"
sepBind :: [X.Feature] -> ([X.Feature], [X.Feature])
sepBind = partition notFtRaw
notFtSession :: X.Feature -> Bool
notFtSession (FtSession _) = False
notFtSession _ = True
notFtRaw :: X.Feature -> Bool
notFtRaw (FtRaw _) = False
notFtRaw _ = True
responseToFeature :: BS.ByteString -> X.Feature -> Maybe Xmpp
responseToFeature r (FtBind _) = Just
. SRIqBind [(Type, "set"), (Id, "_xmpp_bind1")] . IqBind Nothing
$ Resource r
responseToFeature _ _ = Nothing