{-# LANGUAGE OverloadedStrings,
	TypeFamilies, FlexibleContexts, ScopedTypeVariables,
	PackageImports #-}

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.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 (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 (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 =$= toTChan otc
	let	r = fromTChan inc =$= input ns
	return $ XmppTls wr nr r wc