diff --git a/peyotls.cabal b/peyotls.cabal --- a/peyotls.cabal +++ b/peyotls.cabal @@ -2,7 +2,7 @@ cabal-version: >= 1.8 name: peyotls -version: 0.1.3.0 +version: 0.1.4.0 stability: Experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo @@ -281,13 +281,16 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/peyotls.git - tag: peyotls-0.1.3.0 + tag: peyotls-0.1.4.0 library hs-source-dirs: src exposed-modules: - Network.PeyoTLS.Client, Network.PeyoTLS.Server, Network.PeyoTLS.ReadFile + Network.PeyoTLS.Client, Network.PeyoTLS.Server, + Network.PeyoTLS.TChan.Client, Network.PeyoTLS.TChan.Server, + Network.PeyoTLS.ReadFile other-modules: + Network.PeyoTLS.Client.Body, Network.PeyoTLS.Server.Body, Network.PeyoTLS.Base, Network.PeyoTLS.Codec, Network.PeyoTLS.Codec.Hello, Network.PeyoTLS.Codec.Extension, @@ -306,7 +309,8 @@ cryptohash == 0.11.*, crypto-pubkey == 0.2.*, crypto-pubkey-types == 0.4.*, cipher-aes == 0.2.*, - bytable == 0.1.*, handle-like == 0.1.* + bytable == 0.1.*, handle-like == 0.1.*, + stm == 2.4.*, transformers-base == 0.4.*, monad-control == 0.3.* ghc-options: -Wall extensions: PatternGuards, DoAndIfThenElse diff --git a/src/Network/PeyoTLS/Base.hs b/src/Network/PeyoTLS/Base.hs --- a/src/Network/PeyoTLS/Base.hs +++ b/src/Network/PeyoTLS/Base.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, PackageImports #-} module Network.PeyoTLS.Base ( - PeyotlsM, TlsM, run, SettingsS, + TlsState(..), State1(..), wFlush, Keys(..), + PeyotlsM, TlsM, run, run', SettingsS, adGet, adGetLine, adGetContent, adPut, adDebug, adClose, HandshakeM, execHandshakeM, rerunHandshakeM, getSettingsC, setSettingsC, getSettingsS, setSettingsS, @@ -69,7 +70,8 @@ DigitSigned(..), CCSpec(..), Finished(..) ) import qualified Network.PeyoTLS.Run as RUN (finishedHash, debug) import Network.PeyoTLS.Run ( - TlsM, run, HandleBase, getNames, + TlsState(..), State1(..), wFlush, Keys(..), + TlsM, run, run', HandleBase, getNames, chGet, hsPut, updateHash, ccsPut, adGet, adGetLine, adGetContent, adPut, adDebug, adClose, HandshakeM, execHandshakeM, rerunHandshakeM, diff --git a/src/Network/PeyoTLS/Client.hs b/src/Network/PeyoTLS/Client.hs --- a/src/Network/PeyoTLS/Client.hs +++ b/src/Network/PeyoTLS/Client.hs @@ -1,6 +1,6 @@ {-| -Module : Network.PeyoTLS.Server +Module : Network.PeyoTLS.Client Copyright : (c) Yoshikuni Jujo, 2014 License : BSD3 Maintainer : PAF01143@nifty.ne.jp @@ -8,8 +8,6 @@ -} -{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-} - module Network.PeyoTLS.Client ( -- * Basic PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, Alert(..), @@ -21,292 +19,4 @@ -- * Others ValidateHandle(..), CertSecretKey(..) ) where -import Control.Applicative ((<$>), (<*>)) -import Control.Monad (when, unless, liftM, ap) -import "monads-tf" Control.Monad.Error.Class (strMsg) -import Data.Maybe (fromMaybe) -import Data.List (find, intersect) -import Data.Function (on) -import Data.HandleLike (HandleLike(..)) -import System.IO (Handle) -import "crypto-random" Crypto.Random (CPRG, SystemRNG, cprgGenerate) - -import qualified Data.ByteString as BS -import qualified Data.X509 as X509 -import qualified Data.X509.CertificateStore as X509 -import qualified Codec.Bytable.BigEndian as B -import qualified Crypto.PubKey.DH as DH -import qualified Crypto.Types.PubKey.ECC as ECC - -import qualified Crypto.PubKey.RSA as RSA -import qualified Crypto.PubKey.RSA.PKCS15 as RSA -import qualified "monads-tf" Control.Monad.Error as E - -import qualified Network.PeyoTLS.Base as BASE (getNames) -import Network.PeyoTLS.Base ( debug, - PeyotlsM, TlsM, run, - getSettingsC, setSettingsC, - adGet, adGetLine, adGetContent, adPut, adDebug, adClose, - HandshakeM, execHandshakeM, rerunHandshakeM, - withRandom, flushAd, - Alert(..), AlertLevel(..), AlertDesc(..), throw, - ValidateHandle(..), handshakeValidate, validateAlert, - HandleBase, CertSecretKey(..), - readHandshake, writeHandshake, CCSpec(..), - ClHello(..), SvHello(..), SssnId(..), isRnInfo, - CipherSuite(..), KeyEx(..), BulkEnc(..), - CmpMtd(..), HashAlg(..), SignAlg(..), - setCipherSuite, - checkSvRenego, makeClRenego, - SvKeyExEcdhe(..), SvKeyExDhe(..), SvSignPublicKey(..), - CertReq(..), ClCertType(..), - SHDone(..), - ClKeyEx(..), Epms(..), makeKeys, - DigitSigned(..), ClSignSecretKey(..), handshakeHash, - Side(..), RW(..), finishedHash, flushCipherSuite, - DhParam(..), ecdsaPubKey ) - -type PeyotlsHandle = TlsHandle Handle SystemRNG - -newtype TlsHandle h g = TlsHandleC { tlsHandleC :: HandleBase h g } deriving Show - -instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandle h g) where - type HandleMonad (TlsHandle h g) = TlsM h g - type DebugLevel (TlsHandle h g) = DebugLevel h - hlPut = adPut . tlsHandleC - hlGet = adGet rehandshake . tlsHandleC - hlGetLine = adGetLine rehandshake . tlsHandleC - hlGetContent = adGetContent rehandshake . tlsHandleC - hlDebug = adDebug . tlsHandleC - hlClose = adClose . tlsHandleC - -modNm :: String -modNm = "Network.PeyoTLS.Client" - -getNames :: HandleLike h => TlsHandle h g -> TlsM h g [String] -getNames = BASE.getNames . tlsHandleC - -checkName :: HandleLike h => TlsHandle h g -> String -> TlsM h g Bool -checkName t n = flip toCheckName n `liftM` getNames t - -toCheckName :: [String] -> String -> Bool -toCheckName s0s s = any (`toCheckName1` s) s0s - -toCheckName1 :: String -> String -> Bool -toCheckName1 = on checkSepNames $ sepBy '.' - -sepBy :: Eq a => a ->[a] -> [[a]] -sepBy x0 xs - | (t, _ : d) <- span (/= x0) xs = t : sepBy x0 d - | otherwise = [xs] - -checkSepNames :: [String] -> [String] -> Bool -checkSepNames [] [] = True -checkSepNames _ [] = False -checkSepNames [] _ = False -checkSepNames ("*" : ns0) (_ : ns) = checkSepNames ns0 ns -checkSepNames (n0 : ns0) (n : ns) = n0 == n && checkSepNames ns0 ns - --- | Don't forget check server name by checkName. - -open :: (ValidateHandle h, CPRG g) => h -> [CipherSuite] -> - [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore -> - TlsM h g (TlsHandle h g) -open h cscl crts ca = (TlsHandleC `liftM`) . execHandshakeM h $ do - setSettingsC (cscl, crts, ca) - handshake crts ca =<< clientHello cscl - --- | This function open and check server name. --- Use this so as not to forget to check server name. - -open' :: (ValidateHandle h, CPRG g) => h -> String -> [CipherSuite] -> - [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore -> - TlsM h g (TlsHandle h g) -open' h n cscl crts ca = do - t <- open h cscl crts ca - c <- checkName t n - unless c . E.throwError $ strMsg "certificate name mismatch" - return t - -renegotiate :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g () -renegotiate (TlsHandleC t) = rerunHandshakeM t $ do - (cscl, crts, ca) <- getSettingsC - clientHello cscl >>= \cr -> flushAd >>= flip when (handshake crts ca cr) - -setCipherSuites :: (ValidateHandle h, CPRG g) => TlsHandle h g -> - [CipherSuite] -> TlsM h g () -setCipherSuites (TlsHandleC t) cscl = rerunHandshakeM t $ do - (_, crts, cs) <- getSettingsC - setSettingsC (cscl, crts, cs) - -setKeyCerts :: (ValidateHandle h, CPRG g) => TlsHandle h g -> - [(CertSecretKey, X509.CertificateChain)] -> TlsM h g () -setKeyCerts (TlsHandleC t) crts = rerunHandshakeM t $ do - (cscl, _, cs) <- getSettingsC - setSettingsC (cscl, crts, cs) - -setCertificateStore :: (ValidateHandle h, CPRG g) => TlsHandle h g -> - X509.CertificateStore -> TlsM h g () -setCertificateStore (TlsHandleC t) cs = rerunHandshakeM t $ do - (cscl, crts, _) <- getSettingsC - setSettingsC (cscl, crts, cs) - -rehandshake :: (ValidateHandle h, CPRG g) => HandleBase h g -> TlsM h g () -rehandshake t = rerunHandshakeM t $ do - (cscl, crts, ca) <- getSettingsC - handshake crts ca =<< clientHello cscl - -clientHello :: (HandleLike h, CPRG g) => - [CipherSuite] -> HandshakeM h g BS.ByteString -clientHello cscl = do - cr <- withRandom $ cprgGenerate 32 - ((>>) <$> writeHandshake <*> debug "low") - . ClHello (3, 3) cr (SssnId "") cscl [CmpMtdNull] - . Just . (: []) =<< makeClRenego - return cr - -handshake :: (ValidateHandle h, CPRG g) => - [(CertSecretKey, X509.CertificateChain)] -> - X509.CertificateStore -> BS.ByteString -> HandshakeM h g () -handshake crts ca cr = do - (sr, ke) <- serverHello - ($ ca) . ($ crts) . ($ (cr, sr)) $ case ke of - RSA -> rsaHandshake - DHE_RSA -> dheHandshake (undefined :: DH.Params) - ECDHE_RSA -> dheHandshake (undefined :: ECC.Curve) - ECDHE_ECDSA -> dheHandshake (undefined :: ECC.Curve) - _ -> \_ _ _ -> throw ALFtl ADHsFailure $ - modNm ++ ".handshake: not implemented" - -serverHello :: (HandleLike h, CPRG g) => HandshakeM h g (BS.ByteString, KeyEx) -serverHello = do - SvHello v sr _sid cs@(CipherSuite ke _) cm e <- readHandshake - case v of - (3, 3) -> return () - _ -> throw ALFtl ADProtoVer $ - modNm ++ ".serverHello: only TLS 1.2" - case cm of - CmpMtdNull -> return () - _ -> throw ALFtl ADHsFailure $ - modNm ++ ".serverHello: only compression method null" - case find isRnInfo $ fromMaybe [] e of - Just ri -> checkSvRenego ri - _ -> throw ALFtl ADInsSec $ modNm ++ ".serverHello: no sec renego" - setCipherSuite cs - return (sr, ke) - -rsaHandshake :: (ValidateHandle h, CPRG g) => (BS.ByteString, BS.ByteString) -> - [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore -> - HandshakeM h g () -rsaHandshake rs crts ca = do - cc@(X509.CertificateChain (c : _)) <- readHandshake - vr <- handshakeValidate ca cc - unless (null vr) . throw ALFtl (validateAlert vr) $ - modNm ++ ".rsaHandshake: validate failure" - pk <- case X509.certPubKey . X509.signedObject $ X509.getSigned c of - X509.PubKeyRSA k -> return k - _ -> throw ALFtl ADIllParam $ modNm ++ ".rsaHandshake: RSA pk" - crt <- clientCertificate crts - pms <- ("\x03\x03" `BS.append`) `liftM` withRandom (cprgGenerate 46) - makeKeys Client rs pms - writeHandshake . Epms =<< encryptRsa pk pms - finishHandshake crt - -encryptRsa :: (HandleLike h, CPRG g) => - RSA.PublicKey -> BS.ByteString -> HandshakeM h g BS.ByteString -encryptRsa pk p = either (E.throwError . strMsg . show) return =<< - withRandom (\g -> RSA.encrypt g pk p) - -dheHandshake :: (ValidateHandle h, CPRG g, - KeyExchangeClass ke, Show (Secret ke), Show (Public ke)) => - ke -> (BS.ByteString, BS.ByteString) -> - [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore -> - HandshakeM h g () -dheHandshake t rs crts ca = do - cc@(X509.CertificateChain (c : _)) <- readHandshake - vr <- handshakeValidate ca cc - unless (null vr) . throw ALFtl (validateAlert vr) $ - modNm ++ ".succeed: validate failure" - case X509.certPubKey . X509.signedObject $ X509.getSigned c of - X509.PubKeyRSA pk -> succeed t pk rs crts - X509.PubKeyECDSA cv pt -> succeed t (ecdsaPubKey cv pt) rs crts - _ -> throw ALFtl ADHsFailure $ - modNm ++ ".dheHandshake: not implemented" - -succeed :: (ValidateHandle h, CPRG g, SvSignPublicKey pk, - KeyExchangeClass ke, Show (Secret ke), Show (Public ke)) => - ke -> pk -> (BS.ByteString, BS.ByteString) -> - [(CertSecretKey, X509.CertificateChain)] -> HandshakeM h g () -succeed t pk rs@(cr, sr) crts = do - (ps, pv, ha, sa, sn) <- serverKeyExchange - let _ = ps `asTypeOf` t - unless (sa == sspAlgorithm pk) . throw ALFtl ADHsFailure $ - pre ++ "sign algorithm unmatch" - unless (ssVerify ha pk sn $ BS.concat [cr, sr, B.encode ps, B.encode pv]) . - throw ALFtl ADDecryptErr $ pre ++ "verify failure" - crt <- clientCertificate crts - sv <- withRandom $ generateSecret ps - makeKeys Client rs $ calculateShared ps sv pv - writeHandshake . ClKeyEx . B.encode $ calculatePublic ps sv - finishHandshake crt - where pre = modNm ++ ".succeed: " - -class (DhParam bs, B.Bytable bs, B.Bytable (Public bs)) => KeyExchangeClass bs where - serverKeyExchange :: (HandleLike h, CPRG g) => HandshakeM h g - (bs, Public bs, HashAlg, SignAlg, BS.ByteString) - -instance KeyExchangeClass ECC.Curve where - serverKeyExchange = do - SvKeyExEcdhe cv pnt ha sa sn <- readHandshake - return (cv, pnt, ha, sa, sn) - -instance KeyExchangeClass DH.Params where - serverKeyExchange = do - SvKeyExDhe ps pv ha sa sn <- readHandshake - return (ps, pv, ha, sa, sn) - -clientCertificate :: (HandleLike h, CPRG g) => - [(CertSecretKey, X509.CertificateChain)] -> - HandshakeM h g (Maybe (CertSecretKey, X509.CertificateChain)) -clientCertificate crts = do - h <- readHandshake - (\p -> either p (\SHDone -> return Nothing) h) $ \(CertReq cct a dn) -> do - SHDone <- readHandshake - case find (isMatchedCert cct a dn) crts of - Just c -> - (>>) <$> writeHandshake . snd <*> return . Just $ c - _ -> throw ALFtl ADUnkCa $ modNm ++ - ".clientCertificate: no certificate" - -isMatchedCert :: [ClCertType] -> [(HashAlg, SignAlg)] -> - [X509.DistinguishedName] -> (CertSecretKey, X509.CertificateChain) -> Bool -isMatchedCert ct hsa dn = (&&) <$> csk . fst <*> ccrt . snd - where - obj = X509.signedObject . X509.getSigned - rsa = CTRsaSign `elem` ct || Rsa `elem` map snd hsa - ecdsa = CTEcdsaSign `elem` ct || Ecdsa `elem` map snd hsa - csk (RsaKey _) = rsa; csk (EcdsaKey _) = ecdsa - ccrt (X509.CertificateChain cs@(c : _)) = - cpk (X509.certPubKey $ obj c) && - not (null . intersect dn $ map (X509.certIssuerDN . obj) cs) - ccrt _ = error $ modNm ++ ".isMatchedCert: empty certificate chain" - cpk X509.PubKeyRSA{} = rsa; cpk X509.PubKeyECDSA{} = ecdsa; cpk _ = False - -finishHandshake :: (HandleLike h, CPRG g) => - Maybe (CertSecretKey, X509.CertificateChain) -> HandshakeM h g () -finishHandshake crt = do - hs <- handshakeHash - case fst <$> crt of - Just (RsaKey sk) -> writeHandshake . - DigitSigned (cssAlgorithm sk) $ csSign sk hs - Just (EcdsaKey sk) -> writeHandshake . - DigitSigned (cssAlgorithm sk) $ csSign sk hs - _ -> return () - writeHandshake CCSpec - flushCipherSuite Write - writeHandshake =<< finishedHash Client - CCSpec <- readHandshake - flushCipherSuite Read - (==) `liftM` finishedHash Server `ap` readHandshake >>= flip unless - (throw ALFtl ADDecryptErr $ - modNm ++ ".finishHandshake: finished hash failure") +import Network.PeyoTLS.Client.Body diff --git a/src/Network/PeyoTLS/Client/Body.hs b/src/Network/PeyoTLS/Client/Body.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Client/Body.hs @@ -0,0 +1,318 @@ +{-| + +Module : Network.PeyoTLS.Server +Copyright : (c) Yoshikuni Jujo, 2014 +License : BSD3 +Maintainer : PAF01143@nifty.ne.jp +Stability : Experimental + +-} + +{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-} + +module Network.PeyoTLS.Client.Body ( + -- * Basic + TlsState(..), State1(..), Keys(..), toCheckName, + PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, Alert(..), + run, run', open, open', getNames, checkName, + -- * Renegotiation + renegotiate, setCipherSuites, setKeyCerts, setCertificateStore, + -- * Cipher Suite + CipherSuite(..), KeyEx(..), BulkEnc(..), + -- * Others + ValidateHandle(..), CertSecretKey(..) ) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (when, unless, liftM, ap) +import "monads-tf" Control.Monad.Error.Class (strMsg) +import Data.Maybe (fromMaybe) +import Data.List (find, intersect) +import Data.Function (on) +import Data.HandleLike (HandleLike(..)) +import System.IO (Handle) +import "crypto-random" Crypto.Random (CPRG, SystemRNG, cprgGenerate) + +import qualified Data.ByteString as BS +import qualified Data.X509 as X509 +import qualified Data.X509.CertificateStore as X509 +import qualified Codec.Bytable.BigEndian as B +import qualified Crypto.PubKey.DH as DH +import qualified Crypto.Types.PubKey.ECC as ECC + +import qualified Crypto.PubKey.RSA as RSA +import qualified Crypto.PubKey.RSA.PKCS15 as RSA +import qualified "monads-tf" Control.Monad.Error as E + +import qualified Network.PeyoTLS.Base as BASE (getNames) +import Network.PeyoTLS.Base ( debug, wFlush, + TlsState(..), State1(..), Keys(..), + PeyotlsM, TlsM, run, run', + getSettingsC, setSettingsC, + adGet, adGetLine, adGetContent, adPut, adDebug, adClose, + HandshakeM, execHandshakeM, rerunHandshakeM, + withRandom, flushAd, + Alert(..), AlertLevel(..), AlertDesc(..), throw, + ValidateHandle(..), handshakeValidate, validateAlert, + HandleBase, CertSecretKey(..), + readHandshake, writeHandshake, CCSpec(..), + ClHello(..), SvHello(..), SssnId(..), isRnInfo, + CipherSuite(..), KeyEx(..), BulkEnc(..), + CmpMtd(..), HashAlg(..), SignAlg(..), + setCipherSuite, + checkSvRenego, makeClRenego, + SvKeyExEcdhe(..), SvKeyExDhe(..), SvSignPublicKey(..), + CertReq(..), ClCertType(..), + SHDone(..), + ClKeyEx(..), Epms(..), makeKeys, + DigitSigned(..), ClSignSecretKey(..), handshakeHash, + Side(..), RW(..), finishedHash, flushCipherSuite, + DhParam(..), ecdsaPubKey ) + +type PeyotlsHandle = TlsHandle Handle SystemRNG + +newtype TlsHandle h g = TlsHandleC { tlsHandleC :: HandleBase h g } deriving Show + +instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandle h g) where + type HandleMonad (TlsHandle h g) = TlsM h g + type DebugLevel (TlsHandle h g) = DebugLevel h + hlPut = adPut . tlsHandleC + hlGet = adGet rehandshake . tlsHandleC + hlGetLine = adGetLine rehandshake . tlsHandleC + hlGetContent = adGetContent rehandshake . tlsHandleC + hlDebug = adDebug . tlsHandleC + hlClose = adClose . tlsHandleC + hlFlush = writeFlush + +writeFlush :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g () +writeFlush = wFlush . tlsHandleC + +modNm :: String +modNm = "Network.PeyoTLS.Client" + +getNames :: HandleLike h => TlsHandle h g -> TlsM h g [String] +getNames = BASE.getNames . tlsHandleC + +checkName :: HandleLike h => TlsHandle h g -> String -> TlsM h g Bool +checkName t n = flip toCheckName n `liftM` getNames t + +toCheckName :: [String] -> String -> Bool +toCheckName s0s s = any (`toCheckName1` s) s0s + +toCheckName1 :: String -> String -> Bool +toCheckName1 = on checkSepNames $ sepBy '.' + +sepBy :: Eq a => a ->[a] -> [[a]] +sepBy x0 xs + | (t, _ : d) <- span (/= x0) xs = t : sepBy x0 d + | otherwise = [xs] + +checkSepNames :: [String] -> [String] -> Bool +checkSepNames [] [] = True +checkSepNames _ [] = False +checkSepNames [] _ = False +checkSepNames ("*" : ns0) (_ : ns) = checkSepNames ns0 ns +checkSepNames (n0 : ns0) (n : ns) = n0 == n && checkSepNames ns0 ns + +-- | Don't forget check server name by checkName. + +open :: (ValidateHandle h, CPRG g) => h -> [CipherSuite] -> + [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore -> + TlsM h g (TlsHandle h g) +open h cscl crts ca = (TlsHandleC `liftM`) . execHandshakeM h $ do + setSettingsC (cscl, crts, ca) + handshake crts ca =<< clientHello cscl + +-- | This function open and check server name. +-- Use this so as not to forget to check server name. + +open' :: (ValidateHandle h, CPRG g) => h -> String -> [CipherSuite] -> + [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore -> + TlsM h g (TlsHandle h g) +open' h n cscl crts ca = do + t <- open h cscl crts ca + c <- checkName t n + unless c . E.throwError $ strMsg "certificate name mismatch" + return t + +renegotiate :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g () +renegotiate (TlsHandleC t) = rerunHandshakeM t $ do + (cscl, crts, ca) <- getSettingsC + clientHello cscl >>= \cr -> flushAd >>= flip when (handshake crts ca cr) + +setCipherSuites :: (ValidateHandle h, CPRG g) => TlsHandle h g -> + [CipherSuite] -> TlsM h g () +setCipherSuites (TlsHandleC t) cscl = rerunHandshakeM t $ do + (_, crts, cs) <- getSettingsC + setSettingsC (cscl, crts, cs) + +setKeyCerts :: (ValidateHandle h, CPRG g) => TlsHandle h g -> + [(CertSecretKey, X509.CertificateChain)] -> TlsM h g () +setKeyCerts (TlsHandleC t) crts = rerunHandshakeM t $ do + (cscl, _, cs) <- getSettingsC + setSettingsC (cscl, crts, cs) + +setCertificateStore :: (ValidateHandle h, CPRG g) => TlsHandle h g -> + X509.CertificateStore -> TlsM h g () +setCertificateStore (TlsHandleC t) cs = rerunHandshakeM t $ do + (cscl, crts, _) <- getSettingsC + setSettingsC (cscl, crts, cs) + +rehandshake :: (ValidateHandle h, CPRG g) => HandleBase h g -> TlsM h g () +rehandshake t = rerunHandshakeM t $ do + (cscl, crts, ca) <- getSettingsC + handshake crts ca =<< clientHello cscl + +clientHello :: (HandleLike h, CPRG g) => + [CipherSuite] -> HandshakeM h g BS.ByteString +clientHello cscl = do + cr <- withRandom $ cprgGenerate 32 + ((>>) <$> writeHandshake <*> debug "low") + . ClHello (3, 3) cr (SssnId "") cscl [CmpMtdNull] + . Just . (: []) =<< makeClRenego + return cr + +handshake :: (ValidateHandle h, CPRG g) => + [(CertSecretKey, X509.CertificateChain)] -> + X509.CertificateStore -> BS.ByteString -> HandshakeM h g () +handshake crts ca cr = do + (sr, ke) <- serverHello + ($ ca) . ($ crts) . ($ (cr, sr)) $ case ke of + RSA -> rsaHandshake + DHE_RSA -> dheHandshake (undefined :: DH.Params) + ECDHE_RSA -> dheHandshake (undefined :: ECC.Curve) + ECDHE_ECDSA -> dheHandshake (undefined :: ECC.Curve) + _ -> \_ _ _ -> throw ALFtl ADHsFailure $ + modNm ++ ".handshake: not implemented" + +serverHello :: (HandleLike h, CPRG g) => HandshakeM h g (BS.ByteString, KeyEx) +serverHello = do + SvHello v sr _sid cs@(CipherSuite ke _) cm e <- readHandshake + case v of + (3, 3) -> return () + _ -> throw ALFtl ADProtoVer $ + modNm ++ ".serverHello: only TLS 1.2" + case cm of + CmpMtdNull -> return () + _ -> throw ALFtl ADHsFailure $ + modNm ++ ".serverHello: only compression method null" + case find isRnInfo $ fromMaybe [] e of + Just ri -> checkSvRenego ri + _ -> throw ALFtl ADInsSec $ modNm ++ ".serverHello: no sec renego" + setCipherSuite cs + return (sr, ke) + +rsaHandshake :: (ValidateHandle h, CPRG g) => (BS.ByteString, BS.ByteString) -> + [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore -> + HandshakeM h g () +rsaHandshake rs crts ca = do + cc@(X509.CertificateChain (c : _)) <- readHandshake + vr <- handshakeValidate ca cc + unless (null vr) . throw ALFtl (validateAlert vr) $ + modNm ++ ".rsaHandshake: validate failure" + pk <- case X509.certPubKey . X509.signedObject $ X509.getSigned c of + X509.PubKeyRSA k -> return k + _ -> throw ALFtl ADIllParam $ modNm ++ ".rsaHandshake: RSA pk" + crt <- clientCertificate crts + pms <- ("\x03\x03" `BS.append`) `liftM` withRandom (cprgGenerate 46) + makeKeys Client rs pms + writeHandshake . Epms =<< encryptRsa pk pms + finishHandshake crt + +encryptRsa :: (HandleLike h, CPRG g) => + RSA.PublicKey -> BS.ByteString -> HandshakeM h g BS.ByteString +encryptRsa pk p = either (E.throwError . strMsg . show) return =<< + withRandom (\g -> RSA.encrypt g pk p) + +dheHandshake :: (ValidateHandle h, CPRG g, + KeyExchangeClass ke, Show (Secret ke), Show (Public ke)) => + ke -> (BS.ByteString, BS.ByteString) -> + [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore -> + HandshakeM h g () +dheHandshake t rs crts ca = do + cc@(X509.CertificateChain (c : _)) <- readHandshake + vr <- handshakeValidate ca cc + unless (null vr) . throw ALFtl (validateAlert vr) $ + modNm ++ ".succeed: validate failure" + case X509.certPubKey . X509.signedObject $ X509.getSigned c of + X509.PubKeyRSA pk -> succeed t pk rs crts + X509.PubKeyECDSA cv pt -> succeed t (ecdsaPubKey cv pt) rs crts + _ -> throw ALFtl ADHsFailure $ + modNm ++ ".dheHandshake: not implemented" + +succeed :: (ValidateHandle h, CPRG g, SvSignPublicKey pk, + KeyExchangeClass ke, Show (Secret ke), Show (Public ke)) => + ke -> pk -> (BS.ByteString, BS.ByteString) -> + [(CertSecretKey, X509.CertificateChain)] -> HandshakeM h g () +succeed t pk rs@(cr, sr) crts = do + (ps, pv, ha, sa, sn) <- serverKeyExchange + let _ = ps `asTypeOf` t + unless (sa == sspAlgorithm pk) . throw ALFtl ADHsFailure $ + pre ++ "sign algorithm unmatch" + unless (ssVerify ha pk sn $ BS.concat [cr, sr, B.encode ps, B.encode pv]) . + throw ALFtl ADDecryptErr $ pre ++ "verify failure" + crt <- clientCertificate crts + sv <- withRandom $ generateSecret ps + makeKeys Client rs $ calculateShared ps sv pv + writeHandshake . ClKeyEx . B.encode $ calculatePublic ps sv + finishHandshake crt + where pre = modNm ++ ".succeed: " + +class (DhParam bs, B.Bytable bs, B.Bytable (Public bs)) => KeyExchangeClass bs where + serverKeyExchange :: (HandleLike h, CPRG g) => HandshakeM h g + (bs, Public bs, HashAlg, SignAlg, BS.ByteString) + +instance KeyExchangeClass ECC.Curve where + serverKeyExchange = do + SvKeyExEcdhe cv pnt ha sa sn <- readHandshake + return (cv, pnt, ha, sa, sn) + +instance KeyExchangeClass DH.Params where + serverKeyExchange = do + SvKeyExDhe ps pv ha sa sn <- readHandshake + return (ps, pv, ha, sa, sn) + +clientCertificate :: (HandleLike h, CPRG g) => + [(CertSecretKey, X509.CertificateChain)] -> + HandshakeM h g (Maybe (CertSecretKey, X509.CertificateChain)) +clientCertificate crts = do + h <- readHandshake + (\p -> either p (\SHDone -> return Nothing) h) $ \(CertReq cct a dn) -> do + SHDone <- readHandshake + case find (isMatchedCert cct a dn) crts of + Just c -> + (>>) <$> writeHandshake . snd <*> return . Just $ c + _ -> throw ALFtl ADUnkCa $ modNm ++ + ".clientCertificate: no certificate" + +isMatchedCert :: [ClCertType] -> [(HashAlg, SignAlg)] -> + [X509.DistinguishedName] -> (CertSecretKey, X509.CertificateChain) -> Bool +isMatchedCert ct hsa dn = (&&) <$> csk . fst <*> ccrt . snd + where + obj = X509.signedObject . X509.getSigned + rsa = CTRsaSign `elem` ct || Rsa `elem` map snd hsa + ecdsa = CTEcdsaSign `elem` ct || Ecdsa `elem` map snd hsa + csk (RsaKey _) = rsa; csk (EcdsaKey _) = ecdsa + ccrt (X509.CertificateChain cs@(c : _)) = + cpk (X509.certPubKey $ obj c) && + not (null . intersect dn $ map (X509.certIssuerDN . obj) cs) + ccrt _ = error $ modNm ++ ".isMatchedCert: empty certificate chain" + cpk X509.PubKeyRSA{} = rsa; cpk X509.PubKeyECDSA{} = ecdsa; cpk _ = False + +finishHandshake :: (HandleLike h, CPRG g) => + Maybe (CertSecretKey, X509.CertificateChain) -> HandshakeM h g () +finishHandshake crt = do + hs <- handshakeHash + case fst <$> crt of + Just (RsaKey sk) -> writeHandshake . + DigitSigned (cssAlgorithm sk) $ csSign sk hs + Just (EcdsaKey sk) -> writeHandshake . + DigitSigned (cssAlgorithm sk) $ csSign sk hs + _ -> return () + writeHandshake CCSpec + flushCipherSuite Write + writeHandshake =<< finishedHash Client + CCSpec <- readHandshake + flushCipherSuite Read + (==) `liftM` finishedHash Server `ap` readHandshake >>= flip unless + (throw ALFtl ADDecryptErr $ + modNm ++ ".finishHandshake: finished hash failure") diff --git a/src/Network/PeyoTLS/Run.hs b/src/Network/PeyoTLS/Run.hs --- a/src/Network/PeyoTLS/Run.hs +++ b/src/Network/PeyoTLS/Run.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, PackageImports #-} module Network.PeyoTLS.Run ( H.debug, - H.TlsM, H.run, H.HandleBase, + H.TlsState(..), H.State1(..), H.wFlush, H.Keys(..), + H.TlsM, H.run, H.run', H.HandleBase, adGet, adGetLine, adGetContent, H.adPut, H.adDebug, H.adClose, HandshakeM, execHandshakeM, rerunHandshakeM, withRandom, chGet, ccsPut, hsPut, updateHash, flushAd, @@ -35,7 +36,8 @@ import qualified Crypto.Hash.SHA256 as SHA256 import qualified Network.PeyoTLS.Run.Handle as H ( debug, - TlsM, run, withRandom, + TlsState(..), State1(..), wFlush, Keys(..), + TlsM, run, run', withRandom, HandleBase, CipherSuite, newHandle, chGet, ccsPut, hsPut, adGet, adGetLine, adGetContent, adPut, adDebug, adClose, diff --git a/src/Network/PeyoTLS/Run/Crypto.hs b/src/Network/PeyoTLS/Run/Crypto.hs --- a/src/Network/PeyoTLS/Run/Crypto.hs +++ b/src/Network/PeyoTLS/Run/Crypto.hs @@ -58,7 +58,8 @@ decrypt :: (Hash, Int) -> BS.ByteString -> BS.ByteString -> Word64 -> BS.ByteString -> BS.ByteString -> Either String BS.ByteString decrypt (hs, ml) k mk sn pre enc = - if rm == em then Right b else Left $ modNm ++ ".decrypt: bad MAC\n" + if rm == em then Right b else Left $ modNm ++ ".decrypt: bad MAC\n" ++ + "\t"++ show b ++ "\n" where pln = uncurry (AES.decryptCBC $ AES.initAES k) $ BS.splitAt 16 enc up = BS.take (BS.length pln - fromIntegral (lst pln) - 1) pln diff --git a/src/Network/PeyoTLS/Run/Handle.hs b/src/Network/PeyoTLS/Run/Handle.hs --- a/src/Network/PeyoTLS/Run/Handle.hs +++ b/src/Network/PeyoTLS/Run/Handle.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings, TupleSections, PackageImports #-} module Network.PeyoTLS.Run.Handle ( debug, - M.TlsM, M.run, M.withRandom, + M.TlsState(..), M.State1(..), wFlush, M.Keys(..), + M.TlsM, M.run, M.run', M.withRandom, HandleBase, M.CipherSuite, newHandle, chGet, ccsPut, hsPut, adGet, adGetLine, splitLine, adGetContent, adPut, adDebug, adClose, @@ -33,7 +34,8 @@ import qualified Codec.Bytable.BigEndian as B import qualified Network.PeyoTLS.Run.Monad as M ( - TlsM, run, throw, withRandom, + TlsState(..), State1(..), + TlsM, run, run', throw, withRandom, Alert(..), AlertLevel(..), AlertDesc(..), tGet, decrypt, tPut, encrypt, tClose, tDebug, PartnerId, newPartner, ContType(..), diff --git a/src/Network/PeyoTLS/Run/Monad.hs b/src/Network/PeyoTLS/Run/Monad.hs --- a/src/Network/PeyoTLS/Run/Monad.hs +++ b/src/Network/PeyoTLS/Run/Monad.hs @@ -1,7 +1,9 @@ {-# LANGUAGE OverloadedStrings, PackageImports #-} module Network.PeyoTLS.Run.Monad ( - TlsM, run, throw, withRandom, + S.TlsState(..), S.State1(..), + + TlsM, run, run', throw, withRandom, Alert(..), AlertLevel(..), AlertDesc(..), tGet, decrypt, tPut, encrypt, tClose, tDebug, S.PartnerId, S.newPartner, S.ContType(..), @@ -17,7 +19,8 @@ import Control.Arrow ((***)) import Control.Monad (unless, liftM, ap) -import "monads-tf" Control.Monad.State (lift, StateT, evalStateT, gets, modify) +import "monads-tf" Control.Monad.State + (lift, StateT, runStateT, evalStateT, gets, modify) import "monads-tf" Control.Monad.Error (ErrorT, runErrorT, throwError) import "monads-tf" Control.Monad.Error.Class (Error(..)) import Data.Word (Word8, Word64) @@ -27,8 +30,8 @@ import qualified Data.ByteString as BS import qualified Codec.Bytable.BigEndian as B -import qualified Network.PeyoTLS.Run.State as S ( - TlsState, initState, PartnerId, newPartner, +import qualified Network.PeyoTLS.Run.State as S (State1(..), Keys(..), + TlsState(..), initState, PartnerId, newPartner, getGen, setGen, getNames, setNames, getRSn, getWSn, rstRSn, rstWSn, sccRSn, sccWSn, getClFinished, getSvFinished, setClFinished, setSvFinished, @@ -52,8 +55,15 @@ run :: HandleLike h => TlsM h g a -> g -> HandleMonad h a run m g = evalStateT (runErrorT m) (S.initState g) >>= \er -> case er of - Right r -> return r - Left a -> error $ show a + Right r -> return r + Left a -> error $ show a + +run' :: HandleLike h => TlsM h g a -> g -> HandleMonad h ((S.Keys, [String]), g) +run' m g = runStateT (runErrorT m) (S.initState g) >>= \er -> case er of + (Right _, s) -> return (( + S.sKeys . snd . head $ S.states s, + S.sNames . snd . head $ S.states s ), S.gen s) + (Left a, _) -> error $ show a throw :: HandleLike h => AlertLevel -> AlertDesc -> String -> TlsM h g a throw = ((throwError .) .) . Alert diff --git a/src/Network/PeyoTLS/Run/State.hs b/src/Network/PeyoTLS/Run/State.hs --- a/src/Network/PeyoTLS/Run/State.hs +++ b/src/Network/PeyoTLS/Run/State.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings, TupleSections #-} -module Network.PeyoTLS.Run.State ( - TlsState, initState, PartnerId, newPartner, +module Network.PeyoTLS.Run.State ( State1(..), + TlsState(..), initState, PartnerId, newPartner, getGen, setGen, getNames, setNames, getRSn, getWSn, rstRSn, rstWSn, sccRSn, sccWSn, getClFinished, setClFinished, getSvFinished, setSvFinished, diff --git a/src/Network/PeyoTLS/Server.hs b/src/Network/PeyoTLS/Server.hs --- a/src/Network/PeyoTLS/Server.hs +++ b/src/Network/PeyoTLS/Server.hs @@ -8,11 +8,10 @@ -} -{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-} - module Network.PeyoTLS.Server ( -- * Basic - PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, Alert(..), run, open, getNames, + PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, Alert(..), + run, open, getNames, -- * Renegotiation renegotiate, setCipherSuites, setKeyCerts, setCertificateStore, -- * Cipher Suite @@ -20,282 +19,4 @@ -- * Others ValidateHandle(..), CertSecretKey(..) ) where -import Control.Applicative ((<$>), (<*>)) -import Control.Arrow (first) -import Control.Monad (when, unless, liftM, ap) -import "monads-tf" Control.Monad.Error (catchError) -import "monads-tf" Control.Monad.Error.Class (strMsg) -import Data.List (find) -import Data.Word (Word8) -import Data.HandleLike (HandleLike(..)) -import System.IO (Handle) -import Numeric (readHex) -import "crypto-random" Crypto.Random (CPRG, SystemRNG, cprgGenerate) - -import qualified "monads-tf" Control.Monad.Error as E -import qualified Data.ByteString as BS -import qualified Data.X509 as X509 -import qualified Data.X509.CertificateStore as X509 -import qualified Codec.Bytable.BigEndian as B -import qualified Crypto.PubKey.RSA as RSA -import qualified Crypto.PubKey.RSA.PKCS15 as RSA -import qualified Crypto.Types.PubKey.DH as DH -import qualified Crypto.Types.PubKey.ECC as ECC - -import qualified Network.PeyoTLS.Base as BASE (getNames) -import Network.PeyoTLS.Base ( debug, - PeyotlsM, TlsM, run, - SettingsS, getSettingsS, setSettingsS, - adGet, adGetLine, adGetContent, adPut, adDebug, adClose, - HandshakeM, execHandshakeM, rerunHandshakeM, - withRandom, flushAd, - Alert(..), AlertLevel(..), AlertDesc(..), throw, debugCipherSuite, - ValidateHandle(..), handshakeValidate, validateAlert, - HandleBase, CertSecretKey(..), isRsaKey, isEcdsaKey, - readHandshake, writeHandshake, CCSpec(..), - Handshake(HHelloReq), - ClHello(..), SvHello(..), SssnId(..), Extension(..), - isRnInfo, emptyRnInfo, - CipherSuite(..), KeyEx(..), BulkEnc(..), - CmpMtd(..), HashAlg(..), SignAlg(..), - getCipherSuite, setCipherSuite, - checkClRenego, makeSvRenego, - SvKeyEx(..), SvSignSecretKey(..), - certReq, ClCertType(..), - SHDone(..), - ClKeyEx(..), Epms(..), makeKeys, - DigitSigned(..), ClSignPublicKey(..), handshakeHash, - RW(..), flushCipherSuite, - Side(..), finishedHash, - DhParam(..), ecdsaPubKey ) - -type PeyotlsHandle = TlsHandle Handle SystemRNG - -newtype TlsHandle h g = TlsHandleS { tlsHandleS :: HandleBase h g } deriving Show - -instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandle h g) where - type HandleMonad (TlsHandle h g) = TlsM h g - type DebugLevel (TlsHandle h g) = DebugLevel h - hlPut = adPut . tlsHandleS - hlGet = adGet rehandshake . tlsHandleS - hlGetLine = adGetLine rehandshake . tlsHandleS - hlGetContent = adGetContent rehandshake . tlsHandleS - hlDebug = adDebug . tlsHandleS - hlClose = adClose . tlsHandleS - -type Version = (Word8, Word8) - -version :: Version -version = (3, 3) - -moduleName :: String -moduleName = "Network.PeyoTLS.Server" - -getNames :: HandleLike h => TlsHandle h g -> TlsM h g [String] -getNames = BASE.getNames . tlsHandleS - -open :: (ValidateHandle h, CPRG g) => h -> [CipherSuite] -> - [(CertSecretKey, X509.CertificateChain)] -> Maybe X509.CertificateStore -> - TlsM h g (TlsHandle h g) -open h cssv crts mcs = liftM TlsHandleS . execHandshakeM h $ - ((>>) <$> setSettingsS <*> handshake) (cssv', - first rsaKey <$> find (isRsaKey . fst) crts, - first ecdsaKey <$> find (isEcdsaKey . fst) crts, mcs ) - where - cssv' = filter iscs $ case find (isEcdsaKey . fst) crts of - Just _ -> cssv - _ -> flip filter cssv $ \cs -> case cs of - CipherSuite ECDHE_ECDSA _ -> False - _ -> True - iscs (CipherSuiteRaw _ _) = False - iscs EMPTY_RENEGOTIATION_INFO = False - iscs _ = True - -setCipherSuites :: (ValidateHandle h, CPRG g) => TlsHandle h g -> - [CipherSuite] -> TlsM h g () -setCipherSuites (TlsHandleS t) cssv = rerunHandshakeM t $ do - (_, rcrt, ecrt, mcs) <- getSettingsS - setSettingsS (cssv, rcrt, ecrt, mcs) - -setKeyCerts :: (ValidateHandle h, CPRG g) => TlsHandle h g -> - [(CertSecretKey, X509.CertificateChain)] -> TlsM h g () -setKeyCerts (TlsHandleS t) crts = rerunHandshakeM t $ do - (cssv, _, _, mcs) <- getSettingsS - setSettingsS (cssv, - first rsaKey <$> find (isRsaKey . fst) crts, - first ecdsaKey <$> find (isEcdsaKey . fst) crts, mcs) - -setCertificateStore :: (ValidateHandle h, CPRG g) => TlsHandle h g -> - Maybe X509.CertificateStore -> TlsM h g () -setCertificateStore (TlsHandleS t) mcs = rerunHandshakeM t $ do - (cssv, rcrt, ecrt, _) <- getSettingsS - setSettingsS (cssv, rcrt, ecrt, mcs) - -renegotiate :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g () -renegotiate (TlsHandleS t) = rerunHandshakeM t $ do - writeHandshake HHelloReq - debug "low" ("before flushAd" :: String) - ne <- flushAd - debug "low" ("after flushAd" :: String) - when ne (handshake =<< getSettingsS) - -rehandshake :: (ValidateHandle h, CPRG g) => HandleBase h g -> TlsM h g () -rehandshake t = rerunHandshakeM t $ handshake =<< getSettingsS - -handshake :: (ValidateHandle h, CPRG g) => SettingsS -> HandshakeM h g () -handshake (cssv, rcrt, ecrt, mcs) = do - (ke, be, cr, cv) <- clientHello cssv - sr <- serverHello (snd <$> rcrt) (snd <$> ecrt) - ha <- case be of - AES_128_CBC_SHA -> return Sha1 - AES_128_CBC_SHA256 -> return Sha256 - _ -> throw ALFtl ADInternalErr $ - pre ++ "not implemented bulk encryption type" - mpk <- ($ mcs) . ($ (cr, sr)) $ case (ke, fst <$> rcrt, fst <$> ecrt) of - (RSA, Just rsk, _) -> rsaKeyExchange rsk cv - (DHE_RSA, Just rsk, _) -> dhKeyExchange ha dh3072Modp rsk - (ECDHE_RSA, Just rsk, _) -> dhKeyExchange ha secp256r1 rsk - (ECDHE_ECDSA, _, Just esk) -> dhKeyExchange ha secp256r1 esk - _ -> \_ _ -> throw ALFtl ADInternalErr $ - pre ++ "no implemented key exchange type or " ++ - "no applicable certificate files" - flip (maybe $ return ()) mpk $ \pk -> case pk of - X509.PubKeyRSA rpk -> certVerify rpk - X509.PubKeyECDSA c xy -> certVerify $ ecdsaPubKey c xy - _ -> throw ALFtl ADUnsCert $ pre ++ "not implement: " ++ show pk - CCSpec <- readHandshake - flushCipherSuite Read - (==) `liftM` finishedHash Client `ap` readHandshake >>= \ok -> unless ok . - throw ALFtl ADDecryptErr $ pre ++ "wrong finished hash" - writeHandshake CCSpec - flushCipherSuite Write - writeHandshake =<< finishedHash Server - where pre = moduleName ++ ".handshake: " - -secp256r1 :: ECC.Curve -secp256r1 = ECC.getCurveByName ECC.SEC_p256r1 - -dh3072Modp :: DH.Params -dh3072Modp = DH.Params p 2 - where [(p, "")] = readHex $ - "ffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd1" ++ - "29024e088a67cc74020bbea63b139b22514a08798e3404dd" ++ - "ef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245" ++ - "e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7ed" ++ - "ee386bfb5a899fa5ae9f24117c4b1fe649286651ece45b3d" ++ - "c2007cb8a163bf0598da48361c55d39a69163fa8fd24cf5f" ++ - "83655d23dca3ad961c62f356208552bb9ed529077096966d" ++ - "670c354e4abc9804f1746c08ca18217c32905e462e36ce3b" ++ - "e39e772c180e86039b2783a2ec07a28fb5c55df06f4c52c9" ++ - "de2bcbf6955817183995497cea956ae515d2261898fa0510" ++ - "15728e5a8aaac42dad33170d04507a33a85521abdf1cba64" ++ - "ecfb850458dbef0a8aea71575d060c7db3970f85a6e1e4c7" ++ - "abf5ae8cdb0933d71e8c94e04a25619dcee3d2261ad2ee6b" ++ - "f12ffa06d98a0864d87602733ec86a64521f2b18177b200c" ++ - "bbe117577a615d6c770988c0bad946e208e24fa074e5ab31" ++ - "43db5bfce0fd108e4b82d120a93ad2caffffffffffffffff" - -clientHello :: (HandleLike h, CPRG g) => [CipherSuite] -> - HandshakeM h g (KeyEx, BulkEnc, BS.ByteString, Version) -clientHello cssv = do - ClHello cv cr _sid cscl cms me <- readHandshake - checkRnInfo cscl me - unless (cv >= version) . throw ALFtl ADProtoVer $ - pre ++ "only implement TLS 1.2" - unless (CmpMtdNull `elem` cms) . throw ALFtl ADDecodeErr $ - pre ++ "compression method NULL must be supported" - (ke, be) <- case find (`elem` cscl) cssv of - Just cs@(CipherSuite k b) -> setCipherSuite cs >> return (k, b) - _ -> throw ALFtl ADHsFailure $ - pre ++ "no acceptable set of security parameters: \n\t" ++ - "cscl: " ++ show cscl ++ "\n\t" ++ - "cssv: " ++ show cssv ++ "\n" - return (ke, be, cr, cv) - where pre = moduleName ++ ".clientHello: " - -checkRnInfo :: - HandleLike h => [CipherSuite] -> Maybe [Extension] -> HandshakeM h g () -checkRnInfo cscl me = (\n -> maybe n checkClRenego mcf) . throw - ALFtl ADInsSec $ moduleName ++ ".checkRenego: require secure renegotiation" - where mcf = case (EMPTY_RENEGOTIATION_INFO `elem` cscl, me) of - (True, _) -> Just emptyRnInfo - (_, Just e) -> find isRnInfo e - (_, _) -> Nothing - -serverHello :: (HandleLike h, CPRG g) => - Maybe X509.CertificateChain -> Maybe X509.CertificateChain -> - HandshakeM h g BS.ByteString -serverHello rcc ecc = do - cs <- getCipherSuite - ke <- case cs of - CipherSuite k _ -> return k - _ -> throw ALFtl ADInternalErr $ - moduleName ++ ".serverHello: never occur" - sr <- withRandom $ cprgGenerate 32 - writeHandshake - . SvHello version sr (SssnId "") cs CmpMtdNull - . Just . (: []) =<< makeSvRenego - writeHandshake =<< case (ke, rcc, ecc) of - (ECDHE_ECDSA, _, Just c) -> return c - (_, Just c, _) -> return c - _ -> throw ALFtl ADInternalErr $ - moduleName ++ ".serverHello: cert files not match" - return sr - -rsaKeyExchange :: (ValidateHandle h, CPRG g) => RSA.PrivateKey -> Version -> - (BS.ByteString, BS.ByteString) -> Maybe X509.CertificateStore -> - HandshakeM h g (Maybe X509.PubKey) -rsaKeyExchange sk (vj, vn) rs mcs = const `liftM` reqAndCert mcs `ap` do - Epms epms <- readHandshake - makeKeys Server rs =<< mkpms epms `catchError` const - ((BS.cons vj . BS.cons vn) `liftM` withRandom (cprgGenerate 46)) - where mkpms epms = do - pms <- either (E.throwError . strMsg . show) return =<< - withRandom (\g -> RSA.decryptSafer g sk epms) - unless (BS.length pms == 48) $ throw ALFtl ADHsFailure "" - let [pvj, pvn] = BS.unpack $ BS.take 2 pms - unless (pvj == vj && pvn == vn) $ throw ALFtl ADHsFailure "" - return pms - -dhKeyExchange :: (ValidateHandle h, CPRG g, SvSignSecretKey sk, - DhParam dp, B.Bytable dp, B.Bytable (Public dp)) => - HashAlg -> dp -> sk -> (BS.ByteString, BS.ByteString) -> - Maybe X509.CertificateStore -> HandshakeM h g (Maybe X509.PubKey) -dhKeyExchange ha dp sk rs@(cr, sr) mcs = do - sv <- withRandom $ generateSecret dp - bl <- withRandom $ generateBlinder sk - let pv = B.encode $ calculatePublic dp sv - writeHandshake - . SvKeyEx (B.encode dp) pv ha (sssAlgorithm sk) - . ssSign sk ha bl $ BS.concat [cr, sr, B.encode dp, pv] - const `liftM` reqAndCert mcs `ap` do - ClKeyEx cke <- readHandshake - makeKeys Server rs . calculateShared dp sv =<< - either (throw ALFtl ADInternalErr . - (moduleName ++) . (".dhKeyExchange: " ++)) - return (B.decode cke) - -reqAndCert :: (ValidateHandle h, CPRG g) => - Maybe X509.CertificateStore -> HandshakeM h g (Maybe X509.PubKey) -reqAndCert mcs = do - flip (maybe $ return ()) mcs $ writeHandshake . certReq - [CTRsaSign, CTEcdsaSign] [(Sha256, Rsa), (Sha256, Ecdsa)] - writeHandshake SHDone - flip (maybe $ return Nothing) mcs $ liftM Just . \cs -> do - cc@(X509.CertificateChain (c : _)) <- readHandshake - vr <- handshakeValidate cs cc - unless (null vr) . throw ALFtl (validateAlert vr) $ - moduleName ++ ".reqAndCert: " ++ show vr - return . X509.certPubKey $ X509.getCertificate c - -certVerify :: (HandleLike h, CPRG g, ClSignPublicKey pk) => pk -> HandshakeM h g () -certVerify pk = do - debugCipherSuite . show $ cspAlgorithm pk - hs0 <- handshakeHash - DigitSigned a s <- readHandshake - case a of - (Sha256, sa) | sa == cspAlgorithm pk -> return () - _ -> throw ALFtl ADDecodeErr $ - moduleName ++ ".certVerify: not implement: " ++ show a - unless (csVerify pk s hs0) . throw ALFtl ADDecryptErr $ - moduleName ++ ".certVerify: client auth failed " +import Network.PeyoTLS.Server.Body diff --git a/src/Network/PeyoTLS/Server/Body.hs b/src/Network/PeyoTLS/Server/Body.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Server/Body.hs @@ -0,0 +1,324 @@ +{-| + +Module : Network.PeyoTLS.Server +Copyright : (c) Yoshikuni Jujo, 2014 +License : BSD3 +Maintainer : PAF01143@nifty.ne.jp +Stability : Experimental + +-} + +{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-} + +module Network.PeyoTLS.Server.Body ( + Keys(..), toCheckName, + -- * Basic + PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, Alert(..), + run, run', open, getNames, + -- * Renegotiation + renegotiate, setCipherSuites, setKeyCerts, setCertificateStore, + -- * Cipher Suite + CipherSuite(..), KeyEx(..), BulkEnc(..), + -- * Others + ValidateHandle(..), CertSecretKey(..) ) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Arrow (first) +import Control.Monad (when, unless, liftM, ap) +import "monads-tf" Control.Monad.Error (catchError) +import "monads-tf" Control.Monad.Error.Class (strMsg) +import Data.List (find) +import Data.Word (Word8) +import Data.Function +import Data.HandleLike (HandleLike(..)) +import System.IO (Handle) +import Numeric (readHex) +import "crypto-random" Crypto.Random (CPRG, SystemRNG, cprgGenerate) + +import qualified "monads-tf" Control.Monad.Error as E +import qualified Data.ByteString as BS +import qualified Data.X509 as X509 +import qualified Data.X509.CertificateStore as X509 +import qualified Codec.Bytable.BigEndian as B +import qualified Crypto.PubKey.RSA as RSA +import qualified Crypto.PubKey.RSA.PKCS15 as RSA +import qualified Crypto.Types.PubKey.DH as DH +import qualified Crypto.Types.PubKey.ECC as ECC + +import qualified Network.PeyoTLS.Base as BASE (getNames) +import Network.PeyoTLS.Base ( debug, Keys(..), + PeyotlsM, TlsM, run, run', wFlush, + SettingsS, getSettingsS, setSettingsS, + adGet, adGetLine, adGetContent, adPut, adDebug, adClose, + HandshakeM, execHandshakeM, rerunHandshakeM, + withRandom, flushAd, + Alert(..), AlertLevel(..), AlertDesc(..), throw, debugCipherSuite, + ValidateHandle(..), handshakeValidate, validateAlert, + HandleBase, CertSecretKey(..), isRsaKey, isEcdsaKey, + readHandshake, writeHandshake, CCSpec(..), + Handshake(HHelloReq), + ClHello(..), SvHello(..), SssnId(..), Extension(..), + isRnInfo, emptyRnInfo, + CipherSuite(..), KeyEx(..), BulkEnc(..), + CmpMtd(..), HashAlg(..), SignAlg(..), + getCipherSuite, setCipherSuite, + checkClRenego, makeSvRenego, + SvKeyEx(..), SvSignSecretKey(..), + certReq, ClCertType(..), + SHDone(..), + ClKeyEx(..), Epms(..), makeKeys, + DigitSigned(..), ClSignPublicKey(..), handshakeHash, + RW(..), flushCipherSuite, + Side(..), finishedHash, + DhParam(..), ecdsaPubKey ) + +type PeyotlsHandle = TlsHandle Handle SystemRNG + +newtype TlsHandle h g = TlsHandleS { tlsHandleS :: HandleBase h g } deriving Show + +instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandle h g) where + type HandleMonad (TlsHandle h g) = TlsM h g + type DebugLevel (TlsHandle h g) = DebugLevel h + hlPut = adPut . tlsHandleS + hlGet = adGet rehandshake . tlsHandleS + hlGetLine = adGetLine rehandshake . tlsHandleS + hlGetContent = adGetContent rehandshake . tlsHandleS + hlDebug = adDebug . tlsHandleS + hlClose = adClose . tlsHandleS + hlFlush = wFlush . tlsHandleS + +type Version = (Word8, Word8) + +version :: Version +version = (3, 3) + +moduleName :: String +moduleName = "Network.PeyoTLS.Server" + +getNames :: HandleLike h => TlsHandle h g -> TlsM h g [String] +getNames = BASE.getNames . tlsHandleS + +open :: (ValidateHandle h, CPRG g) => h -> [CipherSuite] -> + [(CertSecretKey, X509.CertificateChain)] -> Maybe X509.CertificateStore -> + TlsM h g (TlsHandle h g) +open h cssv crts mcs = liftM TlsHandleS . execHandshakeM h $ + ((>>) <$> setSettingsS <*> handshake) (cssv', + first rsaKey <$> find (isRsaKey . fst) crts, + first ecdsaKey <$> find (isEcdsaKey . fst) crts, mcs ) + where + cssv' = filter iscs $ case find (isEcdsaKey . fst) crts of + Just _ -> cssv + _ -> flip filter cssv $ \cs -> case cs of + CipherSuite ECDHE_ECDSA _ -> False + _ -> True + iscs (CipherSuiteRaw _ _) = False + iscs EMPTY_RENEGOTIATION_INFO = False + iscs _ = True + +setCipherSuites :: (ValidateHandle h, CPRG g) => TlsHandle h g -> + [CipherSuite] -> TlsM h g () +setCipherSuites (TlsHandleS t) cssv = rerunHandshakeM t $ do + (_, rcrt, ecrt, mcs) <- getSettingsS + setSettingsS (cssv, rcrt, ecrt, mcs) + +setKeyCerts :: (ValidateHandle h, CPRG g) => TlsHandle h g -> + [(CertSecretKey, X509.CertificateChain)] -> TlsM h g () +setKeyCerts (TlsHandleS t) crts = rerunHandshakeM t $ do + (cssv, _, _, mcs) <- getSettingsS + setSettingsS (cssv, + first rsaKey <$> find (isRsaKey . fst) crts, + first ecdsaKey <$> find (isEcdsaKey . fst) crts, mcs) + +setCertificateStore :: (ValidateHandle h, CPRG g) => TlsHandle h g -> + Maybe X509.CertificateStore -> TlsM h g () +setCertificateStore (TlsHandleS t) mcs = rerunHandshakeM t $ do + (cssv, rcrt, ecrt, _) <- getSettingsS + setSettingsS (cssv, rcrt, ecrt, mcs) + +renegotiate :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g () +renegotiate (TlsHandleS t) = rerunHandshakeM t $ do + writeHandshake HHelloReq + debug "low" ("before flushAd" :: String) + ne <- flushAd + debug "low" ("after flushAd" :: String) + when ne (handshake =<< getSettingsS) + +rehandshake :: (ValidateHandle h, CPRG g) => HandleBase h g -> TlsM h g () +rehandshake t = rerunHandshakeM t $ handshake =<< getSettingsS + +handshake :: (ValidateHandle h, CPRG g) => SettingsS -> HandshakeM h g () +handshake (cssv, rcrt, ecrt, mcs) = do + (ke, be, cr, cv) <- clientHello cssv + sr <- serverHello (snd <$> rcrt) (snd <$> ecrt) + ha <- case be of + AES_128_CBC_SHA -> return Sha1 + AES_128_CBC_SHA256 -> return Sha256 + _ -> throw ALFtl ADInternalErr $ + pre ++ "not implemented bulk encryption type" + mpk <- ($ mcs) . ($ (cr, sr)) $ case (ke, fst <$> rcrt, fst <$> ecrt) of + (RSA, Just rsk, _) -> rsaKeyExchange rsk cv + (DHE_RSA, Just rsk, _) -> dhKeyExchange ha dh3072Modp rsk + (ECDHE_RSA, Just rsk, _) -> dhKeyExchange ha secp256r1 rsk + (ECDHE_ECDSA, _, Just esk) -> dhKeyExchange ha secp256r1 esk + _ -> \_ _ -> throw ALFtl ADInternalErr $ + pre ++ "no implemented key exchange type or " ++ + "no applicable certificate files" + flip (maybe $ return ()) mpk $ \pk -> case pk of + X509.PubKeyRSA rpk -> certVerify rpk + X509.PubKeyECDSA c xy -> certVerify $ ecdsaPubKey c xy + _ -> throw ALFtl ADUnsCert $ pre ++ "not implement: " ++ show pk + CCSpec <- readHandshake + flushCipherSuite Read + (==) `liftM` finishedHash Client `ap` readHandshake >>= \ok -> unless ok . + throw ALFtl ADDecryptErr $ pre ++ "wrong finished hash" + writeHandshake CCSpec + flushCipherSuite Write + writeHandshake =<< finishedHash Server + where pre = moduleName ++ ".handshake: " + +secp256r1 :: ECC.Curve +secp256r1 = ECC.getCurveByName ECC.SEC_p256r1 + +dh3072Modp :: DH.Params +dh3072Modp = DH.Params p 2 + where [(p, "")] = readHex $ + "ffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd1" ++ + "29024e088a67cc74020bbea63b139b22514a08798e3404dd" ++ + "ef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245" ++ + "e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7ed" ++ + "ee386bfb5a899fa5ae9f24117c4b1fe649286651ece45b3d" ++ + "c2007cb8a163bf0598da48361c55d39a69163fa8fd24cf5f" ++ + "83655d23dca3ad961c62f356208552bb9ed529077096966d" ++ + "670c354e4abc9804f1746c08ca18217c32905e462e36ce3b" ++ + "e39e772c180e86039b2783a2ec07a28fb5c55df06f4c52c9" ++ + "de2bcbf6955817183995497cea956ae515d2261898fa0510" ++ + "15728e5a8aaac42dad33170d04507a33a85521abdf1cba64" ++ + "ecfb850458dbef0a8aea71575d060c7db3970f85a6e1e4c7" ++ + "abf5ae8cdb0933d71e8c94e04a25619dcee3d2261ad2ee6b" ++ + "f12ffa06d98a0864d87602733ec86a64521f2b18177b200c" ++ + "bbe117577a615d6c770988c0bad946e208e24fa074e5ab31" ++ + "43db5bfce0fd108e4b82d120a93ad2caffffffffffffffff" + +clientHello :: (HandleLike h, CPRG g) => [CipherSuite] -> + HandshakeM h g (KeyEx, BulkEnc, BS.ByteString, Version) +clientHello cssv = do + ClHello cv cr _sid cscl cms me <- readHandshake + checkRnInfo cscl me + unless (cv >= version) . throw ALFtl ADProtoVer $ + pre ++ "only implement TLS 1.2" + unless (CmpMtdNull `elem` cms) . throw ALFtl ADDecodeErr $ + pre ++ "compression method NULL must be supported" + (ke, be) <- case find (`elem` cscl) cssv of + Just cs@(CipherSuite k b) -> setCipherSuite cs >> return (k, b) + _ -> throw ALFtl ADHsFailure $ + pre ++ "no acceptable set of security parameters: \n\t" ++ + "cscl: " ++ show cscl ++ "\n\t" ++ + "cssv: " ++ show cssv ++ "\n" + return (ke, be, cr, cv) + where pre = moduleName ++ ".clientHello: " + +checkRnInfo :: + HandleLike h => [CipherSuite] -> Maybe [Extension] -> HandshakeM h g () +checkRnInfo cscl me = (\n -> maybe n checkClRenego mcf) . throw + ALFtl ADInsSec $ moduleName ++ ".checkRenego: require secure renegotiation" + where mcf = case (EMPTY_RENEGOTIATION_INFO `elem` cscl, me) of + (True, _) -> Just emptyRnInfo + (_, Just e) -> find isRnInfo e + (_, _) -> Nothing + +serverHello :: (HandleLike h, CPRG g) => + Maybe X509.CertificateChain -> Maybe X509.CertificateChain -> + HandshakeM h g BS.ByteString +serverHello rcc ecc = do + cs <- getCipherSuite + ke <- case cs of + CipherSuite k _ -> return k + _ -> throw ALFtl ADInternalErr $ + moduleName ++ ".serverHello: never occur" + sr <- withRandom $ cprgGenerate 32 + writeHandshake + . SvHello version sr (SssnId "") cs CmpMtdNull + . Just . (: []) =<< makeSvRenego + writeHandshake =<< case (ke, rcc, ecc) of + (ECDHE_ECDSA, _, Just c) -> return c + (_, Just c, _) -> return c + _ -> throw ALFtl ADInternalErr $ + moduleName ++ ".serverHello: cert files not match" + return sr + +rsaKeyExchange :: (ValidateHandle h, CPRG g) => RSA.PrivateKey -> Version -> + (BS.ByteString, BS.ByteString) -> Maybe X509.CertificateStore -> + HandshakeM h g (Maybe X509.PubKey) +rsaKeyExchange sk (vj, vn) rs mcs = const `liftM` reqAndCert mcs `ap` do + Epms epms <- readHandshake + makeKeys Server rs =<< mkpms epms `catchError` const + ((BS.cons vj . BS.cons vn) `liftM` withRandom (cprgGenerate 46)) + where mkpms epms = do + pms <- either (E.throwError . strMsg . show) return =<< + withRandom (\g -> RSA.decryptSafer g sk epms) + unless (BS.length pms == 48) $ throw ALFtl ADHsFailure "" + let [pvj, pvn] = BS.unpack $ BS.take 2 pms + unless (pvj == vj && pvn == vn) $ throw ALFtl ADHsFailure "" + return pms + +dhKeyExchange :: (ValidateHandle h, CPRG g, SvSignSecretKey sk, + DhParam dp, B.Bytable dp, B.Bytable (Public dp)) => + HashAlg -> dp -> sk -> (BS.ByteString, BS.ByteString) -> + Maybe X509.CertificateStore -> HandshakeM h g (Maybe X509.PubKey) +dhKeyExchange ha dp sk rs@(cr, sr) mcs = do + sv <- withRandom $ generateSecret dp + bl <- withRandom $ generateBlinder sk + let pv = B.encode $ calculatePublic dp sv + writeHandshake + . SvKeyEx (B.encode dp) pv ha (sssAlgorithm sk) + . ssSign sk ha bl $ BS.concat [cr, sr, B.encode dp, pv] + const `liftM` reqAndCert mcs `ap` do + ClKeyEx cke <- readHandshake + makeKeys Server rs . calculateShared dp sv =<< + either (throw ALFtl ADInternalErr . + (moduleName ++) . (".dhKeyExchange: " ++)) + return (B.decode cke) + +reqAndCert :: (ValidateHandle h, CPRG g) => + Maybe X509.CertificateStore -> HandshakeM h g (Maybe X509.PubKey) +reqAndCert mcs = do + flip (maybe $ return ()) mcs $ writeHandshake . certReq + [CTRsaSign, CTEcdsaSign] [(Sha256, Rsa), (Sha256, Ecdsa)] + writeHandshake SHDone + flip (maybe $ return Nothing) mcs $ liftM Just . \cs -> do + cc@(X509.CertificateChain (c : _)) <- readHandshake + vr <- handshakeValidate cs cc + unless (null vr) . throw ALFtl (validateAlert vr) $ + moduleName ++ ".reqAndCert: " ++ show vr + return . X509.certPubKey $ X509.getCertificate c + +certVerify :: (HandleLike h, CPRG g, ClSignPublicKey pk) => pk -> HandshakeM h g () +certVerify pk = do + debugCipherSuite . show $ cspAlgorithm pk + hs0 <- handshakeHash + DigitSigned a s <- readHandshake + case a of + (Sha256, sa) | sa == cspAlgorithm pk -> return () + _ -> throw ALFtl ADDecodeErr $ + moduleName ++ ".certVerify: not implement: " ++ show a + unless (csVerify pk s hs0) . throw ALFtl ADDecryptErr $ + moduleName ++ ".certVerify: client auth failed " + +toCheckName :: [String] -> Maybe (String -> Bool) +toCheckName [] = Nothing +toCheckName s0s = Just $ \s -> any (`toCheckName1` s) s0s + +toCheckName1 :: String -> String -> Bool +toCheckName1 = on checkSepNames $ sepBy '.' + +sepBy :: Eq a => a ->[a] -> [[a]] +sepBy x0 xs + | (t, _ : d) <- span (/= x0) xs = t : sepBy x0 d + | otherwise = [xs] + +checkSepNames :: [String] -> [String] -> Bool +checkSepNames [] [] = True +checkSepNames _ [] = False +checkSepNames [] _ = False +checkSepNames ("*" : ns0) (_ : ns) = checkSepNames ns0 ns +checkSepNames (n0 : ns0) (n : ns) = n0 == n && checkSepNames ns0 ns diff --git a/src/Network/PeyoTLS/TChan/Client.hs b/src/Network/PeyoTLS/TChan/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/TChan/Client.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE OverloadedStrings, FlexibleContexts, PackageImports #-} + +module Network.PeyoTLS.TChan.Client ( + -- * Basic + open, open', + -- * Cipher Suite + CipherSuite(..), KeyEx(..), BulkEnc(..), + -- * Others + ValidateHandle(..), CertSecretKey(..) ) where + +import Control.Applicative +import "monads-tf" Control.Monad.State +import Control.Monad.Trans.Control +import Control.Monad.Base +import Control.Concurrent +import Control.Concurrent.STM +import Data.Word +import Data.HandleLike +import Data.X509 +import Data.X509.CertificateStore +import Network.PeyoTLS.Client.Body hiding (open, open') +import qualified Network.PeyoTLS.Client.Body as C +import Network.PeyoTLS.Run.Crypto +import "crypto-random" Crypto.Random + +import qualified Data.ByteString.Char8 as BSC +import qualified Codec.Bytable.BigEndian as B + +open' :: (CPRG g, ValidateHandle h, MonadBaseControl IO (HandleMonad h)) => h -> + String -> [CipherSuite] -> [(CertSecretKey, CertificateChain)] -> + CertificateStore -> g -> + HandleMonad h (TChan BSC.ByteString, TChan BSC.ByteString) +open' h dn cs kc ca g = do + inc <- liftBase $ atomically newTChan + otc <- liftBase $ atomically newTChan + ((k, _ns), g') <- (`run'` g) $ C.open' h dn cs kc ca + liftBase $ putStrLn "" + let rk = kRKey k + rmk = kRMKey k + wk = kWKey k + wmk = kWMKey k + CipherSuite _ rcs = kRCSuite k + CipherSuite _ wcs = kWCSuite k + _ <- liftBaseDiscard forkIO . forever . (`runStateT` (g', 1)) $ do + wpln <- liftBase . atomically $ readTChan otc + (g0, sn) <- get + let hs = case wcs of + AES_128_CBC_SHA -> sha1 + AES_128_CBC_SHA256 -> sha256 + _ -> error "Network.PeyoTLS.TChan.Client.open': bad" + (wenc, g1) = encrypt hs wk wmk sn "\ETB\ETX\ETX" wpln g0 + put (g1, succ sn) + lift $ hlPut h "\ETB\ETX\ETX" + lift $ hlPut h + . (B.encode :: Word16 -> BSC.ByteString) . fromIntegral + $ BSC.length wenc + lift $ hlPut h wenc + _ <- liftBaseDiscard forkIO . forever . (`runStateT` 1) $ do + sn <- get + modify succ + pre <- lift $ hlGet h 3 + liftBase $ print pre + Right n <- B.decode <$> lift (hlGet h 2) + enc <- lift $ hlGet h n + liftBase $ print enc + let hs = case rcs of + AES_128_CBC_SHA -> sha1 + AES_128_CBC_SHA256 -> sha256 + _ -> error "Network.PeyoTLS.TChan.Client.open': bad" + Right pln = decrypt hs rk rmk sn pre enc + liftBase $ putStrLn "" + liftBase . atomically $ writeTChan inc pln + return (inc, otc) + +open :: (CPRG g, ValidateHandle h, MonadBaseControl IO (HandleMonad h)) => h -> + [CipherSuite] -> [(CertSecretKey, CertificateChain)] -> + CertificateStore -> g -> + HandleMonad h (String -> Bool, (TChan BSC.ByteString, TChan BSC.ByteString)) +open h cs kc ca g = do + inc <- liftBase $ atomically newTChan + otc <- liftBase $ atomically newTChan + ((k, ns), g') <- (`run'` g) $ C.open h cs kc ca + liftBase $ putStrLn "" + let rk = kRKey k + rmk = kRMKey k + wk = kWKey k + wmk = kWMKey k + CipherSuite _ rcs = kRCSuite k + CipherSuite _ wcs = kWCSuite k + _ <- liftBaseDiscard forkIO . (`evalStateT` (g', 1)) . forever $ do + wpln <- liftBase . atomically $ readTChan otc + (g0, sn) <- get + let hs = case wcs of + AES_128_CBC_SHA -> sha1 + AES_128_CBC_SHA256 -> sha256 + _ -> error "Network.PeyoTLS.TChan.Client.open': bad" + (wenc, g1) = encrypt hs wk wmk sn "\ETB\ETX\ETX" wpln g0 + put (g1, succ sn) + lift $ hlPut h "\ETB\ETX\ETX" + lift $ hlPut h + . (B.encode :: Word16 -> BSC.ByteString) . fromIntegral + $ BSC.length wenc + lift $ hlPut h wenc + _ <- liftBaseDiscard forkIO . (`evalStateT` 1) . forever $ do + sn <- get + modify succ + pre <- lift $ hlGet h 3 + liftBase $ print pre + Right n <- B.decode <$> lift (hlGet h 2) + enc <- lift $ hlGet h n + liftBase $ print enc + let hs = case rcs of + AES_128_CBC_SHA -> sha1 + AES_128_CBC_SHA256 -> sha256 + _ -> error "Network.PeyoTLS.TChan.Client.open': bad" + Right pln = decrypt hs rk rmk sn pre enc + liftBase $ putStrLn "" + liftBase . atomically $ writeTChan inc pln + return (toCheckName ns, (inc, otc)) diff --git a/src/Network/PeyoTLS/TChan/Server.hs b/src/Network/PeyoTLS/TChan/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/TChan/Server.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings, FlexibleContexts, PackageImports #-} + +module Network.PeyoTLS.TChan.Server ( + -- * Basic + open, + -- * Cipher Suite + CipherSuite(..), KeyEx(..), BulkEnc(..), + -- * Others + ValidateHandle(..), CertSecretKey(..) ) where + +import Control.Applicative +import "monads-tf" Control.Monad.State +import Control.Monad.Base +import Control.Monad.Trans.Control +import Control.Concurrent +import Control.Concurrent.STM +import Data.Word +import Data.HandleLike +import Data.X509 +import Data.X509.CertificateStore +import Network.PeyoTLS.Server.Body hiding (open) +import qualified Network.PeyoTLS.Server.Body as S +import Network.PeyoTLS.Run.Crypto +import "crypto-random" Crypto.Random + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Codec.Bytable.BigEndian as B + +open :: (CPRG g, ValidateHandle h, MonadBaseControl IO (HandleMonad h)) => + h -> [CipherSuite] -> [(CertSecretKey, CertificateChain)] -> + Maybe CertificateStore -> g -> + HandleMonad h ( + Maybe (String -> Bool), + (TChan BSC.ByteString, TChan BSC.ByteString)) +open h cs kcs ca g = do + inc <- liftBase $ atomically newTChan + otc <- liftBase $ atomically newTChan + ((k, ns), g') <- (`run'` g) $ do + p <- S.open h cs kcs ca + hlFlush p + let rk = kRKey k + rmk = kRMKey k + wk = kWKey k + wmk = kWMKey k + _ <- liftBaseDiscard forkIO + . (`evalStateT` 1) . forever $ do + sn <- get + modify succ + liftBase $ putStrLn $ "sn = " ++ show sn + pre <- lift $ hlGet h 3 + when (BSC.null pre) $ + lift (hlClose h) >> error "bad" + liftBase $ print pre + Right n <- B.decode <$> lift (hlGet h 2) + liftBase $ print n + renc <- lift $ hlGet h n + let Right rpln = decrypt sha1 rk rmk sn pre renc + liftBase $ do + BS.putStr rpln + atomically $ writeTChan inc rpln + + _ <- liftBaseDiscard forkIO + . (`evalStateT` (1, g')) . forever $ do + (sn, g0) <- get + wpln <- liftBase . atomically $ readTChan otc + let (wenc, g1) = + encrypt sha1 wk wmk sn "\ETB\ETX\ETX" wpln g0 + put (succ sn, g1) + lift $ hlPut h "\ETB\ETX\ETX" + lift . hlPut h + . (B.encode :: Word16 -> BSC.ByteString) + . fromIntegral $ BSC.length wenc + lift $ hlPut h wenc + + return (toCheckName ns, (inc, otc))