diff --git a/examples/httpPushTlsE.hs b/examples/httpPushTlsE.hs --- a/examples/httpPushTlsE.hs +++ b/examples/httpPushTlsE.hs @@ -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')]) diff --git a/examples/httpPushTlsT.hs b/examples/httpPushTlsT.hs --- a/examples/httpPushTlsT.hs +++ b/examples/httpPushTlsT.hs @@ -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"] diff --git a/src/Network/XmlPush/Http/Tls/Server.hs b/src/Network/XmlPush/Http/Tls/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/XmlPush/Http/Tls/Server.hs @@ -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 diff --git a/src/Network/XmlPush/HttpPull/Server/Body.hs b/src/Network/XmlPush/HttpPull/Server/Body.hs --- a/src/Network/XmlPush/HttpPull/Server/Body.hs +++ b/src/Network/XmlPush/HttpPull/Server/Body.hs @@ -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 diff --git a/src/Network/XmlPush/HttpPull/Tls/Server.hs b/src/Network/XmlPush/HttpPull/Tls/Server.hs --- a/src/Network/XmlPush/HttpPull/Tls/Server.hs +++ b/src/Network/XmlPush/HttpPull/Tls/Server.hs @@ -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 diff --git a/src/Network/XmlPush/HttpPull/Tls/Server/Body.hs b/src/Network/XmlPush/HttpPull/Tls/Server/Body.hs new file mode 100644 --- /dev/null +++ b/src/Network/XmlPush/HttpPull/Tls/Server/Body.hs @@ -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 diff --git a/src/Network/XmlPush/HttpPush/Tls.hs b/src/Network/XmlPush/HttpPush/Tls.hs --- a/src/Network/XmlPush/HttpPush/Tls.hs +++ b/src/Network/XmlPush/HttpPush/Tls.hs @@ -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 diff --git a/src/Network/XmlPush/HttpPush/Tls/Body.hs b/src/Network/XmlPush/HttpPush/Tls/Body.hs new file mode 100644 --- /dev/null +++ b/src/Network/XmlPush/HttpPush/Tls/Body.hs @@ -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 diff --git a/xml-push.cabal b/xml-push.cabal --- a/xml-push.cabal +++ b/xml-push.cabal @@ -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 maintainer: Yoshikuni Jujo @@ -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.*,