module Network.XmlPush.Xmpp.Tls (
XmppTls, XmppTlsArgs(..), XmppArgs(..), TlsArgs(..)) where
import Prelude hiding (filter)
import Control.Applicative
import "monads-tf" Control.Monad.State
import "monads-tf" Control.Monad.Writer
import "monads-tf" Control.Monad.Error
import Control.Monad.Base
import Control.Monad.Trans.Control
import Control.Concurrent hiding (yield)
import Control.Concurrent.STM
import Data.Maybe
import Data.HandleLike
import Data.Pipe
import Data.Pipe.IO
import Data.Pipe.Flow
import Data.Pipe.TChan
import Text.XML.Pipe
import Network.XMPiPe.Core.C2S.Client
import Network.PeyoTLS.TChan.Client
import "crypto-random" Crypto.Random
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Network.XmlPush
import Network.XmlPush.Xmpp.Common
import Network.XmlPush.Tls.Client
data XmppTls h = XmppTls
(XmlNode -> Bool)
(TChan (Maybe BS.ByteString))
(Pipe () Mpi (HandleMonad h) ())
(TChan (Either BS.ByteString XmlNode))
data XmppTlsArgs h = XmppTlsArgs Bool (XmppArgs h) TlsArgs
instance XmlPusher XmppTls where
type NumOfHandle XmppTls = One
type PusherArgs XmppTls = XmppTlsArgs
generate = makeXmppTls
readFrom (XmppTls wr nr r wc) = r
=$= pushId wr nr wc
=$= convert fromMessage
=$= filter isJust
=$= convert fromJust
writeTo (XmppTls _ _nr _ w) = convert Right =$= toTChan w
makeXmppTls :: (
ValidateHandle h, MonadBaseControl IO (HandleMonad h),
MonadError (HandleMonad h), Error (ErrorType (HandleMonad h))
) => One h -> XmppTlsArgs h -> HandleMonad h (XmppTls h)
makeXmppTls (One h) (XmppTlsArgs dbg
(XmppArgs ms me ps you inr wr) (TlsArgs dn _ _ cs ca kcs)) = do
nr <- liftBase $ atomically newTChan
wc <- liftBase $ atomically newTChan
(g :: SystemRNG) <- liftBase $ cprgCreate <$> createEntropyPool
let (Jid un d (Just rsc)) = me
(cn, g') = cprgGenerate 32 g
ss = St [
("username", un), ("authcid", un), ("password", ps),
("cnonce", cn) ]
runPipe_ $ fromHandleLike h =$= starttls (BSC.pack dn) =$= toHandleLike h
(inc, otc) <- open' h dn cs kcs ca g'
(`evalStateT` ss) . runPipe_ $ fromTChan inc =$= sasl d ms =$= toTChan otc
(Just ns, _fts) <- runWriterT . runPipe $ fromTChan inc
=$= bind d rsc
=@= toTChan otc
runPipe_ $ yield (Presence tagsNull []) =$= output =$= toTChan otc
(>> return ()) . liftBaseDiscard forkIO . runPipe_ $ fromTChan wc
=$= addRandom =$= makeResponse inr you nr =$= output
=$= (if dbg then debug else convert id)
=$= toTChan otc
let r = fromTChan inc
=$= (if dbg then debug else convert id)
=$= input ns
return $ XmppTls wr nr r wc