xml-push 0.0.0.14 → 0.0.0.15

raw patch · 9 files changed

+448/−287 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• examples/httpPushTlsE.hs +2/−2
• examples/httpPushTlsT.hs +1/−1
• src/Network/XmlPush/Http/Tls/Server.hs +72/−0
• src/Network/XmlPush/HttpPull/Server/Body.hs +0/−2
• src/Network/XmlPush/HttpPull/Tls/Server.hs +1/−74
• src/Network/XmlPush/HttpPull/Tls/Server/Body.hs +87/−0
• src/Network/XmlPush/HttpPush/Tls.hs +1/−206
• src/Network/XmlPush/HttpPush/Tls/Body.hs +279/−0
• xml-push.cabal +5/−2

@@ -15,10 +15,10 @@ 	ca <- readCertificateStore ["certs/cacert.sample_pem"] 	k' <- readKey "certs/yoshikuni.sample_key" 	c' <- readCertificateChain ["certs/yoshikuni.sample_crt"]-	ch <- connectTo "localhost" $ PortNumber 80+	ch <- connectTo "localhost" $ PortNumber 443 	testPusher (undefined :: HttpPushTls Handle) (Two (Just ch) Nothing) (HttpPushTlsArgs 		(HttpPushArgs (const Nothing) getServerHandle-			(Just ("localhost", 80, "")) gtPth wntRspns)+			(Just ("localhost", 443, "")) gtPth wntRspns) 		(tlsArgsCl "localhost" True (const Nothing) 			["TLS_RSA_WITH_AES_128_CBC_SHA"] ca 			[(k', c')])

@@ -14,7 +14,7 @@  main :: IO () main = do-	soc <- listenOn $ PortNumber 80+	soc <- listenOn $ PortNumber 443 	ca <- readCertificateStore ["certs/cacert.sample_pem"] 	k' <- readKey "certs/localhost.sample_key" 	c' <- readCertificateChain ["certs/localhost.sample_crt"]

@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-}++module Network.XmlPush.Http.Tls.Server (+	HttpTlsSv,+	HttpTlsSvArgs(..), Mechanism(..),+	HttpPullTlsSvArgs(..), HttpPullSvArgs(HttpPullSvArgs),+	HttpPushTlsArgs(..), HttpPushArgs(HttpPushArgs),+	tlsArgsCl, 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 "critical" "PUSH\n"+				ps <- makeHttpPush [rn] ch t $+					HttpPushTlsArgs psa' tlsC tlsS+				return $ Right ps

@@ -30,9 +30,7 @@ makeHttpPull :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) => 	[XmlNode] -> One h -> HttpPullSvArgs h -> HandleMonad h (HttpPullSv h) makeHttpPull pre (One h) (HttpPullSvArgs ip ep ynr) = do---	hlDebug h "critical" "begin makeHttpPull\n" 	(inc, otc) <- runXml pre h ip ep ynr (convert id)---	hlDebug h "critical" "runXml done\n" 	return $ HttpPullSv (fromTChan inc) (toTChan otc)  data HttpPullSvTest h = HttpPullSvTest

@@ -5,77 +5,4 @@ 	HttpPullTlsSv, HttpPullTlsSvArgs(..), HttpPullSvArgs(..), TlsArgs(..) 	) where -import Prelude hiding (filter)--import Control.Applicative-import Control.Monad-import "monads-tf" Control.Monad.Trans-import Control.Monad.Base-import Control.Monad.Trans.Control--- import Data.List--- import Data.Char-import Data.HandleLike-import Data.Pipe-import Data.Pipe.TChan-import Data.X509 hiding (getCertificate)--- import Data.X509.Validation-import Text.XML.Pipe--- import Numeric-import Network.PeyoTLS.Server-import "crypto-random" Crypto.Random---- import qualified Data.ByteString as BS--- import qualified Data.ByteString.Char8 as BSC--import Network.XmlPush-import Network.XmlPush.HttpPull.Server.Common-import Network.XmlPush.Tls.Server--data HttpPullTlsSv h = HttpPullTlsSv-	(Pipe () XmlNode (HandleMonad h) ())-	(Pipe XmlNode () (HandleMonad h) ())--data HttpPullTlsSvArgs h = HttpPullTlsSvArgs (HttpPullSvArgs h) TlsArgs--instance XmlPusher HttpPullTlsSv where-	type NumOfHandle HttpPullTlsSv = One-	type PusherArgs HttpPullTlsSv = HttpPullTlsSvArgs-	generate = makeHttpPull-	readFrom (HttpPullTlsSv r _) = r-	writeTo (HttpPullTlsSv _ w) = w--makeHttpPull :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) =>-	One h -> HttpPullTlsSvArgs h -> HandleMonad h (HttpPullTlsSv h)-makeHttpPull (One h) (HttpPullTlsSvArgs-	(HttpPullSvArgs ip ep ynr) (TlsArgs gn cc cs mca kcs)) = do-	g <- liftBase (cprgCreate <$> createEntropyPool :: IO SystemRNG)-	(inc, otc) <- (`run` g) $ do-		t <- open h cs kcs mca-		{--		getCertificate t >>= hlDebug t "medium" . BSC.pack . show-			. toHexStr-			. flip getFingerprint HashSHA256-			-}-		runXml [] t ip ep ynr $ checkNameP t gn cc-	return $ HttpPullTlsSv (fromTChan inc) (toTChan otc)--{--toHexStr :: Fingerprint -> String-toHexStr (Fingerprint bs) = lastN 29 .-	intercalate ":" . map (map toUpper . flip showHex "") $ BS.unpack bs--lastN :: Int -> [a] -> [a]-lastN n xs = drop (length xs - n) xs--}--checkNameP :: HandleLike h => TlsHandle h g -> (XmlNode -> Maybe String) ->-	(XmlNode -> Maybe (SignedCertificate -> Bool)) ->-	Pipe XmlNode XmlNode (TlsM h g) ()-checkNameP t gn cc = (await >>=) . maybe (return ()) $ \n -> do-	ok <- maybe (return True) (lift . checkName t) $ gn n-	unless ok $ error "checkNameP: bad client name"-	let ck = maybe (const True) id $ cc n-	c <- lift $ getCertificate t-	unless (ck c) $ error "checkNameP: bad certificate"-	yield n-	checkNameP t gn cc+import Network.XmlPush.HttpPull.Tls.Server.Body

@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts,+	PackageImports #-}++module Network.XmlPush.HttpPull.Tls.Server.Body (+	HttpPullTlsSv(..), HttpPullTlsSvArgs(..), HttpPullSvArgs(..), TlsArgs(..),+	HttpPullTlsSvTest(..), HttpPullTlsSvTestArgs(..),+	makeHttpPull,+	makeHttpPullTls,+	) where++import Prelude hiding (filter)++import Control.Applicative+import Control.Monad+import "monads-tf" Control.Monad.Trans+import Control.Monad.Base+import Control.Monad.Trans.Control+import Data.HandleLike+import Data.Pipe+import Data.Pipe.TChan+import Data.X509 hiding (getCertificate)+import Text.XML.Pipe+import Network.PeyoTLS.Server+import "crypto-random" Crypto.Random++import Network.XmlPush+import Network.XmlPush.HttpPull.Server.Common+import Network.XmlPush.Tls.Server++data HttpPullTlsSv h = HttpPullTlsSv+	(Pipe () XmlNode (HandleMonad h) ())+	(Pipe XmlNode () (HandleMonad h) ())++data HttpPullTlsSvArgs h = HttpPullTlsSvArgs (HttpPullSvArgs h) TlsArgs++instance XmlPusher HttpPullTlsSv where+	type NumOfHandle HttpPullTlsSv = One+	type PusherArgs HttpPullTlsSv = HttpPullTlsSvArgs+	generate = makeHttpPullTls []+	readFrom (HttpPullTlsSv r _) = r+	writeTo (HttpPullTlsSv _ w) = w++data HttpPullTlsSvTest h = HttpPullTlsSvTest+	(Pipe () XmlNode (HandleMonad h) ())+	(Pipe XmlNode () (HandleMonad h) ())++data HttpPullTlsSvTestArgs h = HttpPullTlsSvTestArgs (HttpPullTlsSvArgs h) [XmlNode]++instance XmlPusher HttpPullTlsSvTest where+	type NumOfHandle HttpPullTlsSvTest = One+	type PusherArgs HttpPullTlsSvTest = HttpPullTlsSvTestArgs+	generate h (HttpPullTlsSvTestArgs a pre) = do+		HttpPullTlsSv r w <- makeHttpPullTls pre h a+		return $ HttpPullTlsSvTest r w+	readFrom (HttpPullTlsSvTest r _) = r+	writeTo (HttpPullTlsSvTest _ w) = w++makeHttpPullTls :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) =>+	[XmlNode] ->+	One h -> HttpPullTlsSvArgs h -> HandleMonad h (HttpPullTlsSv h)+makeHttpPullTls pre (One h) (HttpPullTlsSvArgs+	(HttpPullSvArgs ip ep ynr) (TlsArgs gn cc cs mca kcs)) = do+	g <- liftBase (cprgCreate <$> createEntropyPool :: IO SystemRNG)+	(`run` g) $ do+		t <- open h cs kcs mca+		makeHttpPull pre t (HttpPullSvArgs ip ep ynr) gn cc++makeHttpPull :: (ValidateHandle h, CPRG g, MonadBaseControl IO (HandleMonad h)) =>+	[XmlNode] -> TlsHandle h g -> HttpPullSvArgs h ->+	(XmlNode -> Maybe String) ->+	(XmlNode -> Maybe (SignedCertificate -> Bool)) ->+	TlsM h g (HttpPullTlsSv h)+makeHttpPull pre t (HttpPullSvArgs ip ep ynr) gn cc = do+		(inc, otc) <- runXml pre t ip ep ynr $ checkNameP t gn cc+		return $ HttpPullTlsSv (fromTChan inc) (toTChan otc)++checkNameP :: HandleLike h => TlsHandle h g -> (XmlNode -> Maybe String) ->+	(XmlNode -> Maybe (SignedCertificate -> Bool)) ->+	Pipe XmlNode XmlNode (TlsM h g) ()+checkNameP t gn cc = (await >>=) . maybe (return ()) $ \n -> do+	ok <- maybe (return True) (lift . checkName t) $ gn n+	unless ok $ error "checkNameP: bad client name"+	let ck = maybe (const True) id $ cc n+	c <- lift $ getCertificate t+	unless (ck c) $ error "checkNameP: bad certificate"+	yield n+	checkNameP t gn cc

@@ -6,209 +6,4 @@ 	HttpPushTls, HttpPushTlsArgs(..), HttpPushArgs(..), 	TlsArgsCl, tlsArgsCl, TlsArgsSv, tlsArgsSv) where -import Prelude hiding (filter)--import Control.Applicative-import Control.Monad-import "monads-tf" Control.Monad.Trans-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 Data.X509 hiding (getCertificate)-import Data.X509.CertificateStore-import Text.XML.Pipe-import Network.TigHTTP.Server-import Network.PeyoTLS.ReadFile-import Network.PeyoTLS.Server (getCertificate)-import Network.PeyoTLS.Client (ValidateHandle)-import "crypto-random" Crypto.Random--import qualified Data.ByteString.Lazy as LBS-import qualified Network.PeyoTLS.Client as Cl-import qualified Network.PeyoTLS.Server as Sv--import Network.XmlPush-import Network.XmlPush.HttpPush.Common-import Network.XmlPush.Tls.Client as TC-import Network.XmlPush.Tls.Server as TS--type TlsArgsCl = TC.TlsArgs--tlsArgsCl :: String -> Bool ->-	(XmlNode -> Maybe (SignedCertificate -> Bool)) ->-	[Cl.CipherSuite] -> CertificateStore ->-	[(CertSecretKey, CertificateChain)] -> TlsArgsCl-tlsArgsCl = TC.TlsArgs--type TlsArgsSv = TS.TlsArgs--tlsArgsSv :: (XmlNode -> Maybe String) ->-	(XmlNode -> Maybe (SignedCertificate -> Bool)) -> [Cl.CipherSuite] ->-	Maybe CertificateStore -> [(CertSecretKey, CertificateChain)] -> TlsArgsSv-tlsArgsSv = TS.TlsArgs--data HttpPushTls h = HttpPushTls {-	needReply :: TVar Bool,-	clientReadChan :: TChan (XmlNode, Bool),-	clientWriteChan :: TChan (Maybe XmlNode),-	serverReadChan :: TChan (XmlNode, Bool),-	serverWriteChan :: TChan (Maybe XmlNode) }--data HttpPushTlsArgs h = HttpPushTlsArgs (HttpPushArgs h) TC.TlsArgs TS.TlsArgs--instance XmlPusher HttpPushTls where-	type NumOfHandle HttpPushTls = Two-	type PusherArgs HttpPushTls = HttpPushTlsArgs-	generate (Two ch sh) = makeHttpPushTls ch sh-	readFrom hp = fromTChans [clientReadChan hp, serverReadChan hp] =$=-		setNeedReply (needReply hp)-	writeTo hp = (convert (((), ) . Just) =$=) . toTChansM $ do-		nr <- liftBase . atomically . readTVar $ needReply hp-		liftBase . atomically $ writeTVar (needReply hp) False-		return [-			(const nr, serverWriteChan hp),-			(const True, clientWriteChan hp) ]--makeHttpPushTls :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) =>-	Maybe h -> Maybe h ->-	HttpPushTlsArgs h -> HandleMonad h (HttpPushTls h)-makeHttpPushTls mch msh (HttpPushTlsArgs (HttpPushArgs gc gs hi gp wr)-	(TC.TlsArgs dn cdn cc' cs ca kcs) (TS.TlsArgs gn cc cs' mca' kcs')) = do-	vch <- liftBase . atomically $ newTVar mch-	vsh <- liftBase . atomically $ newTVar msh-	case hi of-		Just (hn, _, _) -> when (dn /= hn) $-			error "makeHttpPushTls: conflicted domain name"-		_ -> return ()-	v <- liftBase . atomically $ newTVar False-	vhi <- liftBase . atomically $ newTVar hi-	(ci, co) <- clientC vch vhi cdn cc' gp cs ca kcs-	(si, so) <- talk wr vsh gn cc cs' mca' kcs' vch vhi gc gs-	return $ HttpPushTls v ci co si so--clientC :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) =>-	TVar (Maybe h) -> TVar (Maybe (String, Int, FilePath)) -> Bool ->-	(XmlNode -> Maybe (SignedCertificate -> Bool)) ->-	(XmlNode -> FilePath) ->-	[Cl.CipherSuite] -> CertificateStore ->-	[(CertSecretKey, CertificateChain)] ->-	HandleMonad h (TChan (XmlNode, Bool), TChan (Maybe XmlNode))-clientC vh vhi cdn cc gp cs ca kcs = do-	inc <- liftBase $ atomically newTChan-	otc <- liftBase $ atomically newTChan-	(g :: SystemRNG) <- liftBase $ cprgCreate <$> createEntropyPool-	void . liftBaseDiscard forkIO $ do-		h <- liftBase . atomically $ do-			mh <- readTVar vh-			case mh of-				Just h -> return h-				_ -> retry-		(hn, pn, pt) <- liftBase . atomically $ do-			mhi <- readTVar vhi-			case mhi of-				Just hi -> return hi-				_ -> retry-		(`Cl.run` g) $ do-			t <- (if cdn then Cl.open' h hn else Cl.open h) cs kcs ca-			runPipe_ $ fromTChan otc-				=$= filter isJust-				=$= convert fromJust-				=$= clientLoop t hn pn pt gp (checkCertCl t cc)-				=$= convert (, False)-				=$= toTChan inc-	return (inc, otc)--talk :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) =>-	(XmlNode -> Bool) -> (TVar (Maybe h)) -> (XmlNode -> Maybe String) ->-	(XmlNode -> Maybe (SignedCertificate -> Bool)) -> [Sv.CipherSuite] ->-	Maybe CertificateStore -> [(CertSecretKey, CertificateChain)] ->-	TVar (Maybe h) -> TVar (Maybe (String, Int, FilePath)) ->-	(XmlNode -> Maybe (HandleMonad h h, String, Int, FilePath)) ->-	Maybe (HandleMonad h h) ->-	HandleMonad h (TChan (XmlNode, Bool), TChan (Maybe XmlNode))-talk wr vh gn cc cs mca kcs vch vhi gc mgs = do-	inc <- liftBase $ atomically newTChan-	otc <- liftBase $ atomically newTChan-	g <- liftBase (cprgCreate <$> createEntropyPool :: IO SystemRNG)-	void . liftBaseDiscard forkIO $ do-		flip (maybe (return ())) mgs $ \gs -> do-			h <- gs-			liftBase . atomically $ writeTVar vh (Just h)-		h <- liftBase . atomically $ do-			mh <- readTVar vh-			case mh of-				Just h -> return h-				_ -> retry-		(`Sv.run` g) $ do-			t <- Sv.open h cs kcs mca-			runPipe_ . forever $ do-				req <- lift $ getRequest t-				requestBody req-					=$= xmlEvent-					=$= convert fromJust-					=$= xmlNode []-					=$= setClient vch vhi gc-					=$= checkCert t cc-					=$= checkName t gn-					=$= checkReply wr otc-					=$= toTChan inc-				fromTChan otc =$= await >>= maybe (return ()) (\mn ->-					lift . putResponse t . responseP $ case mn of-						Just n -> LBS.fromChunks [xmlString [n]]-						_ -> "")-	return (inc, otc)--checkCert :: HandleLike h => Sv.TlsHandle h g ->-	(XmlNode -> Maybe (SignedCertificate -> Bool)) ->-	Pipe XmlNode XmlNode (Sv.TlsM h g) ()-checkCert t cc = (await >>=) . maybe (return ()) $ \n -> do-	let ck = maybe (const True) id $ cc n-	c <- lift $ getCertificate t-	unless (ck c) $ error "checkCert: bad certificate"-	yield n-	checkCert t cc--checkCertCl :: (ValidateHandle h, CPRG g) => Cl.TlsHandle h g ->-	(XmlNode -> Maybe (SignedCertificate -> Bool)) ->-	Pipe XmlNode XmlNode (Cl.TlsM h g) ()-checkCertCl t cc = (await >>=) . maybe (return ()) $ \n -> do-	lift $ hlDebug t "medium" "begin checkCertCl"-	let ck = maybe (const True) id $ cc n-	c <- lift $ Cl.getCertificate t-	unless (ck c) $ error "checkCert: bad certificate"-	yield n-	checkCertCl t cc--checkName :: HandleLike h => Sv.TlsHandle h g -> (XmlNode -> Maybe String) ->-	Pipe XmlNode XmlNode (Sv.TlsM h g) ()-checkName t gn = (await >>=) . maybe (return ()) $ \n -> do-	ok <- maybe (return True) (lift . svCheckName t) $ gn n-	unless ok $ error "checkName: bad client name"-	yield n-	checkName t gn--svCheckName :: HandleLike h => Sv.TlsHandle h g -> String -> Sv.TlsM h g Bool-svCheckName t n = do-	ns <- Sv.getNames t-	return $ n `elem` ns--setClient :: (MonadBase IO (HandleMonad h)) =>-	TVar (Maybe h) -> TVar (Maybe (String, Int, FilePath)) ->-	(XmlNode -> Maybe (HandleMonad h h, String, Int, FilePath)) ->-	Pipe XmlNode XmlNode (Sv.TlsM h g) ()-setClient vch vhi gc = (await >>=) . maybe (return ()) $ \n -> do-	yield n-	case gc n of-		Just (gh, hn, pn, pt) -> do-			h <- lift . lift $ lift gh-			lift . liftBase . atomically . writeTVar vch $ Just h-			lift . liftBase . atomically . writeTVar vhi-				$ Just (hn, pn, pt)-		_ -> return ()-	setClient vch vhi gc+import Network.XmlPush.HttpPush.Tls.Body

@@ -0,0 +1,279 @@+{-# LANGUAGE OverloadedStrings, TupleSections, ScopedTypeVariables,+	TypeFamilies, FlexibleContexts,+	PackageImports #-}++module Network.XmlPush.HttpPush.Tls.Body (+	HttpPushTls, HttpPushTlsArgs(..), HttpPushArgs(..),+	TlsArgsCl, tlsArgsCl, TlsArgsSv, tlsArgsSv,+	makeHttpPush, makeHttpPushTls,+	HttpPushTlsTest(..), HttpPushTlsTestArgs(..),+	) where++import Prelude hiding (filter)++import Control.Applicative+import Control.Monad+import "monads-tf" Control.Monad.Trans+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 Data.X509 hiding (getCertificate)+import Data.X509.CertificateStore+import Text.XML.Pipe+import Network.TigHTTP.Server+import Network.PeyoTLS.ReadFile+import Network.PeyoTLS.Server (getCertificate)+import Network.PeyoTLS.Client (ValidateHandle)+import "crypto-random" Crypto.Random++import qualified Data.ByteString.Lazy as LBS+import qualified Network.PeyoTLS.Client as Cl+import qualified Network.PeyoTLS.Server as Sv++import Network.XmlPush+import Network.XmlPush.HttpPush.Common+import Network.XmlPush.Tls.Client as TC+import Network.XmlPush.Tls.Server as TS++type TlsArgsCl = TC.TlsArgs++tlsArgsCl :: String -> Bool ->+	(XmlNode -> Maybe (SignedCertificate -> Bool)) ->+	[Cl.CipherSuite] -> CertificateStore ->+	[(CertSecretKey, CertificateChain)] -> TlsArgsCl+tlsArgsCl = TC.TlsArgs++type TlsArgsSv = TS.TlsArgs++tlsArgsSv :: (XmlNode -> Maybe String) ->+	(XmlNode -> Maybe (SignedCertificate -> Bool)) -> [Cl.CipherSuite] ->+	Maybe CertificateStore -> [(CertSecretKey, CertificateChain)] -> TlsArgsSv+tlsArgsSv = TS.TlsArgs++data HttpPushTls h = HttpPushTls {+	needReply :: TVar Bool,+	clientReadChan :: TChan (XmlNode, Bool),+	clientWriteChan :: TChan (Maybe XmlNode),+	serverReadChan :: TChan (XmlNode, Bool),+	serverWriteChan :: TChan (Maybe XmlNode) }++data HttpPushTlsArgs h = HttpPushTlsArgs (HttpPushArgs h) TC.TlsArgs TS.TlsArgs++instance XmlPusher HttpPushTls where+	type NumOfHandle HttpPushTls = Two+	type PusherArgs HttpPushTls = HttpPushTlsArgs+	generate (Two ch sh) = makeHttpPushTls [] ch sh+	readFrom hp = fromTChans [clientReadChan hp, serverReadChan hp] =$=+		setNeedReply (needReply hp)+	writeTo hp = (convert (((), ) . Just) =$=) . toTChansM $ do+		nr <- liftBase . atomically . readTVar $ needReply hp+		liftBase . atomically $ writeTVar (needReply hp) False+		return [+			(const nr, serverWriteChan hp),+			(const True, clientWriteChan hp) ]++data HttpPushTlsTest h = HttpPushTlsTest (HttpPushTls h)+data HttpPushTlsTestArgs h = HttpPushTlsTestArgs (HttpPushTlsArgs h) [XmlNode]++instance XmlPusher HttpPushTlsTest where+	type NumOfHandle HttpPushTlsTest = Two+	type PusherArgs HttpPushTlsTest = HttpPushTlsTestArgs+	generate (Two ch sh) (HttpPushTlsTestArgs a p) =+		HttpPushTlsTest <$> makeHttpPushTls p ch sh a+	readFrom (HttpPushTlsTest hp) = readFrom hp+	writeTo (HttpPushTlsTest hp) = writeTo hp++makeHttpPushTls :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) =>+	[XmlNode] ->+	Maybe h -> Maybe h ->+	HttpPushTlsArgs h -> HandleMonad h (HttpPushTls h)+makeHttpPushTls pre mch msh (HttpPushTlsArgs (HttpPushArgs gc gs hi gp wr)+	(TC.TlsArgs dn cdn cc' cs ca kcs) (TS.TlsArgs gn cc cs' mca' kcs')) = do+	vch <- liftBase . atomically $ newTVar mch+	vsh <- liftBase . atomically $ newTVar msh+	case hi of+		Just (hn, _, _) -> when (dn /= hn) $+			error "makeHttpPushTls: conflicted domain name"+		_ -> return ()+	v <- liftBase . atomically $ newTVar False+	vhi <- liftBase . atomically $ newTVar hi+	(ci, co) <- clientC vch vhi cdn cc' gp cs ca kcs+	(si, so) <- talk pre wr vsh gn cc cs' mca' kcs' vch vhi gc gs+	return $ HttpPushTls v ci co si so++makeHttpPush :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h), CPRG g) =>+	[XmlNode] -> Maybe h -> Sv.TlsHandle h g ->+	HttpPushTlsArgs h -> Sv.TlsM h g (HttpPushTls h)+makeHttpPush pre mch t (HttpPushTlsArgs (HttpPushArgs gc gs hi gp wr)+	(TC.TlsArgs dn cdn cc' cs ca kcs) (TS.TlsArgs gn cc cs' mca' kcs')) = do+	vch <- lift . lift . liftBase . atomically $ newTVar mch+	vsh <- lift . lift . liftBase . atomically $ newTVar undefined+	hlDebug t "critical" "in makeHttpPush\n"+	case hi of+		Just (hn, _, _) -> when (dn /= hn) $+			error "makeHttpPushTls: conflicted domain name"+		_ -> return ()+	v <- lift . lift . liftBase . atomically $ newTVar False+	vhi <- lift . lift . liftBase . atomically $ newTVar hi+	(ci, co) <- lift . lift $ clientC vch vhi cdn cc' gp cs ca kcs+	(si, so) <- do+		inc <- lift . lift . liftBase $ atomically newTChan+		otc <- lift . lift . liftBase $ atomically newTChan+		hlDebug t "critical" "before talkT\n"+		void . liftBaseDiscard forkIO $+			talkT t inc otc pre wr gn cc vch vhi gc+		hlDebug t "critical" "after talkT\n"+		return (inc, otc)+	return $ HttpPushTls v ci co si so++clientC :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) =>+	TVar (Maybe h) -> TVar (Maybe (String, Int, FilePath)) -> Bool ->+	(XmlNode -> Maybe (SignedCertificate -> Bool)) ->+	(XmlNode -> FilePath) ->+	[Cl.CipherSuite] -> CertificateStore ->+	[(CertSecretKey, CertificateChain)] ->+	HandleMonad h (TChan (XmlNode, Bool), TChan (Maybe XmlNode))+clientC vh vhi cdn cc gp cs ca kcs = do+	inc <- liftBase $ atomically newTChan+	otc <- liftBase $ atomically newTChan+	(g :: SystemRNG) <- liftBase $ cprgCreate <$> createEntropyPool+	void . liftBaseDiscard forkIO $ do+		h <- liftBase . atomically $ do+			mh <- readTVar vh+			case mh of+				Just h -> return h+				_ -> retry+		(hn, pn, pt) <- liftBase . atomically $ do+			mhi <- readTVar vhi+			case mhi of+				Just hi -> return hi+				_ -> retry+		(`Cl.run` g) $ do+			t <- (if cdn then Cl.open' h hn else Cl.open h) cs kcs ca+			runPipe_ $ fromTChan otc+				=$= filter isJust+				=$= convert fromJust+				=$= clientLoop t hn pn pt gp (checkCertCl t cc)+				=$= convert (, False)+				=$= toTChan inc+	return (inc, otc)++talk :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) =>+	[XmlNode] ->+	(XmlNode -> Bool) -> (TVar (Maybe h)) -> (XmlNode -> Maybe String) ->+	(XmlNode -> Maybe (SignedCertificate -> Bool)) -> [Sv.CipherSuite] ->+	Maybe CertificateStore -> [(CertSecretKey, CertificateChain)] ->+	TVar (Maybe h) -> TVar (Maybe (String, Int, FilePath)) ->+	(XmlNode -> Maybe (HandleMonad h h, String, Int, FilePath)) ->+	Maybe (HandleMonad h h) ->+	HandleMonad h (TChan (XmlNode, Bool), TChan (Maybe XmlNode))+talk pre wr vh gn cc cs mca kcs vch vhi gc mgs = do+	g <- liftBase (cprgCreate <$> createEntropyPool :: IO SystemRNG)+	inc <- liftBase $ atomically newTChan+	otc <- liftBase $ atomically newTChan+	void . liftBaseDiscard forkIO $ do+		flip (maybe (return ())) mgs $ \gs -> do+			h <- gs+			liftBase . atomically $ writeTVar vh (Just h)+		h <- liftBase . atomically $ do+			mh <- readTVar vh+			case mh of+				Just h -> return h+				_ -> retry+		(`Sv.run` g) $ do+			t <- Sv.open h cs kcs mca+			talkT t inc otc pre wr gn cc vch vhi gc+	return (inc, otc)++talkT :: (ValidateHandle h, MonadBase IO (HandleMonad h), CPRG g) =>+	Sv.TlsHandle h g -> TChan (XmlNode, Bool) -> TChan (Maybe XmlNode) ->+	[XmlNode] -> (XmlNode -> Bool) -> (XmlNode -> Maybe String) ->+	(XmlNode -> Maybe (SignedCertificate -> Bool)) -> TVar (Maybe h) ->+	TVar (Maybe (String, Int, FilePath)) ->+	(XmlNode -> Maybe (HandleMonad h h, String, Int, FilePath)) ->+	Sv.TlsM h g ()+talkT t inc otc pre wr gn cc vch vhi gc = do+			runPipe_ . writeToChan t inc otc pre $+				setClient vch vhi gc =$= checkReply wr otc+			runPipe_ . forever $ do+				req <- lift $ getRequest t+				requestBody req+					=$= xmlEvent+					=$= convert fromJust+					=$= xmlNode []+					=$= setClient vch vhi gc+					=$= checkCert t cc+					=$= checkName t gn+					=$= checkReply wr otc+					=$= toTChan inc+				fromTChan otc =$= await >>= maybe (return ()) (\mn ->+					lift . putResponse t . responseP $ case mn of+						Just n -> LBS.fromChunks [xmlString [n]]+						_ -> "")++writeToChan :: (HandleLike h, MonadBase IO (HandleMonad h)) =>+	h -> TChan a -> TChan (Maybe XmlNode) -> [XmlNode] ->+	Pipe XmlNode a (HandleMonad h) () ->+	Pipe () () (HandleMonad h) ()+writeToChan _ _ _ [] _ = return ()+writeToChan h inc otc pre pp = do+	mapM yield pre =$= pp =$= toTChan inc+	fromTChan otc =$= await >>= maybe (return ()) (\mn ->+		lift . putResponse h . responseP $ case mn of+			Just n -> LBS.fromChunks [xmlString [n]]+			_ -> "")++checkCert :: HandleLike h => Sv.TlsHandle h g ->+	(XmlNode -> Maybe (SignedCertificate -> Bool)) ->+	Pipe XmlNode XmlNode (Sv.TlsM h g) ()+checkCert t cc = (await >>=) . maybe (return ()) $ \n -> do+	let ck = maybe (const True) id $ cc n+	c <- lift $ getCertificate t+	unless (ck c) $ error "checkCert: bad certificate"+	yield n+	checkCert t cc++checkCertCl :: (ValidateHandle h, CPRG g) => Cl.TlsHandle h g ->+	(XmlNode -> Maybe (SignedCertificate -> Bool)) ->+	Pipe XmlNode XmlNode (Cl.TlsM h g) ()+checkCertCl t cc = (await >>=) . maybe (return ()) $ \n -> do+	lift $ hlDebug t "medium" "begin checkCertCl"+	let ck = maybe (const True) id $ cc n+	c <- lift $ Cl.getCertificate t+	unless (ck c) $ error "checkCert: bad certificate"+	yield n+	checkCertCl t cc++checkName :: HandleLike h => Sv.TlsHandle h g -> (XmlNode -> Maybe String) ->+	Pipe XmlNode XmlNode (Sv.TlsM h g) ()+checkName t gn = (await >>=) . maybe (return ()) $ \n -> do+	ok <- maybe (return True) (lift . svCheckName t) $ gn n+	unless ok $ error "checkName: bad client name"+	yield n+	checkName t gn++svCheckName :: HandleLike h => Sv.TlsHandle h g -> String -> Sv.TlsM h g Bool+svCheckName t n = do+	ns <- Sv.getNames t+	return $ n `elem` ns++setClient :: (MonadBase IO (HandleMonad h)) =>+	TVar (Maybe h) -> TVar (Maybe (String, Int, FilePath)) ->+	(XmlNode -> Maybe (HandleMonad h h, String, Int, FilePath)) ->+	Pipe XmlNode XmlNode (Sv.TlsM h g) ()+setClient vch vhi gc = (await >>=) . maybe (return ()) $ \n -> do+	yield n+	case gc n of+		Just (gh, hn, pn, pt) -> do+			h <- lift . lift $ lift gh+			lift . liftBase . atomically . writeTVar vch $ Just h+			lift . liftBase . atomically . writeTVar vhi+				$ Just (hn, pn, pt)+		_ -> return ()+	setClient vch vhi gc

@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		xml-push-version:	0.0.0.14+version:	0.0.0.15 stability:	Experimenmtal author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -100,7 +100,7 @@ source-repository	this     type:	git     location:	git://github.com/YoshikuniJujo/xml-push.git-    tag:	xml-push-0.0.0.14+    tag:	xml-push-0.0.0.15  library     hs-source-dirs:	src@@ -112,6 +112,7 @@         Network.XmlPush.HttpPull.Tls.Client, Network.XmlPush.HttpPull.Tls.Server         Network.XmlPush.HttpPush, Network.XmlPush.HttpPush.Tls         Network.XmlPush.Http.Server+        Network.XmlPush.Http.Tls.Server     other-modules:         Network.XmlPush.Tls.Client         Network.XmlPush.Tls.Server@@ -120,8 +121,10 @@         Network.XmlPush.HttpPull.Client.Common         Network.XmlPush.HttpPull.Server.Common         Network.XmlPush.HttpPull.Server.Body+        Network.XmlPush.HttpPull.Tls.Server.Body         Network.XmlPush.HttpPush.Common         Network.XmlPush.HttpPush.Body+        Network.XmlPush.HttpPush.Tls.Body     build-depends:         base == 4.*, peyotls == 0.1.*, simple-pipe == 0.0.*, xml-pipe == 0.0.*,         handle-like == 0.1.*, monad-control == 0.3.*, transformers-base == 0.4.*,