module Network.XmlPush.Http.Tls.Server (
HttpTlsSv,
HttpTlsSvArgs(..), Mechanism(..),
HttpPullTlsSvArgs(..), HttpPullSvArgs(HttpPullSvArgs),
HttpPushTlsArgs(..), HttpPushArgs(HttpPushArgs),
TlsArgsCl, tlsArgsCl, TlsArgsSv, tlsArgsSv,
) where
import Control.Applicative
import "monads-tf" Control.Monad.Error
import Control.Monad.Base
import Control.Monad.Trans.Control
import Data.Maybe
import Data.HandleLike
import Data.Pipe
import Data.Pipe.List
import Text.XML.Pipe
import Network.XmlPush
import Network.XmlPush.HttpPull.Tls.Server.Body
import Network.XmlPush.HttpPush.Tls.Body
import qualified Network.XmlPush.Tls.Client as Cl
import qualified Network.XmlPush.Tls.Server as Sv
import Network.TigHTTP.Server
import Network.Sasl
import Network.PeyoTLS.Server
import "crypto-random" Crypto.Random
newtype HttpTlsSv h = HttpTlsSv (Either (HttpPullTlsSv h) (HttpPushTls h))
data Mechanism = Pull | Push deriving Show
data HttpTlsSvArgs h = HttpTlsSvArgs
(XmlNode -> Mechanism) (HttpPullSvArgs h) (HttpPushArgs h)
Cl.TlsArgs Sv.TlsArgs
instance XmlPusher HttpTlsSv where
type NumOfHandle HttpTlsSv = Two
type PusherArgs HttpTlsSv = HttpTlsSvArgs
generate (Two ch (Just sh)) (HttpTlsSvArgs s pla psa tlsC tlsS) =
makeHttpTlsSv ch sh s pla psa tlsC tlsS
generate _ _ = error "bad"
readFrom (HttpTlsSv e) = either readFrom readFrom e
writeTo (HttpTlsSv e) = either writeTo writeTo e
makeHttpTlsSv :: (
ValidateHandle h, MonadBaseControl IO (HandleMonad h),
MonadError (HandleMonad h), SaslError (ErrorType (HandleMonad h))
) => Maybe h -> h -> (XmlNode -> Mechanism) ->
HttpPullSvArgs h -> HttpPushArgs h ->
Cl.TlsArgs -> Sv.TlsArgs ->
HandleMonad h (HttpTlsSv h)
makeHttpTlsSv ch sh s pla' psa' tlsC tlsS@(TlsArgs gn cc cs mca kcs) = do
g <- liftBase (cprgCreate <$> createEntropyPool :: IO SystemRNG)
(`run` g) $ do
t <- open sh cs kcs mca
rq <- getRequest t
Just [rn] <- runPipe $ requestBody rq
=$= xmlEvent
=$= convert fromJust
=$= xmlNode []
=$= toList
HttpTlsSv `liftM` case s rn of
Pull -> do
HttpPullTlsSv r w <- makeHttpPull [rn] t pla' gn cc
return . Left $ HttpPullTlsSv r w
Push -> do
hlDebug t "medium" "PUSH\n"
ps <- makeHttpPush [rn] ch t $
HttpPushTlsArgs psa' tlsC tlsS
return $ Right ps