diff --git a/examples/renegServer.hs b/examples/renegServer.hs new file mode 100644 --- /dev/null +++ b/examples/renegServer.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings, PackageImports #-} + +import Control.Applicative +import Control.Monad +import "monads-tf" Control.Monad.State +import Control.Concurrent +import Data.HandleLike +import System.Environment +import Network +import Network.PeyoTLS.Server +import Network.PeyoTLS.ReadFile +import "crypto-random" Crypto.Random + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC + +main :: IO () +main = do + d : _ <- getArgs + k <- readKey $ d ++ "/localhost.sample_key" + c <- readCertificateChain $ d ++ "/localhost.sample_crt" + g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG + soc <- listenOn $ PortNumber 443 + void . (`runStateT` g0) . forever $ do + (h, _, _) <- liftIO $ accept soc + g <- StateT $ return . cprgFork + liftIO . forkIO . (`run` g) $ do + p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(k, c)] + Nothing + renegotiate p + doUntil BS.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn +-- renegotiate p + hlPut p $ BS.concat [ + "HTTP/1.1 200 OK\r\n", + "Transfer-Encoding: chunked\r\n", + "Content-Type: text/plain\r\n\r\n", + "5\r\nHello0\r\n\r\n" ] + hlClose p + +doUntil :: Monad m => (a -> Bool) -> m a -> m [a] +doUntil p rd = rd >>= \x -> + (if p x then return . (: []) else (`liftM` doUntil p rd) . (:)) x 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.0.0.20 +version: 0.0.0.21 stability: Experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo @@ -253,6 +253,7 @@ examples/eccServer.hs examples/eccClient.hs examples/debugServer.hs + examples/renegServer.hs data-dir: data data-files: @@ -273,22 +274,22 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/peyotls.git - tag: peyotls-0.0.0.20 + tag: peyotls-0.0.0.21 library hs-source-dirs: src exposed-modules: Network.PeyoTLS.Client, Network.PeyoTLS.Server, Network.PeyoTLS.ReadFile other-modules: - Network.PeyoTLS.HandshakeBase, - Network.PeyoTLS.HandshakeType, + Network.PeyoTLS.Base, + Network.PeyoTLS.Types, Network.PeyoTLS.Hello, Network.PeyoTLS.Extension, - Network.PeyoTLS.CipherSuite, Network.PeyoTLS.HashSignAlgorithm, + Network.PeyoTLS.CipherSuite, Network.PeyoTLS.HSAlg, Network.PeyoTLS.Certificate, - Network.PeyoTLS.HandshakeMonad, - Network.PeyoTLS.TlsHandle, - Network.PeyoTLS.TlsMonad, Network.PeyoTLS.State, - Network.PeyoTLS.CryptoTools, + Network.PeyoTLS.Run, + Network.PeyoTLS.Handle, + Network.PeyoTLS.Monad, Network.PeyoTLS.State, + Network.PeyoTLS.Crypto, Network.PeyoTLS.Ecdsa, Network.PeyoTLS.CertSecretKey build-depends: base == 4.*, word24 == 1.0.*, bytestring == 0.10.*, monads-tf == 0.1.*, diff --git a/src/Network/PeyoTLS/Base.hs b/src/Network/PeyoTLS/Base.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Base.hs @@ -0,0 +1,386 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies, PackageImports, + TupleSections #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Network.PeyoTLS.Base ( Extension(..), + PeyotlsM, eRenegoInfo, + debug, generateKs, blindSign, HM.CertSecretKey(..), isEcdsaKey, isRsaKey, + HM.TlsM, HM.run, HM.HandshakeM, HM.execHandshakeM, HM.rerunHandshakeM, + HM.withRandom, HM.randomByteString, + HM.TlsHandle, HM.names, + readHandshake, getChangeCipherSpec, + writeHandshake, putChangeCipherSpec, + writeHandshakeNH, + HM.ValidateHandle(..), HM.handshakeValidate, + HM.Alert(..), HM.AlertLevel(..), HM.AlertDesc(..), + ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..), + ServerHelloDone(..), + ClientHello(..), ServerHello(..), SessionId(..), + CipherSuite(..), KeyEx(..), BulkEnc(..), + CompMethod(..), HashAlg(..), SignAlg(..), + HM.getCipherSuite, HM.setCipherSuite, + CertificateRequest(..), certificateRequest, ClientCertificateType(..), SecretKey(..), + ClientKeyExchange(..), Epms(..), + HM.generateKeys, + HM.encryptRsa, HM.decryptRsa, HM.rsaPadding, HM.debugCipherSuite, + DigitallySigned(..), HM.handshakeHash, HM.flushCipherSuite, + HM.Side(..), HM.RW(..), finishedHash, + DhParam(..), dh3072Modp, secp256r1, HM.throwError, + HM.getClientFinished, HM.getServerFinished, + Finished(..), + HM.ContentType(CTAlert, CTHandshake, CTAppData), + Handshake(..), + HM.tlsHandle, + hlGetRn, hlGetLineRn_, hlGetLineRn, hlGetContentRn_, + hlGetContentRn, + + HM.getSettings, HM.setSettings, + HM.flushAppData_, + flushAppData, + HM.pushAdBufH, + ) where + +import Control.Applicative +import Control.Arrow (first, second, (***)) +import Control.Monad (liftM) +import "monads-tf" Control.Monad.State (gets, lift) +import qualified "monads-tf" Control.Monad.Error as E +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 Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ASN1.Types as ASN1 +import qualified Data.ASN1.Encoding as ASN1 +import qualified Data.ASN1.BinaryEncoding as ASN1 +import qualified Codec.Bytable.BigEndian as B +import qualified Crypto.Hash.SHA1 as SHA1 +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Crypto.PubKey.RSA as RSA +import qualified Crypto.PubKey.RSA.Prim as RSA +import qualified Crypto.Types.PubKey.DH as DH +import qualified Crypto.PubKey.DH as DH +import qualified Crypto.Types.PubKey.ECC as ECC +import qualified Crypto.PubKey.ECC.Prim as ECC +import qualified Crypto.Types.PubKey.ECDSA as ECDSA + +import Network.PeyoTLS.Types ( Extension(..), + Handshake(..), HandshakeItem(..), + ClientHello(..), ServerHello(..), SessionId(..), + CipherSuite(..), KeyEx(..), BulkEnc(..), + CompMethod(..), + ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..), + CertificateRequest(..), certificateRequest, ClientCertificateType(..), + SignAlg(..), HashAlg(..), + ServerHelloDone(..), ClientKeyExchange(..), Epms(..), + DigitallySigned(..), Finished(..) ) +import qualified Network.PeyoTLS.Run as HM ( + TlsM, run, HandshakeM, execHandshakeM, rerunHandshakeM, + withRandom, randomByteString, + ValidateHandle(..), handshakeValidate, + TlsHandle(..), ContentType(..), + names, + getCipherSuite, setCipherSuite, flushCipherSuite, debugCipherSuite, + tlsGetContentType, tlsGet, tlsPut, tlsPutNH, + generateKeys, encryptRsa, decryptRsa, rsaPadding, + Alert(..), AlertLevel(..), AlertDesc(..), + Side(..), RW(..), handshakeHash, finishedHash, throwError, + hlPut_, tGetLine, tGetContent, tlsGet_, tlsPut_, + tGetLine_, tGetContent_, tlsGet__, + hlDebug_, hlClose_, + getClientFinished, setClientFinished, + getServerFinished, setServerFinished, + resetSequenceNumber, + + getSettings, setSettings, + flushAppData_, + getAdBuf, + setAdBuf, + pushAdBufH, + + CertSecretKey(..), + ) +import Network.PeyoTLS.Ecdsa (blindSign, generateKs) + +-- import Network.PeyoTLS.CertSecretKey + +type PeyotlsM = HM.TlsM Handle SystemRNG + +debug :: (HandleLike h, Show a) => DebugLevel h -> a -> HM.HandshakeM h g () +debug p x = do + h <- gets $ HM.tlsHandle . fst + lift . lift . lift . hlDebug h p . BSC.pack . (++ "\n") $ show x + +readHandshake :: (HandleLike h, CPRG g, HandshakeItem hi) => HM.HandshakeM h g hi +readHandshake = do + cnt <- readContent HM.tlsGet =<< HM.tlsGetContentType + hs <- case cnt of + CHandshake HHelloReq -> readHandshake + CHandshake hs -> return hs + _ -> HM.throwError + HM.ALFatal HM.ADUnexpectedMessage $ + "HandshakeBase.readHandshake: not handshake: " ++ show cnt + case fromHandshake hs of + Just i -> return i + _ -> HM.throwError + HM.ALFatal HM.ADUnexpectedMessage $ + "HandshakeBase.readHandshake: type mismatch " ++ show hs + +writeHandshake, writeHandshakeNH :: + (HandleLike h, CPRG g, HandshakeItem hi) => hi -> HM.HandshakeM h g () +writeHandshake = uncurry HM.tlsPut . encodeContent . CHandshake . toHandshake +writeHandshakeNH = uncurry HM.tlsPutNH . encodeContent . CHandshake . toHandshake + +data ChangeCipherSpec = ChangeCipherSpec | ChangeCipherSpecRaw Word8 deriving Show + +instance B.Bytable ChangeCipherSpec where + decode bs = case BS.unpack bs of + [1] -> Right ChangeCipherSpec + [w] -> Right $ ChangeCipherSpecRaw w + _ -> Left "HandshakeBase: ChangeCipherSpec.decode" + encode ChangeCipherSpec = BS.pack [1] + encode (ChangeCipherSpecRaw w) = BS.pack [w] + +getChangeCipherSpec :: (HandleLike h, CPRG g) => HM.HandshakeM h g () +getChangeCipherSpec = do + cnt <- readContent HM.tlsGet =<< HM.tlsGetContentType + case cnt of + CCCSpec ChangeCipherSpec -> return () + _ -> HM.throwError + HM.ALFatal HM.ADUnexpectedMessage $ + "HandshakeBase.getChangeCipherSpec: " ++ + "not change cipher spec: " ++ + show cnt + HM.resetSequenceNumber HM.Read + +putChangeCipherSpec :: (HandleLike h, CPRG g) => HM.HandshakeM h g () +putChangeCipherSpec = do + uncurry HM.tlsPut . encodeContent $ CCCSpec ChangeCipherSpec + HM.resetSequenceNumber HM.Write + +data Content = CCCSpec ChangeCipherSpec | CAlert Word8 Word8 | CHandshake Handshake + deriving Show + +readContent :: Monad m => (Bool -> Int -> m BS.ByteString) -> HM.ContentType -> m Content +readContent rd HM.CTCCSpec = + (CCCSpec . either error id . B.decode) `liftM` rd True 1 +readContent rd HM.CTAlert = + ((\[al, ad] -> CAlert al ad) . BS.unpack) `liftM` rd True 2 +readContent rd HM.CTHandshake = CHandshake `liftM` do + t <- rd True 1 + len <- rd (t /= "\0") 3 +-- (t, len) <- (,) `liftM` rd True 1 `ap` rd True 3 + body <- rd True . either error id $ B.decode len + return . either error id . B.decode $ BS.concat [t, len, body] +readContent _ _ = undefined + +encodeContent :: Content -> (HM.ContentType, BS.ByteString) +encodeContent (CCCSpec ccs) = (HM.CTCCSpec, B.encode ccs) +encodeContent (CAlert al ad) = (HM.CTAlert, BS.pack [al, ad]) +encodeContent (CHandshake hss) = (HM.CTHandshake, B.encode hss) + +class SecretKey sk where + type Blinder sk + generateBlinder :: CPRG g => sk -> g -> (Blinder sk, g) + sign :: HashAlg -> Blinder sk -> sk -> BS.ByteString -> BS.ByteString + signatureAlgorithm :: sk -> SignAlg + +instance SecretKey RSA.PrivateKey where + type Blinder RSA.PrivateKey = RSA.Blinder + generateBlinder sk rng = + RSA.generateBlinder rng . RSA.public_n $ RSA.private_pub sk + sign hs bl sk bs = let + (h, oid) = first ($ bs) $ case hs of + Sha1 -> (SHA1.hash, + ASN1.OID [1, 3, 14, 3, 2, 26]) + Sha256 -> (SHA256.hash, + ASN1.OID [2, 16, 840, 1, 101, 3, 4, 2, 1]) + _ -> error $ "HandshakeBase: " ++ + "not implemented bulk encryption type" + a = [ASN1.Start ASN1.Sequence, + ASN1.Start ASN1.Sequence, + oid, ASN1.Null, ASN1.End ASN1.Sequence, + ASN1.OctetString h, ASN1.End ASN1.Sequence] + b = ASN1.encodeASN1' ASN1.DER a + pd = BS.concat [ "\x00\x01", + BS.replicate (ps - 3 - BS.length b) 0xff, "\NUL", b ] + ps = RSA.public_size $ RSA.private_pub sk in + RSA.dp (Just bl) sk pd + signatureAlgorithm _ = Rsa + +instance SecretKey ECDSA.PrivateKey where + type Blinder ECDSA.PrivateKey = Integer + generateBlinder _ rng = let + (Right bl, rng') = first B.decode $ cprgGenerate 32 rng in + (bl, rng') + sign ha bl sk = B.encode . + (($) <$> blindSign bl hs sk . generateKs (hs, bls) q x <*> id) + where + (hs, bls) = case ha of + Sha1 -> (SHA1.hash, 64) + Sha256 -> (SHA256.hash, 64) + _ -> error $ "HandshakeBase: " ++ + "not implemented bulk encryption type" + q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk + x = ECDSA.private_d sk + signatureAlgorithm _ = Ecdsa + +class DhParam b where + type Secret b + type Public b + generateSecret :: CPRG g => b -> g -> (Secret b, g) + calculatePublic :: b -> Secret b -> Public b + calculateShared :: b -> Secret b -> Public b -> BS.ByteString + +instance DhParam DH.Params where + type Secret DH.Params = DH.PrivateNumber + type Public DH.Params = DH.PublicNumber + generateSecret = flip DH.generatePrivate + calculatePublic = DH.calculatePublic + calculateShared ps sn pn = B.encode . + (\(DH.SharedKey s) -> s) $ DH.getShared ps sn pn + +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" + +instance DhParam ECC.Curve where + type Secret ECC.Curve = Integer + type Public ECC.Curve = ECC.Point + generateSecret c = getRangedInteger 32 1 (n - 1) + where n = ECC.ecc_n $ ECC.common_curve c + calculatePublic cv sn = + ECC.pointMul cv sn . ECC.ecc_g $ ECC.common_curve cv + calculateShared cv sn pp = + let ECC.Point x _ = ECC.pointMul cv sn pp in B.encode x + +getRangedInteger :: CPRG g => Int -> Integer -> Integer -> g -> (Integer, g) +getRangedInteger b mn mx g = let + (n, g') = first (either error id . B.decode) $ cprgGenerate b g in + if mn <= n && n <= mx then (n, g') else getRangedInteger b mn mx g' + +secp256r1 :: ECC.Curve +secp256r1 = ECC.getCurveByName ECC.SEC_p256r1 + +finishedHash :: (HandleLike h, CPRG g) => HM.Side -> HM.HandshakeM h g Finished +finishedHash s = (Finished `liftM`) $ do + fh <- HM.finishedHash s + case s of + HM.Client -> HM.setClientFinished fh + HM.Server -> HM.setServerFinished fh + return fh + +instance (HandleLike h, CPRG g) => HandleLike (HM.TlsHandle h g) where + type HandleMonad (HM.TlsHandle h g) = HM.TlsM h g + type DebugLevel (HM.TlsHandle h g) = DebugLevel h + hlPut = HM.hlPut_ + hlGet = (.) <$> checkAppData <*> ((fst `liftM`) .) + . HM.tlsGet__ . (, undefined) + hlGetLine = ($) <$> checkAppData <*> HM.tGetLine + hlGetContent = ($) <$> checkAppData <*> HM.tGetContent + hlDebug = HM.hlDebug_ + hlClose = HM.hlClose_ + +checkAppData :: (HandleLike h, CPRG g) => HM.TlsHandle h g -> + HM.TlsM h g (HM.ContentType, BS.ByteString) -> HM.TlsM h g BS.ByteString +checkAppData t m = m >>= \cp -> case cp of + (HM.CTAppData, ad) -> return ad + (HM.CTAlert, "\SOH\NUL") -> do + _ <- HM.tlsPut_ (t, undefined) HM.CTAlert "\SOH\NUL" + E.throwError "TlsHandle.checkAppData: EOF" + (HM.CTHandshake, hs) -> do + lift . lift $ hlDebug (HM.tlsHandle t) "critical" "renegotiation?\n" + lift . lift . hlDebug (HM.tlsHandle t) "critical" . BSC.pack + . (++ "\n") $ show hs + lift . lift . hlDebug (HM.tlsHandle t) "critical" . BSC.pack + . (++ "\n") $ show (B.decode hs :: Either String Handshake) + return "" + _ -> do _ <- HM.tlsPut_ (t, undefined) HM.CTAlert "\2\10" + E.throwError "TlsHandle.checkAppData: not application data" + +hlGetRn_ :: (HM.ValidateHandle h, CPRG g) => (HM.TlsHandle h g -> HM.TlsM h g ()) -> + HM.TlsHandle h g -> Int -> HM.TlsM h g BS.ByteString +hlGetRn_ rh = (.) <$> checkAppData <*> ((fst `liftM`) .) . HM.tlsGet_ rh + . (, undefined) + +hlGetLineRn_, hlGetContentRn_ :: (HM.ValidateHandle h, CPRG g) => + (HM.TlsHandle h g -> HM.TlsM h g ()) -> HM.TlsHandle h g -> HM.TlsM h g BS.ByteString +hlGetLineRn_ rh = ($) <$> checkAppData <*> HM.tGetLine_ rh +hlGetContentRn_ rh = ($) <$> checkAppData <*> HM.tGetContent_ rh + +hlGetRn :: (HM.ValidateHandle h, CPRG g) => (HM.TlsHandle h g -> HM.TlsM h g ()) -> + HM.TlsHandle h g -> Int -> HM.TlsM h g BS.ByteString +hlGetRn rn t n = do + bf <- HM.getAdBuf t + if BS.length bf >= n + then do let (ret, rest) = BS.splitAt n bf + HM.setAdBuf t rest + return ret + else (bf `BS.append`) `liftM` hlGetRn_ rn t (n - BS.length bf) + +hlGetLineRn :: (HM.ValidateHandle h, CPRG g) => + (HM.TlsHandle h g -> HM.TlsM h g ()) -> HM.TlsHandle h g -> + HM.TlsM h g BS.ByteString +hlGetLineRn rn t = do + bf <- HM.getAdBuf t + if '\n' `BSC.elem` bf || '\r' `BSC.elem` bf + then do let (ret, rest) = splitOneLine bf + HM.setAdBuf t $ BS.tail rest + return ret + else (bf `BS.append`) `liftM` hlGetLineRn_ rn t + +splitOneLine :: BS.ByteString -> (BS.ByteString, BS.ByteString) +splitOneLine bs = case BSC.span (/= '\r') bs of + (_, "") -> second BS.tail $ BSC.span (/= '\n') bs + (l, ls) -> (l, dropRet ls) + +dropRet :: BS.ByteString -> BS.ByteString +dropRet bs = case BSC.uncons bs of + Just ('\r', bs') -> case BSC.uncons bs' of + Just ('\n', bs'') -> bs'' + _ -> bs' + _ -> bs + +hlGetContentRn :: (HM.ValidateHandle h, CPRG g) => + (HM.TlsHandle h g -> HM.TlsM h g ()) -> + HM.TlsHandle h g -> HM.TlsM h g BS.ByteString +hlGetContentRn rn t = do + bf <- HM.getAdBuf t + if BS.null bf + then hlGetContentRn_ rn t + else do HM.setAdBuf t "" + return bf + +flushAppData :: (HandleLike h, CPRG g) => HM.HandshakeM h g Bool +flushAppData = uncurry (>>) . (HM.pushAdBufH *** return) =<< HM.flushAppData_ + +isEcdsaKey :: HM.CertSecretKey -> Bool +isEcdsaKey (HM.EcdsaKey _) = True +isEcdsaKey _ = False + +isRsaKey :: HM.CertSecretKey -> Bool +isRsaKey (HM.RsaKey _) = True +isRsaKey _ = False + +eRenegoInfo :: Extension -> Maybe BS.ByteString +eRenegoInfo (ERenegoInfo ri) = Just ri +eRenegoInfo _ = Nothing diff --git a/src/Network/PeyoTLS/CertSecretKey.hs b/src/Network/PeyoTLS/CertSecretKey.hs --- a/src/Network/PeyoTLS/CertSecretKey.hs +++ b/src/Network/PeyoTLS/CertSecretKey.hs @@ -3,5 +3,7 @@ import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -data CertSecretKey = RsaKey RSA.PrivateKey | EcdsaKey ECDSA.PrivateKey +data CertSecretKey + = RsaKey { rsaKey :: RSA.PrivateKey } + | EcdsaKey { ecdsaKey :: ECDSA.PrivateKey } deriving Show diff --git a/src/Network/PeyoTLS/Certificate.hs b/src/Network/PeyoTLS/Certificate.hs --- a/src/Network/PeyoTLS/Certificate.hs +++ b/src/Network/PeyoTLS/Certificate.hs @@ -17,7 +17,7 @@ import qualified Data.X509.CertificateStore as X509 import qualified Codec.Bytable.BigEndian as B -import Network.PeyoTLS.HashSignAlgorithm (HashAlg, SignAlg) +import Network.PeyoTLS.HSAlg (HashAlg, SignAlg) instance B.Bytable X509.CertificateChain where decode = B.evalBytableM B.parse diff --git a/src/Network/PeyoTLS/CipherSuite.hs b/src/Network/PeyoTLS/CipherSuite.hs --- a/src/Network/PeyoTLS/CipherSuite.hs +++ b/src/Network/PeyoTLS/CipherSuite.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Network.PeyoTLS.CipherSuite ( - CipherSuite(..), KeyExchange(..), BulkEncryption(..)) where + CipherSuite(..), KeyEx(..), BulkEnc(..)) where import Control.Arrow (first, (***)) import Data.Word (Word8) @@ -11,12 +11,12 @@ import qualified Codec.Bytable.BigEndian as B data CipherSuite - = CipherSuite KeyExchange BulkEncryption - | TLS_EMPTY_RENEGOTIATION_INFO_SCSV + = CipherSuite KeyEx BulkEnc + | EMPTY_RENEGOTIATION_INFO | CipherSuiteRaw Word8 Word8 deriving (Show, Read, Eq) -data KeyExchange +data KeyEx = RSA | DHE_RSA | ECDHE_RSA @@ -25,7 +25,7 @@ | KE_NULL deriving (Show, Read, Eq) -data BulkEncryption +data BulkEnc = AES_128_CBC_SHA | AES_128_CBC_SHA256 -- | CAMELLIA_128_CBC_SHA @@ -48,7 +48,7 @@ (0x00, 0x3c) -> CipherSuite RSA AES_128_CBC_SHA256 -- (0x00, 0x45) -> CipherSuite DHE_RSA CAMELLIA_128_CBC_SHA (0x00, 0x67) -> CipherSuite DHE_RSA AES_128_CBC_SHA256 - (0x00, 0xff) -> TLS_EMPTY_RENEGOTIATION_INFO_SCSV + (0x00, 0xff) -> EMPTY_RENEGOTIATION_INFO (0xc0, 0x09) -> CipherSuite ECDHE_ECDSA AES_128_CBC_SHA (0xc0, 0x13) -> CipherSuite ECDHE_RSA AES_128_CBC_SHA (0xc0, 0x23) -> CipherSuite ECDHE_ECDSA AES_128_CBC_SHA256 @@ -64,7 +64,7 @@ encodeCipherSuite (CipherSuite RSA AES_128_CBC_SHA256) = "\x00\x3c" -- encodeCipherSuite (CipherSuite DHE_RSA CAMELLIA_128_CBC_SHA) = "\x00\x45" encodeCipherSuite (CipherSuite DHE_RSA AES_128_CBC_SHA256) = "\x00\x67" -encodeCipherSuite TLS_EMPTY_RENEGOTIATION_INFO_SCSV = "\x00\xff" +encodeCipherSuite EMPTY_RENEGOTIATION_INFO = "\x00\xff" encodeCipherSuite (CipherSuite ECDHE_ECDSA AES_128_CBC_SHA) = "\xc0\x09" encodeCipherSuite (CipherSuite ECDHE_RSA AES_128_CBC_SHA) = "\xc0\x13" encodeCipherSuite (CipherSuite ECDHE_ECDSA AES_128_CBC_SHA256) = "\xc0\x23" 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,14 +1,15 @@ {-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, - UndecidableInstances, PackageImports, ScopedTypeVariables #-} + PackageImports, ScopedTypeVariables #-} module Network.PeyoTLS.Client ( PeyotlsM, PeyotlsHandleC, TlsM, TlsHandleC, run, open, renegotiate, names, - CipherSuite(..), KeyExchange(..), BulkEncryption(..), + CipherSuite(..), KeyEx(..), BulkEnc(..), ValidateHandle(..), CertSecretKey ) where import Control.Applicative ((<$>), (<*>)) +import Control.Arrow (first) import Control.Monad (when, unless, liftM) import Data.List (find, intersect) import Data.HandleLike (HandleLike(..)) @@ -32,25 +33,23 @@ import qualified Crypto.Types.PubKey.ECC as ECC import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Network.PeyoTLS.HandshakeBase as HB -import Network.PeyoTLS.HandshakeBase ( flushAppData, - Extension(..), getClientFinished, Finished(..), - getInitSet, setInitSet, - setClientFinished, getClientFinished, - setServerFinished, getServerFinished, - PeyotlsM, PeyotlsHandle, +import qualified Network.PeyoTLS.Base as HB +import Network.PeyoTLS.Base ( flushAppData, + Extension(..), getClientFinished, + getSettings, setSettings, + getClientFinished, getServerFinished, + PeyotlsM, TlsM, run, HandshakeM, execHandshakeM, rerunHandshakeM, CertSecretKey(..), withRandom, randomByteString, TlsHandle, readHandshake, getChangeCipherSpec, - readHandshakeNoHash, writeHandshake, putChangeCipherSpec, ValidateHandle(..), handshakeValidate, ServerKeyExEcdhe(..), ServerKeyExDhe(..), ServerHelloDone(..), ClientHello(..), ServerHello(..), SessionId(..), - CipherSuite(..), KeyExchange(..), BulkEncryption(..), - CompressionMethod(..), HashAlg(..), SignAlg(..), + CipherSuite(..), KeyEx(..), BulkEnc(..), + CompMethod(..), HashAlg(..), SignAlg(..), setCipherSuite, CertificateRequest(..), ClientCertificateType(..), ClientKeyExchange(..), Epms(..), @@ -69,32 +68,37 @@ [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore -> TlsM h g (TlsHandleC h g) open h cscl crts ca = (TlsHandleC `liftM`) . execHandshakeM h $ do - setInitSet (cscl, crts, Just ca) + setSettings (cscl, rcrt, ecrt, Just ca) cr <- clientHello cscl - handshake crts ca cr + handshake rcrt ecrt ca cr + where + rcrt = first rsaKey <$> find (HB.isRsaKey . fst) crts + ecrt = first ecdsaKey <$> find (HB.isEcdsaKey . fst) crts renegotiate :: (ValidateHandle h, CPRG g) => TlsHandleC h g -> TlsM h g () renegotiate (TlsHandleC t) = rerunHandshakeM t $ do - (cscl, crts, Just ca) <- getInitSet + (cscl, rcrt, ecrt, Just ca) <- getSettings cr <- clientHello cscl - (ret, ne) <- flushAppData - bf <- HB.getAdBufH - HB.setAdBufH $ bf `BS.append` ret - when ne $ handshake crts ca cr + HB.debug "critical" ("CLIENT HASH AFTER CLIENTHELLO" :: String) + HB.debug "critical" =<< handshakeHash + ne <- flushAppData + when ne $ handshake rcrt ecrt ca cr rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g () rehandshake t = rerunHandshakeM t $ do - (cscl, crts, Just ca) <- getInitSet + (cscl, rcrt, ecrt, Just ca) <- getSettings cr <- clientHello cscl - handshake crts ca cr - return () + handshake rcrt ecrt ca cr handshake :: (ValidateHandle h, CPRG g) => - [(CertSecretKey, X509.CertificateChain)] -> + Maybe (RSA.PrivateKey, X509.CertificateChain) -> + Maybe (ECDSA.PrivateKey, X509.CertificateChain) -> X509.CertificateStore -> BS.ByteString -> HandshakeM h g () -handshake crts ca cr = do +handshake rcrt ecrt ca cr = do (sr, cs@(CipherSuite ke _)) <- serverHello setCipherSuite cs + HB.debug "critical" ("CLIENT HASH AFTER SERVERHELLO" :: String) + HB.debug "critical" =<< handshakeHash case ke of RSA -> rsaHandshake cr sr crts ca DHE_RSA -> dheHandshake dhType cr sr crts ca @@ -104,6 +108,12 @@ where dhType :: DH.Params; dhType = undefined curveType :: ECC.Curve; curveType = undefined + crts = case (rcrt, ecrt) of + (Just (rsk, rcc), Just (esk, ecc)) -> [ + (RsaKey rsk, rcc), (EcdsaKey esk, ecc)] + (Just (rsk, rcc), _) -> [(RsaKey rsk, rcc)] + (_, Just (esk, ecc)) -> [(EcdsaKey esk, ecc)] + _ -> [] getRenegoInfo :: Maybe [Extension] -> Maybe BS.ByteString getRenegoInfo Nothing = Nothing @@ -117,7 +127,7 @@ cr <- randomByteString 32 cf <- getClientFinished writeHandshake . ClientHello (3, 3) cr (SessionId "") cscl - [CompressionMethodNull] $ Just [ERenegoInfo cf] + [CompMethodNull] $ Just [ERenegoInfo cf] return cr serverHello :: (HandleLike h, CPRG g) => @@ -271,12 +281,10 @@ writeHandshake $ digitallySigned sk (pubKey sk c) hs _ -> return () putChangeCipherSpec >> flushCipherSuite Write - fc@(Finished fcb) <- finishedHash Client + fc <- finishedHash Client writeHandshake fc - setClientFinished fcb getChangeCipherSpec >> flushCipherSuite Read - fs@(Finished fsb) <- finishedHash Server - setServerFinished fsb + fs <- finishedHash Server (fs ==) `liftM` readHandshake >>= flip unless (E.throwError "TlsClient.finishHandshake: finished hash failure") where @@ -312,42 +320,13 @@ newtype TlsHandleC h g = TlsHandleC { tlsHandleC :: TlsHandle h g } instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandleC h g) where - type HandleMonad (TlsHandleC h g) = HandleMonad (TlsHandle h g) - type DebugLevel (TlsHandleC h g) = DebugLevel (TlsHandle h g) + type HandleMonad (TlsHandleC h g) = TlsM h g + type DebugLevel (TlsHandleC h g) = DebugLevel h hlPut (TlsHandleC t) = hlPut t - hlGet = hlGet_ -- hlGetRn rehandshake . tlsHandleC - hlGetLine = hlGetLine_ -- hlGetLineRn rehandshake . tlsHandleC - hlGetContent = hlGetContent_ -- hlGetContentRn rehandshake . tlsHandleC + hlGet = hlGetRn rehandshake . tlsHandleC + hlGetLine = hlGetLineRn rehandshake . tlsHandleC + hlGetContent = hlGetContentRn rehandshake . tlsHandleC hlDebug (TlsHandleC t) = hlDebug t hlClose (TlsHandleC t) = hlClose t - -hlGet_ :: (ValidateHandle h, CPRG g) => - TlsHandleC h g -> Int -> TlsM h g BS.ByteString -hlGet_ (TlsHandleC t) n = do - bf <- HB.getAdBuf t - if (BS.length bf >= 0) - then do let (ret, rest) = BS.splitAt n bf - HB.setAdBuf t rest - return ret - else (bf `BS.append`) `liftM` hlGetRn rehandshake t (n - BS.length bf) - -hlGetLine_ :: (ValidateHandle h, CPRG g) => - TlsHandleC h g -> TlsM h g BS.ByteString -hlGetLine_ (TlsHandleC t) = do - bf <- HB.getAdBuf t - if (10 `BS.elem` bf) - then do let (ret, rest) = BS.span (/= 10) bf - HB.setAdBuf t $ BS.tail rest - return ret - else (bf `BS.append`) `liftM` hlGetLineRn rehandshake t - -hlGetContent_ :: (ValidateHandle h, CPRG g) => - TlsHandleC h g -> TlsM h g BS.ByteString -hlGetContent_ (TlsHandleC t) = do - bf <- HB.getAdBuf t - if BS.null bf - then hlGetContentRn rehandshake t - else do HB.setAdBuf t "" - return bf type PeyotlsHandleC = TlsHandleC Handle SystemRNG diff --git a/src/Network/PeyoTLS/Crypto.hs b/src/Network/PeyoTLS/Crypto.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Crypto.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings, PackageImports, TupleSections #-} + +module Network.PeyoTLS.Crypto ( + makeKeys, encrypt, decrypt, hashSha1, hashSha256, finishedHash) where + +import Prelude hiding (splitAt, take) + +import Control.Arrow (first) +import Data.Bits (xor) +import Data.Word (Word8, Word16, Word64) +import "crypto-random" Crypto.Random (CPRG, cprgGenerate) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import qualified Crypto.Hash.SHA1 as SHA1 +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Crypto.Cipher.AES as AES + +import qualified Codec.Bytable.BigEndian as B + +makeKeys :: Int -> BS.ByteString -> BS.ByteString -> BS.ByteString -> + (BS.ByteString, BS.ByteString, BS.ByteString, BS.ByteString, BS.ByteString) +makeKeys kl cr sr pms = let + kls = [kl, kl, 16, 16] + ms = take 48 . prf pms $ BS.concat ["master secret", cr, sr] + ems = prf ms $ BS.concat ["key expansion", sr, cr] + [cwmk, swmk, cwk, swk] = divide kls ems in + (ms, cwmk, swmk, cwk, swk) + where + divide [] _ = [] + divide (n : ns) bs + | BSL.null bs = [] + | otherwise = let (x, bs') = splitAt n bs in x : divide ns bs' + +prf :: BS.ByteString -> BS.ByteString -> BSL.ByteString +prf sk sd = BSL.fromChunks . ph $ hm sk sd + where + hm = hmac SHA256.hash 64 + ph a = hm sk (a `BS.append` sd) : ph (hm sk a) + +hmac :: (BS.ByteString -> BS.ByteString) -> Int -> + BS.ByteString -> BS.ByteString -> BS.ByteString +hmac hs bls sk = + hs . BS.append (BS.map (0x5c `xor`) k) . + hs . BS.append (BS.map (0x36 `xor`) k) + where + k = pd $ if BS.length sk > bls then hs sk else sk + pd bs = bs `BS.append` BS.replicate (bls - BS.length bs) 0 + +type Hash = BS.ByteString -> BS.ByteString + +hashSha1, hashSha256 :: (Hash, Int) +hashSha1 = (SHA1.hash, 20) +hashSha256 = (SHA256.hash, 32) + +encrypt :: CPRG g => (Hash, Int) -> BS.ByteString -> BS.ByteString -> Word64 -> + BS.ByteString -> BS.ByteString -> g -> (BS.ByteString, g) +encrypt (hs, _) k mk sn p m g = (, g') $ + iv `BS.append` AES.encryptCBC (AES.initAES k) iv (pln `BS.append` pd) + where + (iv, g') = cprgGenerate 16 g + pln = m `BS.append` calcMac hs mk sn (p `BS.append` B.addLen w16 m) + l = 16 - (BS.length pln + 1) `mod` 16 + pd = BS.replicate (l + 1) $ fromIntegral l + +decrypt :: (Hash, Int) -> + BS.ByteString -> BS.ByteString -> Word64 -> + BS.ByteString -> BS.ByteString -> Either String BS.ByteString +decrypt (hs, ml) k mk sn p enc = if rm == em then Right b else Left $ if BS.null enc + then "CryptoTools.decrypt: enc is null\n" + else "CryptoTools.decrypt: bad MAC:" ++ + "\n\tsn: " ++ show sn ++ + "\n\tplain: " ++ BSC.unpack pln ++ + "\n\tExpected: " ++ BSC.unpack em ++ + "\n\tRecieved: " ++ BSC.unpack rm ++ + "\n\tml: " ++ show ml ++ "\n" + where + pln = uncurry (AES.decryptCBC $ AES.initAES k) $ BS.splitAt 16 enc + up = BS.take (BS.length pln - fromIntegral (myLast "decrypt" pln) - 1) pln + (b, rm) = BS.splitAt (BS.length up - ml) up + em = calcMac hs mk sn $ p `BS.append` B.addLen w16 b + +calcMac :: Hash -> BS.ByteString -> Word64 -> BS.ByteString -> BS.ByteString +calcMac hs mk sn m = hmac hs 64 mk $ B.encode sn `BS.append` m + +finishedHash :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString +finishedHash c ms hash = take 12 . prf ms . (`BS.append` hash) $ if c + then "client finished" + else "server finished" + +myLast :: String -> BS.ByteString -> Word8 +myLast msg "" = error msg +myLast _ bs = BS.last bs + +take :: Int -> BSL.ByteString -> BS.ByteString +take = (fst .) . splitAt + +splitAt :: Int -> BSL.ByteString -> (BS.ByteString, BSL.ByteString) +splitAt n = first BSL.toStrict . BSL.splitAt (fromIntegral n) + +w16 :: Word16; w16 = undefined diff --git a/src/Network/PeyoTLS/CryptoTools.hs b/src/Network/PeyoTLS/CryptoTools.hs deleted file mode 100644 --- a/src/Network/PeyoTLS/CryptoTools.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE OverloadedStrings, PackageImports, TupleSections #-} - -module Network.PeyoTLS.CryptoTools ( - makeKeys, encrypt, decrypt, hashSha1, hashSha256, finishedHash) where - -import Prelude hiding (splitAt, take) - -import Control.Arrow (first) -import Data.Bits (xor) -import Data.Word (Word8, Word16, Word64) -import "crypto-random" Crypto.Random (CPRG, cprgGenerate) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.Lazy as BSL -import qualified Crypto.Hash.SHA1 as SHA1 -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Crypto.Cipher.AES as AES - -import qualified Codec.Bytable.BigEndian as B - -makeKeys :: Int -> BS.ByteString -> BS.ByteString -> BS.ByteString -> - (BS.ByteString, BS.ByteString, BS.ByteString, BS.ByteString, BS.ByteString) -makeKeys kl cr sr pms = let - kls = [kl, kl, 16, 16] - ms = take 48 . prf pms $ BS.concat ["master secret", cr, sr] - ems = prf ms $ BS.concat ["key expansion", sr, cr] - [cwmk, swmk, cwk, swk] = divide kls ems in - (ms, cwmk, swmk, cwk, swk) - where - divide [] _ = [] - divide (n : ns) bs - | BSL.null bs = [] - | otherwise = let (x, bs') = splitAt n bs in x : divide ns bs' - -prf :: BS.ByteString -> BS.ByteString -> BSL.ByteString -prf sk sd = BSL.fromChunks . ph $ hm sk sd - where - hm = hmac SHA256.hash 64 - ph a = hm sk (a `BS.append` sd) : ph (hm sk a) - -hmac :: (BS.ByteString -> BS.ByteString) -> Int -> - BS.ByteString -> BS.ByteString -> BS.ByteString -hmac hs bls sk = - hs . BS.append (BS.map (0x5c `xor`) k) . - hs . BS.append (BS.map (0x36 `xor`) k) - where - k = pd $ if BS.length sk > bls then hs sk else sk - pd bs = bs `BS.append` BS.replicate (bls - BS.length bs) 0 - -type Hash = BS.ByteString -> BS.ByteString - -hashSha1, hashSha256 :: (Hash, Int) -hashSha1 = (SHA1.hash, 20) -hashSha256 = (SHA256.hash, 32) - -encrypt :: CPRG g => (Hash, Int) -> BS.ByteString -> BS.ByteString -> Word64 -> - BS.ByteString -> BS.ByteString -> g -> (BS.ByteString, g) -encrypt (hs, _) k mk sn p m g = (, g') $ - iv `BS.append` AES.encryptCBC (AES.initAES k) iv (pln `BS.append` pd) - where - (iv, g') = cprgGenerate 16 g - pln = m `BS.append` calcMac hs mk sn (p `BS.append` B.addLen w16 m) - l = 16 - (BS.length pln + 1) `mod` 16 - pd = BS.replicate (l + 1) $ fromIntegral l - -decrypt :: (Hash, Int) -> - BS.ByteString -> BS.ByteString -> Word64 -> - BS.ByteString -> BS.ByteString -> Either String BS.ByteString -decrypt (hs, ml) k mk sn p enc = if rm == em then Right b else Left $ if BS.null enc - then "CryptoTools.decrypt: enc is null\n" - else "CryptoTools.decrypt: bad MAC:" ++ - "\n\tsn: " ++ show sn ++ - "\n\tplain: " ++ BSC.unpack pln ++ - "\n\tExpected: " ++ BSC.unpack em ++ - "\n\tRecieved: " ++ BSC.unpack rm ++ - "\n\tml: " ++ show ml ++ "\n" - where - pln = uncurry (AES.decryptCBC $ AES.initAES k) $ BS.splitAt 16 enc - up = BS.take (BS.length pln - fromIntegral (myLast "decrypt" pln) - 1) pln - (b, rm) = BS.splitAt (BS.length up - ml) up - em = calcMac hs mk sn $ p `BS.append` B.addLen w16 b - -calcMac :: Hash -> BS.ByteString -> Word64 -> BS.ByteString -> BS.ByteString -calcMac hs mk sn m = hmac hs 64 mk $ B.encode sn `BS.append` m - -finishedHash :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString -finishedHash c ms hash = take 12 . prf ms . (`BS.append` hash) $ if c - then "client finished" - else "server finished" - -myLast :: String -> BS.ByteString -> Word8 -myLast msg "" = error msg -myLast _ bs = BS.last bs - -take :: Int -> BSL.ByteString -> BS.ByteString -take = (fst .) . splitAt - -splitAt :: Int -> BSL.ByteString -> (BS.ByteString, BSL.ByteString) -splitAt n = first BSL.toStrict . BSL.splitAt (fromIntegral n) - -w16 :: Word16; w16 = undefined diff --git a/src/Network/PeyoTLS/Extension.hs b/src/Network/PeyoTLS/Extension.hs --- a/src/Network/PeyoTLS/Extension.hs +++ b/src/Network/PeyoTLS/Extension.hs @@ -12,7 +12,7 @@ import qualified Crypto.Types.PubKey.DH as DH import qualified Crypto.Types.PubKey.ECC as ECC -import Network.PeyoTLS.HashSignAlgorithm(HashAlg(..), SignAlg(..)) +import Network.PeyoTLS.HSAlg(HashAlg(..), SignAlg(..)) data Extension = ESName [ServerName] diff --git a/src/Network/PeyoTLS/HSAlg.hs b/src/Network/PeyoTLS/HSAlg.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/HSAlg.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.PeyoTLS.HSAlg (SignAlg(..), HashAlg(..)) where + +import Data.Word (Word8) + +import qualified Data.ByteString as BS +import qualified Codec.Bytable.BigEndian as B + +data HashAlg = Sha1 | Sha224 | Sha256 | Sha384 | Sha512 | HARaw Word8 + deriving Show + +instance B.Bytable HashAlg where + encode Sha1 = "\x02" + encode Sha224 = "\x03" + encode Sha256 = "\x04" + encode Sha384 = "\x05" + encode Sha512 = "\x06" + encode (HARaw w) = BS.pack [w] + decode bs = case BS.unpack bs of + [ha] -> Right $ case ha of + 2 -> Sha1 ; 3 -> Sha224; 4 -> Sha256 + 5 -> Sha384; 6 -> Sha512; _ -> HARaw ha + _ -> Left "HashSignAlgorithm: Bytable.decode" + +instance B.Parsable HashAlg where + parse = B.take 1 + +data SignAlg = Rsa | Dsa | Ecdsa | SARaw Word8 deriving (Show, Eq) + +instance B.Bytable SignAlg where + encode Rsa = "\x01" + encode Dsa = "\x02" + encode Ecdsa = "\x03" + encode (SARaw w) = BS.pack [w] + decode bs = case BS.unpack bs of + [sa] -> Right $ case sa of + 1 -> Rsa; 2 -> Dsa; 3 -> Ecdsa; _ -> SARaw sa + _ -> Left "Type.decodeSA" + +instance B.Parsable SignAlg where + parse = B.take 1 diff --git a/src/Network/PeyoTLS/Handle.hs b/src/Network/PeyoTLS/Handle.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Handle.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, PackageImports #-} + +module Network.PeyoTLS.Handle ( + TlsM, Alert(..), AlertLevel(..), AlertDesc(..), + run, withRandom, randomByteString, + TlsHandle(..), RW(..), Side(..), ContentType(..), CipherSuite(..), + newHandle, getContentType, tlsGet, tlsPut, generateKeys, + debugCipherSuite, + getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt, + setKeys, + handshakeHash, finishedHash, + hlPut_, hlDebug_, hlClose_, tGetLine, tGetLine_, tGetContent, + getClientFinishedT, setClientFinishedT, + getServerFinishedT, setServerFinishedT, + + getInitSetT, setInitSetT, + InitialSettings, + + resetSequenceNumber, + tlsGet_, + flushAppData, + + getAdBufT, setAdBufT, + CertSecretKey(..), + ) where + +import Prelude hiding (read) + +import Control.Arrow (second) +import Control.Monad (liftM, when, unless) +import "monads-tf" Control.Monad.State (get, put, lift) +import "monads-tf" Control.Monad.Error (throwError, catchError) +import "monads-tf" Control.Monad.Error.Class (strMsg) +import Data.Word (Word16, Word64) +import Data.HandleLike (HandleLike(..)) +import "crypto-random" Crypto.Random (CPRG) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Codec.Bytable.BigEndian as B +import qualified Crypto.Hash.SHA256 as SHA256 + +import Network.PeyoTLS.Monad ( + TlsM, evalTlsM, initState, thlGet, thlPut, thlClose, thlDebug, + withRandom, randomByteString, + getBuf, setBuf, getWBuf, setWBuf, + getAdBuf, setAdBuf, + getReadSn, getWriteSn, succReadSn, succWriteSn, + resetReadSn, resetWriteSn, + getCipherSuiteSt, setCipherSuiteSt, + flushCipherSuiteRead, flushCipherSuiteWrite, getKeys, setKeys, + Alert(..), AlertLevel(..), AlertDesc(..), + ContentType(..), CipherSuite(..), BulkEnc(..), + PartnerId, newPartnerId, Keys(..), + getClientFinished, setClientFinished, + getServerFinished, setServerFinished, + InitialSettings, + getInitSet, setInitSet, + CertSecretKey(..), + ) +import qualified Network.PeyoTLS.Crypto as CT ( + makeKeys, encrypt, decrypt, hashSha1, hashSha256, finishedHash ) + +data TlsHandle h g = TlsHandle { + clientId :: PartnerId, + tlsHandle :: h, + names :: [String] } + deriving Show + +type HandleHash h g = (TlsHandle h g, SHA256.Ctx) + +data Side = Server | Client deriving (Show, Eq) + +run :: HandleLike h => TlsM h g a -> g -> HandleMonad h a +run m g = do + ret <- (`evalTlsM` initState g) $ m `catchError` \a -> throwError a + case ret of + Right r -> return r + Left a -> error $ show a + +newHandle :: HandleLike h => h -> TlsM h g (TlsHandle h g) +newHandle h = do + s <- get + let (i, s') = newPartnerId s + put s' + return TlsHandle { + clientId = i, tlsHandle = h, names = [] } + +getContentType :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g ContentType +getContentType t = do + ct <- fst `liftM` getBuf (clientId t) + (\gt -> case ct of CTNull -> gt; _ -> return ct) $ do + (ct', bf) <- getWholeWithCt t + setBuf (clientId t) (ct', bf) + return ct' + +flushAppData :: (HandleLike h, CPRG g) => + TlsHandle h g -> TlsM h g (BS.ByteString, Bool) +flushAppData t = do + ct <- getContentType t + case ct of + CTAppData -> do + (_, ad) <- tGetContent t + (bs, b) <- flushAppData t + return (ad `BS.append` bs, b) +-- liftM (BS.append . snd) (tGetContent t) `ap` flushAppData t + CTAlert -> do + ((_, a), _) <- tlsGet True (t, undefined) 2 + case a of + "\1\0" -> return ("", False) + _ -> throwError "flushAppData" + _ -> return ("", True) + +tlsGet :: (HandleLike h, CPRG g) => Bool -> HandleHash h g -> + Int -> TlsM h g ((ContentType, BS.ByteString), HandleHash h g) +tlsGet b hh@(t, _) n = do + r@(ct, bs) <- buffered t n + (r ,) `liftM` case (ct, b, bs) of + (CTHandshake, _, "\0") -> return hh + (CTHandshake, True, _) + | "\0\0\0\0" `BS.isPrefixOf` bs -> + updateHash hh $ BS.drop 4 bs + | otherwise -> updateHash hh bs + _ -> return hh + +tlsGet_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) -> + HandleHash h g -> Int -> + TlsM h g ((ContentType, BS.ByteString), HandleHash h g) +tlsGet_ rn hh@(t, _) n = (, hh) `liftM` buffered_ rn t n + +buffered :: (HandleLike h, CPRG g) => + TlsHandle h g -> Int -> TlsM h g (ContentType, BS.ByteString) +buffered t n = do + (ct, b) <- getBuf $ clientId t; let rl = n - BS.length b + if rl <= 0 + then splitRetBuf t n ct b + else do (ct', b') <- getWholeWithCt t + unless (ct' == ct) . throwError . strMsg $ + "Content Type confliction\n" ++ + "\tExpected: " ++ show ct ++ "\n" ++ + "\tActual : " ++ show ct' ++ "\n" ++ + "\tData : " ++ show b' + when (BS.null b') $ throwError "buffered: No data available" + setBuf (clientId t) (ct', b') + second (b `BS.append`) `liftM` buffered t rl + +buffered_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) -> + TlsHandle h g -> Int -> TlsM h g (ContentType, BS.ByteString) +buffered_ rn t n = do + ct0 <- getContentType t + case ct0 of + CTHandshake -> rn t >> buffered_ rn t n + _ -> do (ct, b) <- getBuf $ clientId t; let rl = n - BS.length b + if rl <= 0 + then splitRetBuf t n ct b + else do (ct', b') <- getWholeWithCt t + unless (ct' == ct) . throwError . strMsg $ + "Content Type confliction\n" + when (BS.null b') $ throwError "buffered: No data" + setBuf (clientId t) (ct', b') + second (b `BS.append`) `liftM` buffered_ rn t rl + +splitRetBuf :: HandleLike h => + TlsHandle h g -> Int -> ContentType -> BS.ByteString -> + TlsM h g (ContentType, BS.ByteString) +splitRetBuf t n ct b = do + let (ret, b') = BS.splitAt n b + setBuf (clientId t) $ if BS.null b' then (CTNull, "") else (ct, b') + return (ct, ret) + +getWholeWithCt :: (HandleLike h, CPRG g) => + TlsHandle h g -> TlsM h g (ContentType, BS.ByteString) +getWholeWithCt t = do + flush t + ct <- (either (throwError . strMsg) return . B.decode) =<< read t 1 + [_vmj, _vmn] <- BS.unpack `liftM` read t 2 + e <- read t =<< either (throwError . strMsg) return . B.decode =<< read t 2 + when (BS.null e) $ throwError "TlsHandle.getWholeWithCt: e is null" + p <- decrypt t ct e + thlDebug (tlsHandle t) "medium" . BSC.pack . (++ ": ") $ show ct + thlDebug (tlsHandle t) "medium" . BSC.pack . (++ "\n") . show $ BS.head p + thlDebug (tlsHandle t) "low" . BSC.pack . (++ "\n") $ show p + return (ct, p) + +read :: (HandleLike h, CPRG g) => TlsHandle h g -> Int -> TlsM h g BS.ByteString +read t n = do + r <- thlGet (tlsHandle t) n + unless (BS.length r == n) . throwError . strMsg $ + "TlsHandle.read: can't read " ++ show (BS.length r) ++ " " ++ show n + return r + +decrypt :: HandleLike h => + TlsHandle h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString +decrypt t ct e = do + ks <- getKeys $ clientId t + decrypt_ t ks ct e + +decrypt_ :: HandleLike h => TlsHandle h g -> + Keys -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString +decrypt_ _ Keys{ kReadCS = CipherSuite _ BE_NULL } _ e = return e +decrypt_ t ks ct e = do + let CipherSuite _ be = kReadCS ks + wk = kReadKey ks + mk = kReadMacKey ks + sn <- updateSequenceNumber t Read + hs <- case be of + AES_128_CBC_SHA -> return CT.hashSha1 + AES_128_CBC_SHA256 -> return CT.hashSha256 + _ -> throwError "TlsHandle.decrypt: not implement bulk encryption" + either (throwError . strMsg) return $ + CT.decrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") e + +tlsPut :: (HandleLike h, CPRG g) => Bool -> + HandleHash h g -> ContentType -> BS.ByteString -> TlsM h g (HandleHash h g) +tlsPut b hh@(t, _) ct p = do + (bct, bp) <- getWBuf $ clientId t + case ct of + CTCCSpec -> flush t >> setWBuf (clientId t) (ct, p) >> flush t + _ | bct /= CTNull && ct /= bct -> + flush t >> setWBuf (clientId t) (ct, p) + | otherwise -> setWBuf (clientId t) (ct, bp `BS.append` p) + case (ct, b) of + (CTHandshake, True) -> updateHash hh p + _ -> return hh + +flush :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g () +flush t = do + (bct, bp) <- getWBuf $ clientId t + setWBuf (clientId t) (CTNull, "") + unless (bct == CTNull) $ do + e <- encrypt t bct bp + thlPut (tlsHandle t) $ BS.concat [ + B.encode bct, "\x03\x03", B.addLen (undefined :: Word16) e ] + +encrypt :: (HandleLike h, CPRG g) => + TlsHandle h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString +encrypt t ct p = do + ks <- getKeys $ clientId t + encrypt_ t ks ct p + +encrypt_ :: (HandleLike h, CPRG g) => TlsHandle h g -> + Keys -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString +encrypt_ _ Keys{ kWriteCS = CipherSuite _ BE_NULL } _ p = return p +encrypt_ t ks ct p = do + let CipherSuite _ be = kWriteCS ks + wk = kWriteKey ks + mk = kWriteMacKey ks + sn <- updateSequenceNumber t Write + hs <- case be of + AES_128_CBC_SHA -> return CT.hashSha1 + AES_128_CBC_SHA256 -> return CT.hashSha256 + _ -> throwError "TlsHandle.encrypt: not implemented bulk encryption" + withRandom $ CT.encrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") p + +updateHash :: + HandleLike h => HandleHash h g -> BS.ByteString -> TlsM h g (HandleHash h g) +updateHash (th, ctx') bs = return (th, SHA256.update ctx' bs) + +updateSequenceNumber :: HandleLike h => TlsHandle h g -> RW -> TlsM h g Word64 +updateSequenceNumber t rw = do + ks <- getKeys $ clientId t + (sn, cs) <- case rw of + Read -> (, kReadCS ks) `liftM` getReadSn (clientId t) + Write -> (, kWriteCS ks) `liftM` getWriteSn (clientId t) + case cs of + CipherSuite _ BE_NULL -> return () + _ -> case rw of + Read -> succReadSn $ clientId t + Write -> succWriteSn $ clientId t + return sn + +resetSequenceNumber :: HandleLike h => TlsHandle h g -> RW -> TlsM h g () +resetSequenceNumber t rw = case rw of + Read -> resetReadSn $ clientId t + Write -> resetWriteSn $ clientId t + +generateKeys :: HandleLike h => TlsHandle h g -> Side -> CipherSuite -> + BS.ByteString -> BS.ByteString -> BS.ByteString -> TlsM h g Keys +generateKeys t p cs cr sr pms = do + let CipherSuite _ be = cs + kl <- case be of + AES_128_CBC_SHA -> return 20 + AES_128_CBC_SHA256 -> return 32 + _ -> throwError + "TlsServer.generateKeys: not implemented bulk encryption" + let (ms, cwmk, swmk, cwk, swk) = CT.makeKeys kl cr sr pms + k <- getKeys $ clientId t + return $ case p of + Client -> k { + kCachedCS = cs, + kMasterSecret = ms, + kCachedReadMacKey = swmk, kCachedWriteMacKey = cwmk, + kCachedReadKey = swk, kCachedWriteKey = cwk } + Server -> k { + kCachedCS = cs, + kMasterSecret = ms, + kCachedReadMacKey = cwmk, kCachedWriteMacKey = swmk, + kCachedReadKey = cwk, kCachedWriteKey = swk } + +data RW = Read | Write deriving Show + +flushCipherSuiteSt :: HandleLike h => RW -> PartnerId -> TlsM h g () +flushCipherSuiteSt p = case p of + Read -> flushCipherSuiteRead + Write -> flushCipherSuiteWrite + +debugCipherSuite :: HandleLike h => TlsHandle h g -> String -> TlsM h g () +debugCipherSuite t a = do + k <- getKeys $ clientId t + thlDebug (tlsHandle t) "high" . BSC.pack + . (++ (" - VERIFY WITH " ++ a ++ "\n")) . lenSpace 50 + . show $ kCachedCS k + where lenSpace n str = str ++ replicate (n - length str) ' ' + +handshakeHash :: HandleLike h => HandleHash h g -> TlsM h g BS.ByteString +handshakeHash = return . SHA256.finalize . snd + +finishedHash :: HandleLike h => HandleHash h g -> Side -> TlsM h g BS.ByteString +finishedHash (t, ctx) partner = do + ms <- kMasterSecret `liftM` getKeys (clientId t) + sha256 <- handshakeHash (t, ctx) + return $ CT.finishedHash (partner == Client) ms sha256 + +hlPut_ :: (HandleLike h, CPRG g) => TlsHandle h g -> BS.ByteString -> TlsM h g () +hlPut_ = ((>> return ()) .) . flip (tlsPut True) CTAppData . (, undefined) + +hlDebug_ :: HandleLike h => + TlsHandle h g -> DebugLevel h -> BS.ByteString -> TlsM h g () +hlDebug_ t l = lift . lift . hlDebug (tlsHandle t) l + +hlClose_ :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g () +hlClose_ t = tlsPut True (t, undefined) CTAlert "\SOH\NUL" >> + flush t >> thlClose (tlsHandle t) + +tGetLine :: (HandleLike h, CPRG g) => + TlsHandle h g -> TlsM h g (ContentType, BS.ByteString) +tGetLine t = do + (bct, bp) <- getBuf $ clientId t + case splitLine bp of + Just (l, ls) -> setBuf (clientId t) (bct, ls) >> return (bct, l) + _ -> do cp <- getWholeWithCt t + setBuf (clientId t) cp + second (bp `BS.append`) `liftM` tGetLine t + +tGetLine_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) -> + TlsHandle h g -> TlsM h g (ContentType, BS.ByteString) +tGetLine_ rn t = do + ct <- getContentType t + case ct of + CTHandshake -> rn t >> tGetLine_ rn t + _ -> do (bct, bp) <- getBuf $ clientId t + case splitLine bp of + Just (l, ls) -> do + setBuf (clientId t) (bct, ls) + return (bct, l) + _ -> do cp <- getWholeWithCt t + setBuf (clientId t) cp + second (bp `BS.append`) `liftM` + tGetLine_ rn t + +splitLine :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString) +splitLine bs = case ('\r' `BSC.elem` bs, '\n' `BSC.elem` bs) of + (True, _) -> let + (l, ls) = BSC.span (/= '\r') bs + Just ('\r', ls') = BSC.uncons ls in + case BSC.uncons ls' of + Just ('\n', ls'') -> Just (l, ls'') + _ -> Just (l, ls') + (_, True) -> let + (l, ls) = BSC.span (/= '\n') bs + Just ('\n', ls') = BSC.uncons ls in Just (l, ls') + _ -> Nothing + +tGetContent :: (HandleLike h, CPRG g) => + TlsHandle h g -> TlsM h g (ContentType, BS.ByteString) +tGetContent t = do + bcp@(_, bp) <- getBuf $ clientId t + if BS.null bp then getWholeWithCt t else + setBuf (clientId t) (CTNull, BS.empty) >> return bcp + +getClientFinishedT, getServerFinishedT :: + HandleLike h => TlsHandle h g -> TlsM h g BS.ByteString +getClientFinishedT = getClientFinished . clientId +getServerFinishedT = getServerFinished . clientId + +setClientFinishedT, setServerFinishedT :: + HandleLike h => TlsHandle h g -> BS.ByteString -> TlsM h g () +setClientFinishedT = setClientFinished . clientId +setServerFinishedT = setServerFinished . clientId + +getInitSetT :: HandleLike h => TlsHandle h g -> TlsM h g InitialSettings +getInitSetT = getInitSet . clientId + +setInitSetT :: HandleLike h => TlsHandle h g -> InitialSettings -> TlsM h g () +setInitSetT = setInitSet . clientId + +getAdBufT :: HandleLike h => TlsHandle h g -> TlsM h g BS.ByteString +getAdBufT = getAdBuf . clientId + +setAdBufT :: HandleLike h => TlsHandle h g -> BS.ByteString -> TlsM h g () +setAdBufT = setAdBuf . clientId diff --git a/src/Network/PeyoTLS/HandshakeBase.hs b/src/Network/PeyoTLS/HandshakeBase.hs deleted file mode 100644 --- a/src/Network/PeyoTLS/HandshakeBase.hs +++ /dev/null @@ -1,337 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TypeFamilies, PackageImports, - TupleSections #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Network.PeyoTLS.HandshakeBase ( Extension(..), - PeyotlsM, PeyotlsHandle, - debug, generateKs, blindSign, CertSecretKey(..), - HM.TlsM, HM.run, HM.HandshakeM, HM.execHandshakeM, HM.rerunHandshakeM, - HM.withRandom, HM.randomByteString, - HM.TlsHandle, HM.names, - readHandshake, getChangeCipherSpec, - readHandshakeNoHash, - writeHandshake, putChangeCipherSpec, - writeHandshakeNoHash, - HM.ValidateHandle(..), HM.handshakeValidate, - HM.Alert(..), HM.AlertLevel(..), HM.AlertDesc(..), - ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..), - ServerHelloDone(..), - ClientHello(..), ServerHello(..), SessionId(..), - CipherSuite(..), KeyExchange(..), BulkEncryption(..), - CompressionMethod(..), HashAlg(..), SignAlg(..), - HM.setCipherSuite, - CertificateRequest(..), certificateRequest, ClientCertificateType(..), SecretKey(..), - ClientKeyExchange(..), Epms(..), - HM.generateKeys, - HM.encryptRsa, HM.decryptRsa, HM.rsaPadding, HM.debugCipherSuite, - DigitallySigned(..), HM.handshakeHash, HM.flushCipherSuite, - HM.Side(..), HM.RW(..), finishedHash, - DhParam(..), dh3072Modp, secp256r1, HM.throwError, - HM.getClientFinished, HM.setClientFinished, - HM.getServerFinished, HM.setServerFinished, - Finished(..), - HM.ContentType(CTAlert, CTHandshake, CTAppData), - Handshake(..), - HM.tlsHandle, - hlGetRn, hlGetLineRn, hlGetContentRn, - - HM.getInitSet, HM.setInitSet, - HM.flushAppData, - HM.getAdBuf, - HM.setAdBuf, - HM.getAdBufH, - HM.setAdBufH, - ) where - -import Control.Applicative -import Control.Arrow (first) -import Control.Monad (liftM, ap) -import "monads-tf" Control.Monad.State (gets, lift) -import qualified "monads-tf" Control.Monad.Error as E -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 Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC -import qualified Data.ASN1.Types as ASN1 -import qualified Data.ASN1.Encoding as ASN1 -import qualified Data.ASN1.BinaryEncoding as ASN1 -import qualified Codec.Bytable.BigEndian as B -import qualified Crypto.Hash.SHA1 as SHA1 -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Crypto.PubKey.RSA as RSA -import qualified Crypto.PubKey.RSA.Prim as RSA -import qualified Crypto.Types.PubKey.DH as DH -import qualified Crypto.PubKey.DH as DH -import qualified Crypto.Types.PubKey.ECC as ECC -import qualified Crypto.PubKey.ECC.Prim as ECC -import qualified Crypto.Types.PubKey.ECDSA as ECDSA - -import Network.PeyoTLS.HandshakeType ( Extension(..), - Handshake(..), HandshakeItem(..), - ClientHello(..), ServerHello(..), SessionId(..), - CipherSuite(..), KeyExchange(..), BulkEncryption(..), - CompressionMethod(..), - ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..), - CertificateRequest(..), certificateRequest, ClientCertificateType(..), - SignAlg(..), HashAlg(..), - ServerHelloDone(..), ClientKeyExchange(..), Epms(..), - DigitallySigned(..), Finished(..) ) -import qualified Network.PeyoTLS.HandshakeMonad as HM ( - TlsM, run, HandshakeM, execHandshakeM, rerunHandshakeM, - withRandom, randomByteString, - ValidateHandle(..), handshakeValidate, - TlsHandle(..), ContentType(..), - names, - setCipherSuite, flushCipherSuite, debugCipherSuite, - tlsGetContentType, tlsGet, tlsPut, tlsPutNoHash, - generateKeys, encryptRsa, decryptRsa, rsaPadding, - Alert(..), AlertLevel(..), AlertDesc(..), - Side(..), RW(..), handshakeHash, finishedHash, throwError, - hlPut_, tGetLine, tGetContent, tlsGet_, tlsPut_, - tGetLine_, tGetContent_, tlsGet__, - hlDebug_, hlClose_, - getClientFinished, setClientFinished, - getServerFinished, setServerFinished, - resetSequenceNumber, - - getInitSet, setInitSet, - flushAppData, - getAdBuf, - setAdBuf, - getAdBufH, - setAdBufH, - ) -import Network.PeyoTLS.Ecdsa (blindSign, generateKs) - -import Network.PeyoTLS.CertSecretKey - -type PeyotlsM = HM.TlsM Handle SystemRNG -type PeyotlsHandle = HM.TlsHandle Handle SystemRNG - -debug :: (HandleLike h, Show a) => DebugLevel h -> a -> HM.HandshakeM h g () -debug p x = do - h <- gets $ HM.tlsHandle . fst - lift . lift . lift . hlDebug h p . BSC.pack . (++ "\n") $ show x - -readHandshake :: (HandleLike h, CPRG g, HandshakeItem hi) => HM.HandshakeM h g hi -readHandshake = do - cnt <- readContent (HM.tlsGet True) =<< HM.tlsGetContentType - hs <- case cnt of - CHandshake HHelloRequest -> readHandshake - CHandshake hs -> return hs - _ -> HM.throwError - HM.ALFatal HM.ADUnexpectedMessage $ - "HandshakeBase.readHandshake: not handshake: " ++ show cnt - case fromHandshake hs of - Just i -> return i - _ -> HM.throwError - HM.ALFatal HM.ADUnexpectedMessage $ - "HandshakeBase.readHandshake: type mismatch " ++ show hs - -readHandshakeNoHash :: (HandleLike h, CPRG g, HandshakeItem hi) => HM.HandshakeM h g hi -readHandshakeNoHash = do - cnt <- readContent (HM.tlsGet False) =<< HM.tlsGetContentType - hs <- case cnt of - CHandshake hs -> return hs - _ -> HM.throwError - HM.ALFatal HM.ADUnexpectedMessage $ - "HandshakeBase.readHandshake: not handshake: " ++ show cnt - case fromHandshake hs of - Just i -> return i - _ -> HM.throwError - HM.ALFatal HM.ADUnexpectedMessage $ - "HandshakeBase.readHandshake: type mismatch " ++ show hs - -writeHandshake, writeHandshakeNoHash :: - (HandleLike h, CPRG g, HandshakeItem hi) => hi -> HM.HandshakeM h g () -writeHandshake = uncurry HM.tlsPut . encodeContent . CHandshake . toHandshake -writeHandshakeNoHash = - uncurry HM.tlsPutNoHash . encodeContent . CHandshake . toHandshake - -data ChangeCipherSpec = ChangeCipherSpec | ChangeCipherSpecRaw Word8 deriving Show - -instance B.Bytable ChangeCipherSpec where - decode bs = case BS.unpack bs of - [1] -> Right ChangeCipherSpec - [w] -> Right $ ChangeCipherSpecRaw w - _ -> Left "HandshakeBase: ChangeCipherSpec.decode" - encode ChangeCipherSpec = BS.pack [1] - encode (ChangeCipherSpecRaw w) = BS.pack [w] - -getChangeCipherSpec :: (HandleLike h, CPRG g) => HM.HandshakeM h g () -getChangeCipherSpec = do - cnt <- readContent (HM.tlsGet True) =<< HM.tlsGetContentType - case cnt of - CCCSpec ChangeCipherSpec -> return () - _ -> HM.throwError - HM.ALFatal HM.ADUnexpectedMessage $ - "HandshakeBase.getChangeCipherSpec: " ++ - "not change cipher spec: " ++ - show cnt - HM.resetSequenceNumber HM.Read - -putChangeCipherSpec :: (HandleLike h, CPRG g) => HM.HandshakeM h g () -putChangeCipherSpec = do - uncurry HM.tlsPut . encodeContent $ CCCSpec ChangeCipherSpec - HM.resetSequenceNumber HM.Write - -data Content = CCCSpec ChangeCipherSpec | CAlert Word8 Word8 | CHandshake Handshake - deriving Show - -readContent :: Monad m => (Int -> m BS.ByteString) -> HM.ContentType -> m Content -readContent rd HM.CTCCSpec = (CCCSpec . either error id . B.decode) `liftM` rd 1 -readContent rd HM.CTAlert = ((\[al, ad] -> CAlert al ad) . BS.unpack) `liftM` rd 2 -readContent rd HM.CTHandshake = CHandshake `liftM` do - (t, len) <- (,) `liftM` rd 1 `ap` rd 3 - body <- rd . either error id $ B.decode len - return . either error id . B.decode $ BS.concat [t, len, body] -readContent _ _ = undefined - -encodeContent :: Content -> (HM.ContentType, BS.ByteString) -encodeContent (CCCSpec ccs) = (HM.CTCCSpec, B.encode ccs) -encodeContent (CAlert al ad) = (HM.CTAlert, BS.pack [al, ad]) -encodeContent (CHandshake hss) = (HM.CTHandshake, B.encode hss) - -class SecretKey sk where - type Blinder sk - generateBlinder :: CPRG g => sk -> g -> (Blinder sk, g) - sign :: HashAlg -> Blinder sk -> sk -> BS.ByteString -> BS.ByteString - signatureAlgorithm :: sk -> SignAlg - -instance SecretKey RSA.PrivateKey where - type Blinder RSA.PrivateKey = RSA.Blinder - generateBlinder sk rng = - RSA.generateBlinder rng . RSA.public_n $ RSA.private_pub sk - sign hs bl sk bs = let - (h, oid) = first ($ bs) $ case hs of - Sha1 -> (SHA1.hash, - ASN1.OID [1, 3, 14, 3, 2, 26]) - Sha256 -> (SHA256.hash, - ASN1.OID [2, 16, 840, 1, 101, 3, 4, 2, 1]) - _ -> error $ "HandshakeBase: " ++ - "not implemented bulk encryption type" - a = [ASN1.Start ASN1.Sequence, - ASN1.Start ASN1.Sequence, - oid, ASN1.Null, ASN1.End ASN1.Sequence, - ASN1.OctetString h, ASN1.End ASN1.Sequence] - b = ASN1.encodeASN1' ASN1.DER a - pd = BS.concat [ "\x00\x01", - BS.replicate (ps - 3 - BS.length b) 0xff, "\NUL", b ] - ps = RSA.public_size $ RSA.private_pub sk in - RSA.dp (Just bl) sk pd - signatureAlgorithm _ = Rsa - -instance SecretKey ECDSA.PrivateKey where - type Blinder ECDSA.PrivateKey = Integer - generateBlinder _ rng = let - (Right bl, rng') = first B.decode $ cprgGenerate 32 rng in - (bl, rng') - sign ha bl sk = B.encode . - (($) <$> blindSign bl hs sk . generateKs (hs, bls) q x <*> id) - where - (hs, bls) = case ha of - Sha1 -> (SHA1.hash, 64) - Sha256 -> (SHA256.hash, 64) - _ -> error $ "HandshakeBase: " ++ - "not implemented bulk encryption type" - q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk - x = ECDSA.private_d sk - signatureAlgorithm _ = Ecdsa - -class DhParam b where - type Secret b - type Public b - generateSecret :: CPRG g => b -> g -> (Secret b, g) - calculatePublic :: b -> Secret b -> Public b - calculateShared :: b -> Secret b -> Public b -> BS.ByteString - -instance DhParam DH.Params where - type Secret DH.Params = DH.PrivateNumber - type Public DH.Params = DH.PublicNumber - generateSecret = flip DH.generatePrivate - calculatePublic = DH.calculatePublic - calculateShared ps sn pn = B.encode . - (\(DH.SharedKey s) -> s) $ DH.getShared ps sn pn - -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" - -instance DhParam ECC.Curve where - type Secret ECC.Curve = Integer - type Public ECC.Curve = ECC.Point - generateSecret c = getRangedInteger 32 1 (n - 1) - where n = ECC.ecc_n $ ECC.common_curve c - calculatePublic cv sn = - ECC.pointMul cv sn . ECC.ecc_g $ ECC.common_curve cv - calculateShared cv sn pp = - let ECC.Point x _ = ECC.pointMul cv sn pp in B.encode x - -getRangedInteger :: CPRG g => Int -> Integer -> Integer -> g -> (Integer, g) -getRangedInteger b mn mx g = let - (n, g') = first (either error id . B.decode) $ cprgGenerate b g in - if mn <= n && n <= mx then (n, g') else getRangedInteger b mn mx g' - -secp256r1 :: ECC.Curve -secp256r1 = ECC.getCurveByName ECC.SEC_p256r1 - -finishedHash :: (HandleLike h, CPRG g) => HM.Side -> HM.HandshakeM h g Finished -finishedHash = (Finished `liftM`) . HM.finishedHash - -instance (HandleLike h, CPRG g) => HandleLike (HM.TlsHandle h g) where - type HandleMonad (HM.TlsHandle h g) = HM.TlsM h g - type DebugLevel (HM.TlsHandle h g) = DebugLevel h - hlPut = HM.hlPut_ - hlGet = (.) <$> checkAppData <*> ((fst `liftM`) .) - . HM.tlsGet__ . (, undefined) - hlGetLine = ($) <$> checkAppData <*> HM.tGetLine - hlGetContent = ($) <$> checkAppData <*> HM.tGetContent - hlDebug = HM.hlDebug_ - hlClose = HM.hlClose_ - -checkAppData :: (HandleLike h, CPRG g) => HM.TlsHandle h g -> - HM.TlsM h g (HM.ContentType, BS.ByteString) -> HM.TlsM h g BS.ByteString -checkAppData t m = m >>= \cp -> case cp of - (HM.CTAppData, ad) -> return ad - (HM.CTAlert, "\SOH\NUL") -> do - _ <- HM.tlsPut_ (t, undefined) HM.CTAlert "\SOH\NUL" - E.throwError "TlsHandle.checkAppData: EOF" - (HM.CTHandshake, hs) -> do - lift . lift $ hlDebug (HM.tlsHandle t) "critical" "renegotiation?\n" - lift . lift . hlDebug (HM.tlsHandle t) "critical" . BSC.pack - . (++ "\n") $ show hs - lift . lift . hlDebug (HM.tlsHandle t) "critical" . BSC.pack - . (++ "\n") $ show (B.decode hs :: Either String Handshake) - return "" - _ -> do _ <- HM.tlsPut_ (t, undefined) HM.CTAlert "\2\10" - E.throwError "TlsHandle.checkAppData: not application data" - -hlGetRn :: (HM.ValidateHandle h, CPRG g) => (HM.TlsHandle h g -> HM.TlsM h g ()) -> - HM.TlsHandle h g -> Int -> HM.TlsM h g BS.ByteString -hlGetRn rh = (.) <$> checkAppData <*> ((fst `liftM`) .) . HM.tlsGet_ rh - . (, undefined) - -hlGetLineRn, hlGetContentRn :: (HM.ValidateHandle h, CPRG g) => - (HM.TlsHandle h g -> HM.TlsM h g ()) -> HM.TlsHandle h g -> HM.TlsM h g BS.ByteString -hlGetLineRn rh = ($) <$> checkAppData <*> HM.tGetLine_ rh -hlGetContentRn rh = ($) <$> checkAppData <*> HM.tGetContent_ rh diff --git a/src/Network/PeyoTLS/HandshakeMonad.hs b/src/Network/PeyoTLS/HandshakeMonad.hs deleted file mode 100644 --- a/src/Network/PeyoTLS/HandshakeMonad.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports, TypeFamilies #-} - -module Network.PeyoTLS.HandshakeMonad ( - TH.TlsM, TH.run, HandshakeM, execHandshakeM, rerunHandshakeM, - withRandom, randomByteString, - ValidateHandle(..), handshakeValidate, - TH.TlsHandle(..), TH.ContentType(..), - setCipherSuite, flushCipherSuite, debugCipherSuite, - tlsGetContentType, tlsGet, tlsPut, tlsPutNoHash, - generateKeys, encryptRsa, decryptRsa, rsaPadding, - TH.Alert(..), TH.AlertLevel(..), TH.AlertDesc(..), - TH.Side(..), TH.RW(..), handshakeHash, finishedHash, throwError, - TH.hlPut_, TH.hlDebug_, TH.hlClose_, - TH.tGetLine, TH.tGetContent, tlsGet_, tlsPut_, tlsGet__, - tGetLine_, tGetContent_, - getClientFinished, setClientFinished, - getServerFinished, setServerFinished, - - resetSequenceNumber, - - getInitSet, setInitSet, - flushAppData, - - getAdBuf, setAdBuf, - getAdBufH, setAdBufH, - ) where - -import Prelude hiding (read) - -import Control.Applicative -import qualified Data.ASN1.Types as ASN1 -import Control.Arrow (first) -import Control.Monad (liftM) -import "monads-tf" Control.Monad.Trans (lift) -import "monads-tf" Control.Monad.State ( - StateT, evalStateT, execStateT, get, gets, put, modify) -import qualified "monads-tf" Control.Monad.Error as E (throwError) -import "monads-tf" Control.Monad.Error.Class (strMsg) -import Data.HandleLike (HandleLike(..)) -import System.IO (Handle) -import "crypto-random" Crypto.Random (CPRG) - -import qualified Data.ByteString as BS -import qualified Data.X509 as X509 -import qualified Data.X509.Validation as X509 -import qualified Data.X509.CertificateStore as X509 -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Crypto.PubKey.HashDescr as HD -import qualified Crypto.PubKey.RSA as RSA -import qualified Crypto.PubKey.RSA.PKCS15 as RSA - -import qualified Network.PeyoTLS.TlsHandle as TH ( - TlsM, Alert(..), AlertLevel(..), AlertDesc(..), - run, withRandom, randomByteString, - TlsHandle(..), ContentType(..), - newHandle, getContentType, tlsGet, tlsPut, generateKeys, - debugCipherSuite, - getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt, setKeys, - Side(..), RW(..), finishedHash, handshakeHash, CipherSuite(..), - hlPut_, hlDebug_, hlClose_, tGetContent, tGetLine, tGetLine_, - getClientFinishedT, setClientFinishedT, - getServerFinishedT, setServerFinishedT, - - resetSequenceNumber, - - getInitSetT, setInitSetT, InitialSettings, - tlsGet_, - flushAppData, - getAdBufT, - setAdBufT, - ) - -resetSequenceNumber :: HandleLike h => TH.RW -> HandshakeM h g () -resetSequenceNumber rw = gets fst >>= lift . flip TH.resetSequenceNumber rw - -tlsGet_ :: (HandleLike h, CPRG g) => - (TH.TlsHandle h g -> TH.TlsM h g ()) -> - (TH.TlsHandle h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle h g, SHA256.Ctx)) -tlsGet_ = TH.tlsGet_ - -tlsGet__ :: (HandleLike h, CPRG g) => - (TH.TlsHandle h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle h g, SHA256.Ctx)) -tlsGet__ = TH.tlsGet True - -tGetLine_, tGetContent_ :: (HandleLike h, CPRG g) => - (TH.TlsHandle h g -> TH.TlsM h g ()) -> - TH.TlsHandle h g -> TH.TlsM h g (TH.ContentType, BS.ByteString) -tGetLine_ = TH.tGetLine_ - -flushAppData :: (HandleLike h, CPRG g) => HandshakeM h g (BS.ByteString, Bool) -flushAppData = gets fst >>= lift . TH.flushAppData - -tGetContent_ rn t = do - ct <- TH.getContentType t - case ct of - TH.CTHandshake -> rn t >> tGetContent_ rn t - _ -> TH.tGetContent t - -tlsPut_ :: (HandleLike h, CPRG g) => - (TH.TlsHandle h g, SHA256.Ctx) -> TH.ContentType -> BS.ByteString -> TH.TlsM h g (TH.TlsHandle h g, SHA256.Ctx) -tlsPut_ = TH.tlsPut True - -throwError :: HandleLike h => - TH.AlertLevel -> TH.AlertDesc -> String -> HandshakeM h g a -throwError al ad m = E.throwError $ TH.Alert al ad m - -type HandshakeM h g = StateT (TH.TlsHandle h g, SHA256.Ctx) (TH.TlsM h g) - -execHandshakeM :: HandleLike h => - h -> HandshakeM h g () -> TH.TlsM h g (TH.TlsHandle h g) -execHandshakeM h = - liftM fst . ((, SHA256.init) `liftM` TH.newHandle h >>=) . execStateT - -rerunHandshakeM :: - HandleLike h => TH.TlsHandle h g -> HandshakeM h g a -> TH.TlsM h g a -rerunHandshakeM t hm = evalStateT hm (t, SHA256.init) - -withRandom :: HandleLike h => (g -> (a, g)) -> HandshakeM h g a -withRandom = lift . TH.withRandom - -randomByteString :: (HandleLike h, CPRG g) => Int -> HandshakeM h g BS.ByteString -randomByteString = lift . TH.randomByteString - -class HandleLike h => ValidateHandle h where - validate :: h -> X509.CertificateStore -> X509.CertificateChain -> - HandleMonad h [X509.FailedReason] - -instance ValidateHandle Handle where - validate _ cs (X509.CertificateChain cc) = - X509.validate X509.HashSHA256 X509.defaultHooks - validationChecks cs validationCache ("", "") $ - X509.CertificateChain cc - where - validationCache = X509.ValidationCache - (\_ _ _ -> return X509.ValidationCacheUnknown) - (\_ _ _ -> return ()) - validationChecks = X509.defaultChecks { X509.checkFQHN = False } - -certNames :: X509.Certificate -> [String] -certNames = nms - where - nms c = maybe id (:) <$> nms_ <*> ans $ c - nms_ = (ASN1.asn1CharacterToString =<<) . - X509.getDnElement X509.DnCommonName . X509.certSubjectDN - ans = maybe [] ((\ns -> [s | X509.AltNameDNS s <- ns]) - . \(X509.ExtSubjectAltName ns) -> ns) - . X509.extensionGet . X509.certExtensions - -handshakeValidate :: ValidateHandle h => - X509.CertificateStore -> X509.CertificateChain -> - HandshakeM h g [X509.FailedReason] -handshakeValidate cs cc@(X509.CertificateChain c) = gets fst >>= \t -> do - modify . first $ const t { TH.names = certNames . X509.getCertificate $ last c } - lift . lift . lift $ validate (TH.tlsHandle t) cs cc - -setCipherSuite :: HandleLike h => TH.CipherSuite -> HandshakeM h g () -setCipherSuite cs = do - t <- gets fst - lift $ TH.setCipherSuiteSt (TH.clientId t) cs - -flushCipherSuite :: (HandleLike h, CPRG g) => TH.RW -> HandshakeM h g () -flushCipherSuite p = do - t <- gets fst - lift $ TH.flushCipherSuiteSt p (TH.clientId t) - -debugCipherSuite :: HandleLike h => String -> HandshakeM h g () -debugCipherSuite m = do t <- gets fst; lift $ TH.debugCipherSuite t m - -tlsGetContentType :: (HandleLike h, CPRG g) => HandshakeM h g TH.ContentType -tlsGetContentType = gets fst >>= lift . TH.getContentType - -tlsGet :: (HandleLike h, CPRG g) => Bool -> Int -> HandshakeM h g BS.ByteString -tlsGet b n = do ((_, bs), t') <- lift . flip (TH.tlsGet b) n =<< get; put t'; return bs - -tlsPut, tlsPutNoHash :: (HandleLike h, CPRG g) => - TH.ContentType -> BS.ByteString -> HandshakeM h g () -tlsPut ct bs = get >>= lift . (\t -> TH.tlsPut True t ct bs) >>= put -tlsPutNoHash ct bs = get >>= lift . (\t -> TH.tlsPut False t ct bs) >>= put - -generateKeys :: HandleLike h => TH.Side -> - (BS.ByteString, BS.ByteString) -> BS.ByteString -> HandshakeM h g () -generateKeys p (cr, sr) pms = do - t <- gets fst - cs <- lift $ TH.getCipherSuiteSt (TH.clientId t) - k <- lift $ TH.generateKeys t p cs cr sr pms - lift $ TH.setKeys (TH.clientId t) k - -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) - -decryptRsa :: (HandleLike h, CPRG g) => - RSA.PrivateKey -> BS.ByteString -> HandshakeM h g BS.ByteString -decryptRsa sk e = either (E.throwError . strMsg . show) return =<< - withRandom (\g -> RSA.decryptSafer g sk e) - -rsaPadding :: RSA.PublicKey -> BS.ByteString -> BS.ByteString -rsaPadding pk bs = case RSA.padSignature (RSA.public_size pk) $ - HD.digestToASN1 HD.hashDescrSHA256 bs of - Right pd -> pd; Left m -> error $ show m - -handshakeHash :: HandleLike h => HandshakeM h g BS.ByteString -handshakeHash = get >>= lift . TH.handshakeHash - -finishedHash :: (HandleLike h, CPRG g) => TH.Side -> HandshakeM h g BS.ByteString -finishedHash p = get >>= lift . flip TH.finishedHash p - -getClientFinished, getServerFinished :: HandleLike h => HandshakeM h g BS.ByteString -getClientFinished = gets fst >>= lift . TH.getClientFinishedT -getServerFinished = gets fst >>= lift . TH.getServerFinishedT - -setClientFinished, setServerFinished :: - HandleLike h => BS.ByteString -> HandshakeM h g () -setClientFinished cf = gets fst >>= lift . flip TH.setClientFinishedT cf -setServerFinished cf = gets fst >>= lift . flip TH.setServerFinishedT cf - -getInitSet :: HandleLike h => HandshakeM h g TH.InitialSettings -getInitSet = gets fst >>= lift . TH.getInitSetT - -setInitSet :: HandleLike h => TH.InitialSettings -> HandshakeM h g () -setInitSet is = gets fst >>= lift . flip TH.setInitSetT is - --- getAdBuf :: HandleLike h => HandshakeM h g BS.ByteString -getAdBuf :: HandleLike h => TH.TlsHandle h g -> TH.TlsM h g BS.ByteString -getAdBuf = TH.getAdBufT -- = gets fst >>= lift . TH.getAdBufT - --- setAdBuf :: HandleLike h => BS.ByteString -> HandshakeM h g () -setAdBuf :: HandleLike h => - TH.TlsHandle h g -> BS.ByteString -> TH.TlsM h g () -setAdBuf = TH.setAdBufT -- bs = gets fst >>= lift . flip TH.setAdBufT bs - -getAdBufH :: HandleLike h => HandshakeM h g BS.ByteString -getAdBufH = gets fst >>= lift . TH.getAdBufT - -setAdBufH :: HandleLike h => BS.ByteString -> HandshakeM h g () -setAdBufH bs = gets fst >>= lift . flip TH.setAdBufT bs diff --git a/src/Network/PeyoTLS/HandshakeType.hs b/src/Network/PeyoTLS/HandshakeType.hs deleted file mode 100644 --- a/src/Network/PeyoTLS/HandshakeType.hs +++ /dev/null @@ -1,240 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Network.PeyoTLS.HandshakeType ( Extension(..), - Handshake(..), HandshakeItem(..), - ClientHello(..), ServerHello(..), SessionId(..), - CipherSuite(..), KeyExchange(..), BulkEncryption(..), - CompressionMethod(..), - ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..), - CertificateRequest(..), certificateRequest, ClientCertificateType(..), - SignAlg(..), HashAlg(..), - ServerHelloDone(..), ClientKeyExchange(..), Epms(..), - DigitallySigned(..), Finished(..) ) where - -import Control.Applicative ((<$>), (<*>)) -import Control.Monad (unless) -import Data.Word (Word8, Word16) -import Data.Word.Word24 (Word24) - -import qualified Data.ByteString as BS -import qualified Data.X509 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 Network.PeyoTLS.Hello ( Extension(..), - ClientHello(..), ServerHello(..), SessionId(..), - CipherSuite(..), KeyExchange(..), BulkEncryption(..), - CompressionMethod(..), HashAlg(..), SignAlg(..) ) -import Network.PeyoTLS.Certificate ( - CertificateRequest(..), certificateRequest, ClientCertificateType(..), - ClientKeyExchange(..), DigitallySigned(..) ) - -data Handshake - = HHelloRequest - | HClientHello ClientHello | HServerHello ServerHello - | HCertificate X509.CertificateChain | HServerKeyEx BS.ByteString - | HCertificateReq CertificateRequest | HServerHelloDone - | HCertVerify DigitallySigned | HClientKeyEx ClientKeyExchange - | HFinished BS.ByteString | HRaw Type BS.ByteString - deriving Show - -instance B.Bytable Handshake where - decode = B.evalBytableM B.parse; encode = encodeH - -instance B.Parsable Handshake where - parse = do - t <- B.take 1 - len <- B.take 3 - case t of - THelloRequest -> do - unless (len == 0) $ fail "parse Handshake" - return HHelloRequest - TClientHello -> HClientHello <$> B.take len - TServerHello -> HServerHello <$> B.take len - TCertificate -> HCertificate <$> B.take len - TServerKeyEx -> HServerKeyEx <$> B.take len - TCertificateReq -> HCertificateReq <$> B.take len - TServerHelloDone -> let 0 = len in return HServerHelloDone - TCertVerify -> HCertVerify <$> B.take len - TClientKeyEx -> HClientKeyEx <$> B.take len - TFinished -> HFinished <$> B.take len - _ -> HRaw t <$> B.take len - -encodeH :: Handshake -> BS.ByteString -encodeH HHelloRequest = encodeH $ HRaw THelloRequest "" -encodeH (HClientHello ch) = encodeH . HRaw TClientHello $ B.encode ch -encodeH (HServerHello sh) = encodeH . HRaw TServerHello $ B.encode sh -encodeH (HCertificate crts) = encodeH . HRaw TCertificate $ B.encode crts -encodeH (HServerKeyEx ske) = encodeH $ HRaw TServerKeyEx ske -encodeH (HCertificateReq cr) = encodeH . HRaw TCertificateReq $ B.encode cr -encodeH HServerHelloDone = encodeH $ HRaw TServerHelloDone "" -encodeH (HCertVerify ds) = encodeH . HRaw TCertVerify $ B.encode ds -encodeH (HClientKeyEx epms) = encodeH . HRaw TClientKeyEx $ B.encode epms -encodeH (HFinished bs) = encodeH $ HRaw TFinished bs -encodeH (HRaw t bs) = B.encode t `BS.append` B.addLen (undefined :: Word24) bs - -class HandshakeItem hi where - fromHandshake :: Handshake -> Maybe hi; toHandshake :: hi -> Handshake - -instance HandshakeItem Handshake where - fromHandshake = Just; toHandshake = id - -instance (HandshakeItem l, HandshakeItem r) => HandshakeItem (Either l r) where - fromHandshake hs = let - l = fromHandshake hs - r = fromHandshake hs in maybe (Right <$> r) (Just . Left) l - toHandshake (Left l) = toHandshake l - toHandshake (Right r) = toHandshake r - -instance HandshakeItem ClientHello where - fromHandshake (HClientHello ch) = Just ch - fromHandshake _ = Nothing - toHandshake = HClientHello - -instance HandshakeItem ServerHello where - fromHandshake (HServerHello sh) = Just sh - fromHandshake _ = Nothing - toHandshake = HServerHello - -instance HandshakeItem X509.CertificateChain where - fromHandshake (HCertificate cc) = Just cc - fromHandshake _ = Nothing - toHandshake = HCertificate - -data ServerKeyExchange = ServerKeyEx BS.ByteString BS.ByteString - HashAlg SignAlg BS.ByteString deriving Show - -data ServerKeyExDhe = ServerKeyExDhe DH.Params DH.PublicNumber - HashAlg SignAlg BS.ByteString deriving Show - -data ServerKeyExEcdhe = ServerKeyExEcdhe ECC.Curve ECC.Point - HashAlg SignAlg BS.ByteString deriving Show - -instance HandshakeItem ServerKeyExchange where - fromHandshake = undefined - toHandshake = HServerKeyEx . B.encode - -instance HandshakeItem ServerKeyExDhe where - toHandshake = HServerKeyEx . B.encode - fromHandshake (HServerKeyEx ske) = - either (const Nothing) Just $ B.decode ske - fromHandshake _ = Nothing - -instance HandshakeItem ServerKeyExEcdhe where - toHandshake = HServerKeyEx . B.encode - fromHandshake (HServerKeyEx ske) = - either (const Nothing) Just $ B.decode ske - fromHandshake _ = Nothing - -instance B.Bytable ServerKeyExchange where - decode = undefined - encode (ServerKeyEx ps pv ha sa sn) = BS.concat [ - ps, pv, B.encode ha, B.encode sa, - B.addLen (undefined :: Word16) sn ] - -instance B.Bytable ServerKeyExDhe where - encode (ServerKeyExDhe ps pv ha sa sn) = BS.concat [ - B.encode ps, B.encode pv, B.encode ha, B.encode sa, - B.addLen (undefined :: Word16) sn ] - decode = B.evalBytableM B.parse - -instance B.Bytable ServerKeyExEcdhe where - encode (ServerKeyExEcdhe cv pnt ha sa sn) = BS.concat [ - B.encode cv, B.encode pnt, B.encode ha, B.encode sa, - B.addLen (undefined :: Word16) sn ] - decode = B.evalBytableM B.parse - -instance B.Parsable ServerKeyExDhe where - parse = do - ps <- B.parse - pv <- B.parse - (ha, sa, sn) <- hasasn - return $ ServerKeyExDhe ps pv ha sa sn - -instance B.Parsable ServerKeyExEcdhe where - parse = do - cv <- B.parse - pnt <- B.parse - (ha, sa, sn) <- hasasn - return $ ServerKeyExEcdhe cv pnt ha sa sn - -hasasn :: B.BytableM (HashAlg, SignAlg, BS.ByteString) -hasasn = (,,) <$> B.parse <*> B.parse <*> (B.take =<< B.take 2) - -instance HandshakeItem CertificateRequest where - fromHandshake (HCertificateReq cr) = Just cr - fromHandshake _ = Nothing - toHandshake = HCertificateReq - -instance HandshakeItem ServerHelloDone where - fromHandshake HServerHelloDone = Just ServerHelloDone - fromHandshake _ = Nothing - toHandshake _ = HServerHelloDone - -instance HandshakeItem DigitallySigned where - fromHandshake (HCertVerify ds) = Just ds - fromHandshake _ = Nothing - toHandshake = HCertVerify - -instance HandshakeItem ClientKeyExchange where - fromHandshake (HClientKeyEx cke) = Just cke - fromHandshake _ = Nothing - toHandshake = HClientKeyEx - -data Epms = Epms BS.ByteString - -instance HandshakeItem Epms where - fromHandshake (HClientKeyEx cke) = ckeToEpms cke - fromHandshake _ = Nothing - toHandshake = HClientKeyEx . epmsToCke - -ckeToEpms :: ClientKeyExchange -> Maybe Epms -ckeToEpms (ClientKeyExchange cke) = case B.runBytableM (B.take =<< B.take 2) cke of - Right (e, "") -> Just $ Epms e - _ -> Nothing - -epmsToCke :: Epms -> ClientKeyExchange -epmsToCke (Epms epms) = ClientKeyExchange $ B.addLen (undefined :: Word16) epms - -data Finished = Finished BS.ByteString deriving (Show, Eq) - -instance HandshakeItem Finished where - fromHandshake (HFinished f) = Just $ Finished f - fromHandshake _ = Nothing - toHandshake (Finished f) = HFinished f - -data ServerHelloDone = ServerHelloDone deriving Show - -data Type - = THelloRequest | TClientHello | TServerHello - | TCertificate | TServerKeyEx | TCertificateReq | TServerHelloDone - | TCertVerify | TClientKeyEx | TFinished | TRaw Word8 - deriving Show - -instance B.Bytable Type where - decode bs = case BS.unpack bs of - [0] -> Right THelloRequest - [1] -> Right TClientHello - [2] -> Right TServerHello - [11] -> Right TCertificate - [12] -> Right TServerKeyEx - [13] -> Right TCertificateReq - [14] -> Right TServerHelloDone - [15] -> Right TCertVerify - [16] -> Right TClientKeyEx - [20] -> Right TFinished - [ht] -> Right $ TRaw ht - _ -> Left "Handshake.decodeT" - encode THelloRequest = BS.pack [0] - encode TClientHello = BS.pack [1] - encode TServerHello = BS.pack [2] - encode TCertificate = BS.pack [11] - encode TServerKeyEx = BS.pack [12] - encode TCertificateReq = BS.pack [13] - encode TServerHelloDone = BS.pack [14] - encode TCertVerify = BS.pack [15] - encode TClientKeyEx = BS.pack [16] - encode TFinished = BS.pack [20] - encode (TRaw w) = BS.pack [w] diff --git a/src/Network/PeyoTLS/HashSignAlgorithm.hs b/src/Network/PeyoTLS/HashSignAlgorithm.hs deleted file mode 100644 --- a/src/Network/PeyoTLS/HashSignAlgorithm.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Network.PeyoTLS.HashSignAlgorithm (SignAlg(..), HashAlg(..)) where - -import Data.Word (Word8) - -import qualified Data.ByteString as BS -import qualified Codec.Bytable.BigEndian as B - -data HashAlg = Sha1 | Sha224 | Sha256 | Sha384 | Sha512 | HARaw Word8 - deriving Show - -instance B.Bytable HashAlg where - encode Sha1 = "\x02" - encode Sha224 = "\x03" - encode Sha256 = "\x04" - encode Sha384 = "\x05" - encode Sha512 = "\x06" - encode (HARaw w) = BS.pack [w] - decode bs = case BS.unpack bs of - [ha] -> Right $ case ha of - 2 -> Sha1 ; 3 -> Sha224; 4 -> Sha256 - 5 -> Sha384; 6 -> Sha512; _ -> HARaw ha - _ -> Left "HashSignAlgorithm: Bytable.decode" - -instance B.Parsable HashAlg where - parse = B.take 1 - -data SignAlg = Rsa | Dsa | Ecdsa | SARaw Word8 deriving (Show, Eq) - -instance B.Bytable SignAlg where - encode Rsa = "\x01" - encode Dsa = "\x02" - encode Ecdsa = "\x03" - encode (SARaw w) = BS.pack [w] - decode bs = case BS.unpack bs of - [sa] -> Right $ case sa of - 1 -> Rsa; 2 -> Dsa; 3 -> Ecdsa; _ -> SARaw sa - _ -> Left "Type.decodeSA" - -instance B.Parsable SignAlg where - parse = B.take 1 diff --git a/src/Network/PeyoTLS/Hello.hs b/src/Network/PeyoTLS/Hello.hs --- a/src/Network/PeyoTLS/Hello.hs +++ b/src/Network/PeyoTLS/Hello.hs @@ -2,8 +2,8 @@ module Network.PeyoTLS.Hello ( Extension(..), ClientHello(..), ServerHello(..), SessionId(..), - CipherSuite(..), KeyExchange(..), BulkEncryption(..), - CompressionMethod(..), + CipherSuite(..), KeyEx(..), BulkEnc(..), + CompMethod(..), SignAlg(..), HashAlg(..) ) where import Control.Applicative ((<$>), (<*>)) @@ -15,11 +15,11 @@ import Network.PeyoTLS.Extension (Extension(..), SignAlg(..), HashAlg(..)) import Network.PeyoTLS.CipherSuite ( - CipherSuite(..), KeyExchange(..), BulkEncryption(..)) + CipherSuite(..), KeyEx(..), BulkEnc(..)) data ClientHello = ClientHello (Word8, Word8) BS.ByteString SessionId - [CipherSuite] [CompressionMethod] (Maybe [Extension]) + [CipherSuite] [CompMethod] (Maybe [Extension]) | ClientHelloRaw BS.ByteString deriving Show @@ -46,7 +46,7 @@ data ServerHello = ServerHello (Word8, Word8) BS.ByteString SessionId - CipherSuite CompressionMethod (Maybe [Extension]) + CipherSuite CompMethod (Maybe [Extension]) | ServerHelloRaw BS.ByteString deriving Show @@ -71,17 +71,17 @@ maybe "" (B.addLen (undefined :: Word16) . BS.concat . map B.encode) mes ] encodeSh (ServerHelloRaw sh) = sh -data CompressionMethod = CompressionMethodNull | CompressionMethodRaw Word8 +data CompMethod = CompMethodNull | CompMethodRaw Word8 deriving (Show, Eq) -instance B.Bytable CompressionMethod where +instance B.Bytable CompMethod where decode bs = case BS.unpack bs of [cm] -> Right $ case cm of - 0 -> CompressionMethodNull - _ -> CompressionMethodRaw cm + 0 -> CompMethodNull + _ -> CompMethodRaw cm _ -> Left "Hello.decodeCm" - encode CompressionMethodNull = "\0" - encode (CompressionMethodRaw cm) = BS.pack [cm] + encode CompMethodNull = "\0" + encode (CompMethodRaw cm) = BS.pack [cm] data SessionId = SessionId BS.ByteString diff --git a/src/Network/PeyoTLS/Monad.hs b/src/Network/PeyoTLS/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Monad.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE PackageImports #-} + +module Network.PeyoTLS.Monad ( + TlsM, evalTlsM, S.initState, + thlGet, thlPut, thlClose, thlDebug, thlError, + withRandom, randomByteString, + getBuf, setBuf, getWBuf, setWBuf, + getAdBuf, setAdBuf, + getReadSn, getWriteSn, succReadSn, succWriteSn, + resetReadSn, resetWriteSn, + getCipherSuiteSt, setCipherSuiteSt, + flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys, + getInitSet, setInitSet, S.InitialSettings, + S.Alert(..), S.AlertLevel(..), S.AlertDesc(..), + S.ContentType(..), + S.CipherSuite(..), S.KeyEx(..), S.BulkEnc(..), + S.PartnerId, S.newPartnerId, S.Keys(..), S.nullKeys, + + getClientFinished, setClientFinished, + getServerFinished, setServerFinished, + S.CertSecretKey(..), + ) where + +import Control.Monad (liftM) +import "monads-tf" Control.Monad.Trans (lift) +import "monads-tf" Control.Monad.State (StateT, evalStateT, gets, modify) +import "monads-tf" Control.Monad.Error (ErrorT, runErrorT) +import Data.Word (Word64) +import Data.HandleLike (HandleLike(..)) +import "crypto-random" Crypto.Random (CPRG, cprgGenerate) + +import qualified Data.ByteString as BS + +import qualified Network.PeyoTLS.State as S ( + HandshakeState, initState, PartnerId, newPartnerId, Keys(..), nullKeys, + ContentType(..), Alert(..), AlertLevel(..), AlertDesc(..), + CipherSuite(..), KeyEx(..), BulkEnc(..), + randomGen, setRandomGen, + setBuf, getBuf, setWBuf, getWBuf, + setAdBuf, getAdBuf, + getReadSN, getWriteSN, succReadSN, succWriteSN, resetReadSN, resetWriteSN, + getCipherSuite, setCipherSuite, + flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys, + getInitSet, setInitSet, + getClientFinished, setClientFinished, + getServerFinished, setServerFinished, + + InitialSettings, + CertSecretKey(..), + ) + +type TlsM h g = ErrorT S.Alert (StateT (S.HandshakeState h g) (HandleMonad h)) + +evalTlsM :: HandleLike h => + TlsM h g a -> S.HandshakeState h g -> HandleMonad h (Either S.Alert a) +evalTlsM = evalStateT . runErrorT + +getBuf, getWBuf :: HandleLike h => + S.PartnerId -> TlsM h g (S.ContentType, BS.ByteString) +getBuf = gets . S.getBuf; getWBuf = gets . S.getWBuf + +getAdBuf :: HandleLike h => S.PartnerId -> TlsM h g BS.ByteString +getAdBuf = gets . S.getAdBuf + +setAdBuf :: HandleLike h => S.PartnerId -> BS.ByteString -> TlsM h g () +setAdBuf = (modify .) . S.setAdBuf + +setBuf, setWBuf :: HandleLike h => + S.PartnerId -> (S.ContentType, BS.ByteString) -> TlsM h g () +setBuf = (modify .) . S.setBuf; setWBuf = (modify .) . S.setWBuf + +getWriteSn, getReadSn :: HandleLike h => S.PartnerId -> TlsM h g Word64 +getWriteSn = gets . S.getWriteSN; getReadSn = gets . S.getReadSN + +succWriteSn, succReadSn :: HandleLike h => S.PartnerId -> TlsM h g () +succWriteSn = modify . S.succWriteSN; succReadSn = modify . S.succReadSN + +resetWriteSn, resetReadSn :: HandleLike h => S.PartnerId -> TlsM h g () +resetWriteSn = modify . S.resetWriteSN; resetReadSn = modify . S.resetReadSN + +getCipherSuiteSt :: HandleLike h => S.PartnerId -> TlsM h g S.CipherSuite +getCipherSuiteSt = gets . S.getCipherSuite + +setCipherSuiteSt :: HandleLike h => S.PartnerId -> S.CipherSuite -> TlsM h g () +setCipherSuiteSt = (modify .) . S.setCipherSuite + +setKeys :: HandleLike h => S.PartnerId -> S.Keys -> TlsM h g () +setKeys = (modify .) . S.setKeys + +getKeys :: HandleLike h => S.PartnerId -> TlsM h g S.Keys +getKeys = gets . S.getKeys + +getInitSet :: HandleLike h => S.PartnerId -> TlsM h g S.InitialSettings +getInitSet = gets . S.getInitSet + +setInitSet :: HandleLike h => S.PartnerId -> S.InitialSettings -> TlsM h g () +setInitSet = (modify .) . S.setInitSet + +getClientFinished, getServerFinished :: + HandleLike h => S.PartnerId -> TlsM h g BS.ByteString +getClientFinished = gets . S.getClientFinished +getServerFinished = gets . S.getServerFinished + +setClientFinished, setServerFinished :: + HandleLike h => S.PartnerId -> BS.ByteString -> TlsM h g () +setClientFinished = (modify .) . S.setClientFinished +setServerFinished = (modify .) . S.setServerFinished + +flushCipherSuiteRead, flushCipherSuiteWrite :: + HandleLike h => S.PartnerId -> TlsM h g () +flushCipherSuiteRead = modify . S.flushCipherSuiteRead +flushCipherSuiteWrite = modify . S.flushCipherSuiteWrite + +withRandom :: HandleLike h => (gen -> (a, gen)) -> TlsM h gen a +withRandom p = do + (x, g') <- p `liftM` gets S.randomGen + modify $ S.setRandomGen g' + return x + +randomByteString :: (HandleLike h, CPRG g) => Int -> TlsM h g BS.ByteString +randomByteString = withRandom . cprgGenerate + +thlGet :: HandleLike h => h -> Int -> TlsM h g BS.ByteString +thlGet = ((lift . lift) .) . hlGet + +thlPut :: HandleLike h => h -> BS.ByteString -> TlsM h g () +thlPut = ((lift . lift) .) . hlPut + +thlClose :: HandleLike h => h -> TlsM h g () +thlClose = lift . lift . hlClose + +thlDebug :: HandleLike h => + h -> DebugLevel h -> BS.ByteString -> TlsM h gen () +thlDebug = (((lift . lift) .) .) . hlDebug + +thlError :: HandleLike h => h -> BS.ByteString -> TlsM h g a +thlError = ((lift . lift) .) . hlError diff --git a/src/Network/PeyoTLS/Run.hs b/src/Network/PeyoTLS/Run.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Run.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports, TypeFamilies #-} + +module Network.PeyoTLS.Run ( + TH.TlsM, TH.run, HandshakeM, execHandshakeM, rerunHandshakeM, + withRandom, randomByteString, + ValidateHandle(..), handshakeValidate, + TH.TlsHandle(..), TH.ContentType(..), + getCipherSuite, setCipherSuite, flushCipherSuite, debugCipherSuite, + tlsGetContentType, tlsGet, tlsPut, tlsPutNH, + generateKeys, encryptRsa, decryptRsa, rsaPadding, + TH.Alert(..), TH.AlertLevel(..), TH.AlertDesc(..), + TH.Side(..), TH.RW(..), handshakeHash, finishedHash, throwError, + TH.hlPut_, TH.hlDebug_, TH.hlClose_, + TH.tGetLine, TH.tGetContent, tlsGet_, tlsPut_, tlsGet__, + tGetLine_, tGetContent_, + getClientFinished, setClientFinished, + getServerFinished, setServerFinished, + + resetSequenceNumber, + + getSettings, setSettings, + flushAppData_, + + getAdBuf, setAdBuf, + pushAdBufH, + + TH.CertSecretKey(..) + ) where + +import Prelude hiding (read) + +import Control.Applicative +import qualified Data.ASN1.Types as ASN1 +import Control.Arrow (first) +import Control.Monad (liftM) +import "monads-tf" Control.Monad.Trans (lift) +import "monads-tf" Control.Monad.State ( + StateT, evalStateT, execStateT, get, gets, put, modify) +import qualified "monads-tf" Control.Monad.Error as E (throwError) +import "monads-tf" Control.Monad.Error.Class (strMsg) +import Data.HandleLike (HandleLike(..)) +import System.IO (Handle) +import "crypto-random" Crypto.Random (CPRG) + +import qualified Data.ByteString as BS +import qualified Data.X509 as X509 +import qualified Data.X509.Validation as X509 +import qualified Data.X509.CertificateStore as X509 +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Crypto.PubKey.HashDescr as HD +import qualified Crypto.PubKey.RSA as RSA +import qualified Crypto.PubKey.RSA.PKCS15 as RSA + +import qualified Network.PeyoTLS.Handle as TH ( + TlsM, Alert(..), AlertLevel(..), AlertDesc(..), + run, withRandom, randomByteString, + TlsHandle(..), ContentType(..), + newHandle, getContentType, tlsGet, tlsPut, generateKeys, + debugCipherSuite, + getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt, setKeys, + Side(..), RW(..), finishedHash, handshakeHash, CipherSuite(..), + hlPut_, hlDebug_, hlClose_, tGetContent, tGetLine, tGetLine_, + getClientFinishedT, setClientFinishedT, + getServerFinishedT, setServerFinishedT, + + resetSequenceNumber, + + getInitSetT, setInitSetT, InitialSettings, + tlsGet_, + flushAppData, + getAdBufT, + setAdBufT, + + CertSecretKey(..), + ) + +resetSequenceNumber :: HandleLike h => TH.RW -> HandshakeM h g () +resetSequenceNumber rw = gets fst >>= lift . flip TH.resetSequenceNumber rw + +tlsGet_ :: (HandleLike h, CPRG g) => + (TH.TlsHandle h g -> TH.TlsM h g ()) -> + (TH.TlsHandle h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle h g, SHA256.Ctx)) +tlsGet_ = TH.tlsGet_ + +tlsGet__ :: (HandleLike h, CPRG g) => + (TH.TlsHandle h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle h g, SHA256.Ctx)) +tlsGet__ = TH.tlsGet True + +tGetLine_, tGetContent_ :: (HandleLike h, CPRG g) => + (TH.TlsHandle h g -> TH.TlsM h g ()) -> + TH.TlsHandle h g -> TH.TlsM h g (TH.ContentType, BS.ByteString) +tGetLine_ = TH.tGetLine_ + +flushAppData_ :: (HandleLike h, CPRG g) => HandshakeM h g (BS.ByteString, Bool) +flushAppData_ = gets fst >>= lift . TH.flushAppData + +tGetContent_ rn t = do + ct <- TH.getContentType t + case ct of + TH.CTHandshake -> rn t >> tGetContent_ rn t + _ -> TH.tGetContent t + +tlsPut_ :: (HandleLike h, CPRG g) => + (TH.TlsHandle h g, SHA256.Ctx) -> TH.ContentType -> BS.ByteString -> TH.TlsM h g (TH.TlsHandle h g, SHA256.Ctx) +tlsPut_ = TH.tlsPut True + +throwError :: HandleLike h => + TH.AlertLevel -> TH.AlertDesc -> String -> HandshakeM h g a +throwError al ad m = E.throwError $ TH.Alert al ad m + +type HandshakeM h g = StateT (TH.TlsHandle h g, SHA256.Ctx) (TH.TlsM h g) + +execHandshakeM :: HandleLike h => + h -> HandshakeM h g () -> TH.TlsM h g (TH.TlsHandle h g) +execHandshakeM h = + liftM fst . ((, SHA256.init) `liftM` TH.newHandle h >>=) . execStateT + +rerunHandshakeM :: + HandleLike h => TH.TlsHandle h g -> HandshakeM h g a -> TH.TlsM h g a +rerunHandshakeM t hm = evalStateT hm (t, SHA256.init) + +withRandom :: HandleLike h => (g -> (a, g)) -> HandshakeM h g a +withRandom = lift . TH.withRandom + +randomByteString :: (HandleLike h, CPRG g) => Int -> HandshakeM h g BS.ByteString +randomByteString = lift . TH.randomByteString + +class HandleLike h => ValidateHandle h where + validate :: h -> X509.CertificateStore -> X509.CertificateChain -> + HandleMonad h [X509.FailedReason] + +instance ValidateHandle Handle where + validate _ cs (X509.CertificateChain cc) = + X509.validate X509.HashSHA256 X509.defaultHooks + validationChecks cs validationCache ("", "") $ + X509.CertificateChain cc + where + validationCache = X509.ValidationCache + (\_ _ _ -> return X509.ValidationCacheUnknown) + (\_ _ _ -> return ()) + validationChecks = X509.defaultChecks { X509.checkFQHN = False } + +certNames :: X509.Certificate -> [String] +certNames = nms + where + nms c = maybe id (:) <$> nms_ <*> ans $ c + nms_ = (ASN1.asn1CharacterToString =<<) . + X509.getDnElement X509.DnCommonName . X509.certSubjectDN + ans = maybe [] ((\ns -> [s | X509.AltNameDNS s <- ns]) + . \(X509.ExtSubjectAltName ns) -> ns) + . X509.extensionGet . X509.certExtensions + +handshakeValidate :: ValidateHandle h => + X509.CertificateStore -> X509.CertificateChain -> + HandshakeM h g [X509.FailedReason] +handshakeValidate cs cc@(X509.CertificateChain c) = gets fst >>= \t -> do + modify . first $ const t { TH.names = certNames . X509.getCertificate $ last c } + lift . lift . lift $ validate (TH.tlsHandle t) cs cc + +setCipherSuite :: HandleLike h => TH.CipherSuite -> HandshakeM h g () +setCipherSuite cs = do + t <- gets fst + lift $ TH.setCipherSuiteSt (TH.clientId t) cs + +getCipherSuite :: HandleLike h => HandshakeM h g TH.CipherSuite +getCipherSuite = do + t <- gets fst + lift . TH.getCipherSuiteSt $ TH.clientId t + +flushCipherSuite :: (HandleLike h, CPRG g) => TH.RW -> HandshakeM h g () +flushCipherSuite p = do + t <- gets fst + lift $ TH.flushCipherSuiteSt p (TH.clientId t) + +debugCipherSuite :: HandleLike h => String -> HandshakeM h g () +debugCipherSuite m = do t <- gets fst; lift $ TH.debugCipherSuite t m + +tlsGetContentType :: (HandleLike h, CPRG g) => HandshakeM h g TH.ContentType +tlsGetContentType = gets fst >>= lift . TH.getContentType + +tlsGet :: (HandleLike h, CPRG g) => Bool -> Int -> HandshakeM h g BS.ByteString +tlsGet b n = do ((_, bs), t') <- lift . flip (TH.tlsGet b) n =<< get; put t'; return bs + +tlsPut, tlsPutNH :: (HandleLike h, CPRG g) => + TH.ContentType -> BS.ByteString -> HandshakeM h g () +tlsPut ct bs = get >>= lift . (\t -> TH.tlsPut True t ct bs) >>= put +tlsPutNH ct bs = get >>= lift . (\t -> TH.tlsPut False t ct bs) >>= put + +generateKeys :: HandleLike h => TH.Side -> + (BS.ByteString, BS.ByteString) -> BS.ByteString -> HandshakeM h g () +generateKeys p (cr, sr) pms = do + t <- gets fst + cs <- lift $ TH.getCipherSuiteSt (TH.clientId t) + k <- lift $ TH.generateKeys t p cs cr sr pms + lift $ TH.setKeys (TH.clientId t) k + +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) + +decryptRsa :: (HandleLike h, CPRG g) => + RSA.PrivateKey -> BS.ByteString -> HandshakeM h g BS.ByteString +decryptRsa sk e = either (E.throwError . strMsg . show) return =<< + withRandom (\g -> RSA.decryptSafer g sk e) + +rsaPadding :: RSA.PublicKey -> BS.ByteString -> BS.ByteString +rsaPadding pk bs = case RSA.padSignature (RSA.public_size pk) $ + HD.digestToASN1 HD.hashDescrSHA256 bs of + Right pd -> pd; Left m -> error $ show m + +handshakeHash :: HandleLike h => HandshakeM h g BS.ByteString +handshakeHash = get >>= lift . TH.handshakeHash + +finishedHash :: (HandleLike h, CPRG g) => TH.Side -> HandshakeM h g BS.ByteString +finishedHash p = get >>= lift . flip TH.finishedHash p + +getClientFinished, getServerFinished :: HandleLike h => HandshakeM h g BS.ByteString +getClientFinished = gets fst >>= lift . TH.getClientFinishedT +getServerFinished = gets fst >>= lift . TH.getServerFinishedT + +setClientFinished, setServerFinished :: + HandleLike h => BS.ByteString -> HandshakeM h g () +setClientFinished cf = gets fst >>= lift . flip TH.setClientFinishedT cf +setServerFinished cf = gets fst >>= lift . flip TH.setServerFinishedT cf + +getSettings :: HandleLike h => HandshakeM h g TH.InitialSettings +getSettings = gets fst >>= lift . TH.getInitSetT + +setSettings :: HandleLike h => TH.InitialSettings -> HandshakeM h g () +setSettings is = gets fst >>= lift . flip TH.setInitSetT is + +getAdBuf :: HandleLike h => TH.TlsHandle h g -> TH.TlsM h g BS.ByteString +getAdBuf = TH.getAdBufT + +setAdBuf :: HandleLike h => + TH.TlsHandle h g -> BS.ByteString -> TH.TlsM h g () +setAdBuf = TH.setAdBufT + +getAdBufH :: HandleLike h => HandshakeM h g BS.ByteString +getAdBufH = gets fst >>= lift . TH.getAdBufT + +setAdBufH :: HandleLike h => BS.ByteString -> HandshakeM h g () +setAdBufH bs = gets fst >>= lift . flip TH.setAdBufT bs + +pushAdBufH :: HandleLike h => BS.ByteString -> HandshakeM h g () +pushAdBufH bs = do + bf <- getAdBufH + setAdBufH $ bf `BS.append` bs 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 @@ -1,21 +1,21 @@ -{-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, FlexibleContexts, - UndecidableInstances, PackageImports #-} +{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports, TupleSections #-} module Network.PeyoTLS.Server ( - PeyotlsM, PeyotlsHandleS, TlsM, TlsHandleS, - run, open, renegotiate, names, - CipherSuite(..), KeyExchange(..), BulkEncryption(..), - ValidateHandle(..), CertSecretKey ) where + PeyotlsM, PeyotlsHandleS, TlsM, TlsHandleS, run, open, renegotiate, names, + CipherSuite(..), KeyEx(..), BulkEnc(..), 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 Data.Maybe (listToMaybe, mapMaybe) import Data.List (find) import Data.Word (Word8) import Data.HandleLike (HandleLike(..)) import System.IO (Handle) import "crypto-random" Crypto.Random (CPRG, SystemRNG) -import qualified "monads-tf" Control.Monad.Error as E -import qualified "monads-tf" Control.Monad.Error.Class as E import qualified Data.ByteString as BS import qualified Data.X509 as X509 import qualified Data.X509.Validation as X509 @@ -27,147 +27,168 @@ import qualified Crypto.Types.PubKey.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Network.PeyoTLS.HandshakeBase as HB -import Network.PeyoTLS.HandshakeBase ( +import qualified Network.PeyoTLS.Base as HB (names) +import Network.PeyoTLS.Base ( PeyotlsM, TlsM, run, HandshakeM, execHandshakeM, rerunHandshakeM, - setCipherSuite, withRandom, randomByteString, + throwError, debug, debugCipherSuite, + withRandom, randomByteString, ValidateHandle(..), handshakeValidate, - TlsHandle, CertSecretKey(..), + TlsHandle, CertSecretKey(..), isRsaKey, isEcdsaKey, readHandshake, getChangeCipherSpec, writeHandshake, putChangeCipherSpec, - writeHandshakeNoHash, + writeHandshakeNH, AlertLevel(..), AlertDesc(..), ClientHello(..), ServerHello(..), SessionId(..), Extension(..), - CipherSuite(..), KeyExchange(..), BulkEncryption(..), - CompressionMethod(..), HashAlg(..), SignAlg(..), - getClientFinished, setClientFinished, - getServerFinished, setServerFinished, + CipherSuite(..), KeyEx(..), BulkEnc(..), + CompMethod(..), HashAlg(..), SignAlg(..), + getCipherSuite, setCipherSuite, + getClientFinished, getServerFinished, ServerKeyExchange(..), certificateRequest, ClientCertificateType(..), SecretKey(..), ServerHelloDone(..), ClientKeyExchange(..), Epms(..), - generateKeys, decryptRsa, rsaPadding, debugCipherSuite, - DigitallySigned(..), handshakeHash, flushCipherSuite, - Finished(..), Side(..), RW(..), finishedHash, - DhParam(..), dh3072Modp, secp256r1, throwError, + generateKeys, decryptRsa, rsaPadding, + DigitallySigned(..), handshakeHash, + RW(..), flushCipherSuite, + Side(..), finishedHash, + DhParam(..), dh3072Modp, secp256r1, - hlGetRn, hlGetLineRn, hlGetContentRn, debug ) + Handshake(HHelloReq), eRenegoInfo, getSettings, setSettings, flushAppData, + hlGetRn, hlGetLineRn, hlGetContentRn ) type PeyotlsHandleS = TlsHandleS Handle SystemRNG +newtype TlsHandleS h g = TlsHandleS { tlsHandleS :: TlsHandle h g } deriving Show + +instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandleS h g) where + type HandleMonad (TlsHandleS h g) = TlsM h g + type DebugLevel (TlsHandleS h g) = DebugLevel h + hlPut (TlsHandleS t) = hlPut t + hlGet = hlGetRn rehandshake . tlsHandleS + hlGetLine = hlGetLineRn rehandshake . tlsHandleS + hlGetContent = hlGetContentRn rehandshake . tlsHandleS + hlDebug (TlsHandleS t) = hlDebug t + hlClose (TlsHandleS t) = hlClose t + +type Version = (Word8, Word8) +type Settings = ( + [CipherSuite], + Maybe (RSA.PrivateKey, X509.CertificateChain), + Maybe (ECDSA.PrivateKey, X509.CertificateChain), + Maybe X509.CertificateStore ) + +version :: Version +version = (3, 3) + names :: TlsHandleS h g -> [String] names = HB.names . tlsHandleS -open :: (ValidateHandle h, CPRG g) => - h -> [CipherSuite] -> [(CertSecretKey, X509.CertificateChain)] -> +open :: (ValidateHandle h, CPRG g) => h -> + [CipherSuite] -> [(CertSecretKey, X509.CertificateChain)] -> Maybe X509.CertificateStore -> TlsM h g (TlsHandleS h g) -open h cssv crts mcs = (TlsHandleS `liftM`) . execHandshakeM h $ do - HB.setInitSet (cssv, crts, mcs) - (cs, cr, cv, rn) <- clientHello $ filterCS crts cssv - succeed cs cr cv crts mcs rn +open h cssv crts mcs = liftM TlsHandleS . execHandshakeM h $ + ((>>) <$> setSettings <*> 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 -renegotiate :: - (ValidateHandle h, CPRG g) => TlsHandleS h g -> TlsM h g () -renegotiate (TlsHandleS t) = rerunHandshakeM t $ do - writeHandshakeNoHash HB.HHelloRequest - (ret, ne) <- HB.flushAppData - bf <- HB.getAdBufH - HB.setAdBufH $ bf `BS.append` ret - when ne $ handshake +renegotiate :: (ValidateHandle h, CPRG g) => TlsHandleS h g -> TlsM h g () +renegotiate (TlsHandleS t) = rerunHandshakeM t $ writeHandshakeNH HHelloReq >> + flushAppData >>= flip when (handshake =<< getSettings) rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g () -rehandshake t = rerunHandshakeM t handshake +rehandshake t = rerunHandshakeM t $ handshake =<< getSettings -handshake :: (ValidateHandle h, CPRG g) => HandshakeM h g () -handshake = do - (cssv, crts, mcs) <- HB.getInitSet - (cs, cr, cv, rn) <- clientHello $ filterCS crts cssv - succeed cs cr cv crts mcs rn +handshake :: (ValidateHandle h, CPRG g) => Settings -> HandshakeM h g () +handshake (cssv, rcrt, ecrt, mcs) = do + (ke, be, cr, cv, rn) <- clientHello cssv + sr <- serverHello (snd <$> rcrt) (snd <$> ecrt) rn + ha <- case be of + AES_128_CBC_SHA -> return Sha1 + AES_128_CBC_SHA256 -> return Sha256 + _ -> throwError ALFatal ADInternalError $ + pre ++ "not implemented bulk encryption type" + mpk <- ($ mcs) . ($ (cr, sr)) $ case (ke, rcrt, 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 + _ -> \_ _ -> throwError ALFatal ADInternalError $ + pre ++ "no implemented key exchange type or " ++ + "no applicable certificate files" + maybe (return ()) certificateVerify mpk + getChangeCipherSpec >> flushCipherSuite Read + (==) `liftM` finishedHash Client `ap` readHandshake >>= \ok -> + unless ok . throwError ALFatal ADDecryptError $ + pre ++ "wrong finished hash" + putChangeCipherSpec >> flushCipherSuite Write + writeHandshake =<< finishedHash Server + where pre = "Network.PeyoTLS.Server.handshake: " -clientHello :: (HandleLike h, CPRG g) => - [CipherSuite] -> HandshakeM h g (CipherSuite, BS.ByteString, Version, Bool) +clientHello :: (HandleLike h, CPRG g) => [CipherSuite] -> + HandshakeM h g (KeyEx, BulkEnc, BS.ByteString, Version, Bool) clientHello cssv = do - cf0 <- getClientFinished - ch@(ClientHello cv cr _sid cscl cms me) <- readHandshake - let (cf, rn) = case me of - Nothing -> ("", False) - Just e -> case getRenegoInfo cscl e of - Nothing -> ("", False) - Just c -> (c, True) - debug "medium" ch - unless (cf == cf0) $ E.throwError "clientHello" - chk cv cscl cms >> return (merge cssv cscl, cr, cv, rn) + ClientHello cv cr _sid cscl cms me <- readHandshake + checkRenegotiation cscl me + unless (cv >= version) . throwError ALFatal ADProtocolVersion $ + pre ++ "client version should 3.3 or more" + unless (CompMethodNull `elem` cms) . throwError ALFatal ADDecodeError $ + 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) + _ -> throwError ALFatal ADHandshakeFailure $ + pre ++ "no acceptable set of security parameters" + return (ke, be, cr, cv, True) + where pre = "Network.PeyoTLS.Server.clientHello: " + +checkRenegotiation :: + HandleLike h => [CipherSuite] -> Maybe [Extension] -> HandshakeM h g () +checkRenegotiation cscl me = do + case mcf of + Just cf -> (cf ==) `liftM` getClientFinished >>= \ok -> unless ok . + throwError ALFatal ADHandshakeFailure $ + pre ++ "bad renegotiation" + _ -> throwError ALFatal ADInsufficientSecurity $ + pre ++ "require secure renegotiation" where - merge sv cl = case find (`elem` cl) sv of - Just cs -> cs; _ -> CipherSuite RSA AES_128_CBC_SHA - chk cv _css cms - | cv < version = throwError ALFatal ADProtocolVersion $ - pmsg ++ "client version should 3.3 or more" - | CompressionMethodNull `notElem` cms = - throwError ALFatal ADDecodeError $ - pmsg ++ "compression method NULL must be supported" - | otherwise = return () - where pmsg = "TlsServer.clientHello: " - getRenegoInfo [] [] = Nothing - getRenegoInfo (TLS_EMPTY_RENEGOTIATION_INFO_SCSV : _) _ = Just "" - getRenegoInfo (_ : css) e = getRenegoInfo css e - getRenegoInfo [] (ERenegoInfo rn : _) = Just rn - getRenegoInfo [] (_ : es) = getRenegoInfo [] es + pre = "Network.PeyoTLS.Server.checkRenegotiation: " + mcf = case (EMPTY_RENEGOTIATION_INFO `elem` cscl, me) of + (True, _) -> Just "" + (_, Just e) -> listToMaybe $ mapMaybe eRenegoInfo e + (_, _) -> Nothing -serverHello :: (HandleLike h, CPRG g) => CipherSuite -> - X509.CertificateChain -> X509.CertificateChain -> Bool -> +serverHello :: (HandleLike h, CPRG g) => + Maybe X509.CertificateChain -> Maybe X509.CertificateChain -> Bool -> HandshakeM h g BS.ByteString -serverHello cs@(CipherSuite ke _) rcc ecc rn = do +serverHello rcc ecc rn = do + cs@(CipherSuite ke _) <- getCipherSuite sr <- randomByteString 32 cf <- getClientFinished sf <- getServerFinished writeHandshake . ServerHello - version sr (SessionId "") cs CompressionMethodNull $ if rn + version sr (SessionId "") cs CompMethodNull $ if rn then Just [ERenegoInfo $ cf `BS.append` sf] else Nothing - writeHandshake $ case ke of ECDHE_ECDSA -> ecc; _ -> rcc + debug "critical" ("SERVER HASH AFTER SERVERHELLO" :: String) + debug "critical" =<< handshakeHash + writeHandshake $ case (ke, rcc, ecc) of + (ECDHE_ECDSA, _, Just c) -> c + (_, Just c, _) -> c + _ -> error "serverHello" return sr -serverHello _ _ _ _ = E.throwError "TlsServer.serverHello: never occur" - -succeed :: (ValidateHandle h, CPRG g) => CipherSuite -> BS.ByteString -> - Version -> [(CertSecretKey, X509.CertificateChain)] -> - Maybe X509.CertificateStore -> Bool -> HandshakeM h g () -succeed cs@(CipherSuite ke be) cr cv crts mcs rn = do - sr <- serverHello cs rcc ecc rn - setCipherSuite cs - ha <- case be of - AES_128_CBC_SHA -> return Sha1 - AES_128_CBC_SHA256 -> return Sha256 - _ -> E.throwError - "TlsServer.succeed: not implemented bulk encryption type" - mpk <- (\kep -> kep (cr, sr) mcs) $ case ke of - RSA -> rsaKeyExchange rsk cv - DHE_RSA -> dhKeyExchange ha dh3072Modp rsk - ECDHE_RSA -> dhKeyExchange ha secp256r1 rsk - ECDHE_ECDSA -> dhKeyExchange ha secp256r1 esk - _ -> \_ _ -> E.throwError - "TlsServer.succeed: not implemented key exchange type" - maybe (return ()) certificateVerify mpk - getChangeCipherSpec >> flushCipherSuite Read - cf@(Finished cfb) <- finishedHash Client - rcf <- readHandshake - debug "low" ("client finished hash" :: String) - debug "low" cf - debug "low" rcf - unless (cf == rcf) $ throwError ALFatal ADDecryptError - "TlsServer.succeed: wrong finished hash" - setClientFinished cfb - putChangeCipherSpec >> flushCipherSuite Write - sf@(Finished sfb) <- finishedHash Server - setServerFinished sfb - writeHandshake sf - where - Just (RsaKey rsk, rcc) = find isRsa crts - Just (EcdsaKey esk, ecc) = find isEcdsa crts - isRsa (RsaKey _, _) = True - isRsa _ = False -succeed _ _ _ _ _ _ = E.throwError "Network.PeyoTLS.Server.succeed: not implemented" + {- +serverHello _ _ _ _ = throwError ALFatal ADInternalError + "Network.PeyoTLS.Server.serverHello: never occur" + -} rsaKeyExchange :: (ValidateHandle h, CPRG g) => RSA.PrivateKey -> Version -> (BS.ByteString, BS.ByteString) -> Maybe X509.CertificateStore -> @@ -208,6 +229,8 @@ flip (maybe $ return ()) mcs $ writeHandshake . certificateRequest [CTRsaSign, CTEcdsaSign] [(Sha256, Rsa), (Sha256, Ecdsa)] writeHandshake ServerHelloDone + debug "high" ("SERVER HASH AFTER SERVERHELLODONE" :: String) + debug "high" =<< handshakeHash maybe (return Nothing) (liftM Just . clientCertificate) mcs clientCertificate :: (ValidateHandle h, CPRG g) => @@ -233,16 +256,18 @@ Epms epms <- readHandshake debug "low" ("EPMS" :: String) debug "low" epms - generateKeys Server rs =<< mkpms epms `E.catchError` const + generateKeys Server rs =<< mkpms epms `catchError` const ((BS.cons cvj . BS.cons cvn) `liftM` randomByteString 46) where mkpms epms = do pms <- decryptRsa sk epms - unless (BS.length pms == 48) $ E.throwError "mkpms: length" + unless (BS.length pms == 48) $ + throwError ALFatal ADHandshakeFailure "" case BS.unpack $ BS.take 2 pms of [pvj, pvn] -> unless (pvj == cvj && pvn == cvn) $ - E.throwError "mkpms: version" - _ -> E.throwError "mkpms: never occur" + throwError ALFatal ADHandshakeFailure "" + _ -> error $ "Network.PeyoTLS.Server." ++ + "rsaClientKeyExchange: never occur" debug "low" ("PMS" :: String) debug "low" pms return pms @@ -254,8 +279,8 @@ ClientKeyExchange cke <- readHandshake let Right pv = B.decode cke generateKeys Server rs =<< case Right $ calculateShared dp sv pv of - Left em -> E.throwError . E.strMsg $ - "TlsServer.dhClientKeyExchange: " ++ em + Left em -> throwError ALFatal ADInternalError $ + "Network.PeyoTLS.Server.dhClientKeyExchange: " ++ em Right sh -> return sh certificateVerify :: (HandleLike h, CPRG g) => X509.PubKey -> HandshakeM h g () @@ -288,62 +313,3 @@ (either error id $ B.decode y) certificateVerify p = throwError ALFatal ADUnsupportedCertificate $ "TlsServer.certificateVerify: not implement: " ++ show p - -newtype TlsHandleS h g = TlsHandleS { tlsHandleS :: TlsHandle h g } - -instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandleS h g) where - type HandleMonad (TlsHandleS h g) = HandleMonad (TlsHandle h g) - type DebugLevel (TlsHandleS h g) = DebugLevel (TlsHandle h g) - hlPut (TlsHandleS t) = hlPut t - hlGet = hlGet_ -- hlGetRn rehandshake . tlsHandleS - hlGetLine = hlGetLine_ -- hlGetLineRn rehandshake . tlsHandleS - hlGetContent = hlGetContent_ -- hlGetContentRn rehandshake . tlsHandleS - hlDebug (TlsHandleS t) = hlDebug t - hlClose (TlsHandleS t) = hlClose t - -hlGet_ :: (ValidateHandle h, CPRG g) => - TlsHandleS h g -> Int -> TlsM h g BS.ByteString -hlGet_ (TlsHandleS t) n = do - bf <- HB.getAdBuf t - if (BS.length bf >= 0) - then do let (ret, rest) = BS.splitAt n bf - HB.setAdBuf t rest - return ret - else (bf `BS.append`) `liftM` hlGetRn rehandshake t (n - BS.length bf) - -hlGetLine_ :: (ValidateHandle h, CPRG g) => - TlsHandleS h g -> TlsM h g BS.ByteString -hlGetLine_ (TlsHandleS t) = do - bf <- HB.getAdBuf t - if (10 `BS.elem` bf) - then do let (ret, rest) = BS.span (/= 10) bf - HB.setAdBuf t $ BS.tail rest - return ret - else (bf `BS.append`) `liftM` hlGetLineRn rehandshake t - -hlGetContent_ :: (ValidateHandle h, CPRG g) => - TlsHandleS h g -> TlsM h g BS.ByteString -hlGetContent_ (TlsHandleS t) = do - bf <- HB.getAdBuf t - if BS.null bf - then hlGetContentRn rehandshake t - else do HB.setAdBuf t "" - return bf - -type Version = (Word8, Word8) - -version :: Version -version = (3, 3) - -filterCS :: [(CertSecretKey, X509.CertificateChain)] -> - [CipherSuite] -> [CipherSuite] -filterCS crts cs = case find isEcdsa crts of - Just _ -> cs - _ -> filter (not . isEcdsaCS) cs - where - isEcdsaCS (CipherSuite ECDHE_ECDSA _) = True - isEcdsaCS _ = False - -isEcdsa :: (CertSecretKey, X509.CertificateChain) -> Bool -isEcdsa (EcdsaKey _, _) = True -isEcdsa _ = False diff --git a/src/Network/PeyoTLS/State.hs b/src/Network/PeyoTLS/State.hs --- a/src/Network/PeyoTLS/State.hs +++ b/src/Network/PeyoTLS/State.hs @@ -3,7 +3,7 @@ module Network.PeyoTLS.State ( HandshakeState, initState, PartnerId, newPartnerId, Keys(..), nullKeys, ContentType(..), Alert(..), AlertLevel(..), AlertDesc(..), - CipherSuite(..), KeyExchange(..), BulkEncryption(..), + CipherSuite(..), KeyEx(..), BulkEnc(..), randomGen, setRandomGen, getBuf, setBuf, getWBuf, setWBuf, getAdBuf, setAdBuf, @@ -15,6 +15,7 @@ getServerFinished, setServerFinished, InitialSettings, + CertSecretKey(..), ) where import "monads-tf" Control.Monad.Error.Class (Error(strMsg)) @@ -25,13 +26,16 @@ import qualified Data.ByteString as BS import qualified Codec.Bytable.BigEndian as B -import Network.PeyoTLS.CertSecretKey +import Network.PeyoTLS.CertSecretKey (CertSecretKey(..)) import qualified Data.X509 as X509 import qualified Data.X509.CertificateStore as X509 import Network.PeyoTLS.CipherSuite ( - CipherSuite(..), KeyExchange(..), BulkEncryption(..)) + CipherSuite(..), KeyEx(..), BulkEnc(..)) +import qualified Crypto.PubKey.RSA as RSA +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA + data HandshakeState h g = HandshakeState { randomGen :: g, nextPartnerId :: Int, states :: [(PartnerId, StateOne g)] } @@ -53,12 +57,14 @@ radBuffer = "", readSN = 0, writeSN = 0, rnClientFinished = "", rnServerFinished = "", - initialSettings = ([], [], Nothing) + initialSettings = ([], Nothing, Nothing, Nothing) } sos = states s type InitialSettings = ( - [CipherSuite], [(CertSecretKey, X509.CertificateChain)], + [CipherSuite], + Maybe (RSA.PrivateKey, X509.CertificateChain), + Maybe (ECDSA.PrivateKey, X509.CertificateChain), Maybe X509.CertificateStore) data StateOne g = StateOne { @@ -70,9 +76,7 @@ writeSN :: Word64, rnClientFinished :: BS.ByteString, rnServerFinished :: BS.ByteString, - initialSettings :: ( - [CipherSuite], [(CertSecretKey, X509.CertificateChain)], - Maybe X509.CertificateStore) + initialSettings :: InitialSettings } getState :: PartnerId -> HandshakeState h g -> StateOne g @@ -131,10 +135,13 @@ data AlertLevel = ALWarning | ALFatal | ALRaw Word8 deriving Show data AlertDesc - = ADCloseNotify | ADUnexpectedMessage | ADBadRecordMac - | ADUnsupportedCertificate | ADCertificateExpired | ADCertificateUnknown - | ADIllegalParameter | ADUnknownCa | ADDecodeError - | ADDecryptError | ADProtocolVersion | ADRaw Word8 + = ADCloseNotify | ADUnexpectedMessage | ADBadRecordMac + | ADRecordOverflow | ADDecompressionFailure | ADHandshakeFailure + | ADUnsupportedCertificate | ADCertificateExpired | ADCertificateUnknown + | ADIllegalParameter | ADUnknownCa | ADDecodeError + | ADDecryptError | ADProtocolVersion | ADInsufficientSecurity + | ADInternalError + | ADRaw Word8 deriving Show instance Error Alert where diff --git a/src/Network/PeyoTLS/TlsHandle.hs b/src/Network/PeyoTLS/TlsHandle.hs deleted file mode 100644 --- a/src/Network/PeyoTLS/TlsHandle.hs +++ /dev/null @@ -1,394 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, PackageImports #-} - -module Network.PeyoTLS.TlsHandle ( - TlsM, Alert(..), AlertLevel(..), AlertDesc(..), - run, withRandom, randomByteString, - TlsHandle(..), RW(..), Side(..), ContentType(..), CipherSuite(..), - newHandle, getContentType, tlsGet, tlsPut, generateKeys, - debugCipherSuite, - getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt, - setKeys, - handshakeHash, finishedHash, - hlPut_, hlDebug_, hlClose_, tGetLine, tGetLine_, tGetContent, - getClientFinishedT, setClientFinishedT, - getServerFinishedT, setServerFinishedT, - - getInitSetT, setInitSetT, - InitialSettings, - - resetSequenceNumber, - tlsGet_, - flushAppData, - - getAdBufT, setAdBufT, - ) where - -import Prelude hiding (read) - -import Control.Arrow (second) -import Control.Monad (liftM, ap, when, unless) -import "monads-tf" Control.Monad.State (get, put, lift) -import "monads-tf" Control.Monad.Error (throwError, catchError) -import "monads-tf" Control.Monad.Error.Class (strMsg) -import Data.Word (Word16, Word64) -import Data.HandleLike (HandleLike(..)) -import "crypto-random" Crypto.Random (CPRG) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC -import qualified Codec.Bytable.BigEndian as B -import qualified Crypto.Hash.SHA256 as SHA256 - -import Network.PeyoTLS.TlsMonad ( - TlsM, evalTlsM, initState, thlGet, thlPut, thlClose, thlDebug, - withRandom, randomByteString, - getBuf, setBuf, getWBuf, setWBuf, - getAdBuf, setAdBuf, - getReadSn, getWriteSn, succReadSn, succWriteSn, - resetReadSn, resetWriteSn, - getCipherSuiteSt, setCipherSuiteSt, - flushCipherSuiteRead, flushCipherSuiteWrite, getKeys, setKeys, - Alert(..), AlertLevel(..), AlertDesc(..), - ContentType(..), CipherSuite(..), BulkEncryption(..), - PartnerId, newPartnerId, Keys(..), - getClientFinished, setClientFinished, - getServerFinished, setServerFinished, - InitialSettings, - getInitSet, setInitSet, - ) -import qualified Network.PeyoTLS.CryptoTools as CT ( - makeKeys, encrypt, decrypt, hashSha1, hashSha256, finishedHash ) - -data TlsHandle h g = TlsHandle { - clientId :: PartnerId, - tlsHandle :: h, names :: [String] } - -type HandleHash h g = (TlsHandle h g, SHA256.Ctx) - -data Side = Server | Client deriving (Show, Eq) - -run :: HandleLike h => TlsM h g a -> g -> HandleMonad h a -run m g = do - ret <- (`evalTlsM` initState g) $ m `catchError` \a -> throwError a - case ret of - Right r -> return r - Left a -> error $ show a - -newHandle :: HandleLike h => h -> TlsM h g (TlsHandle h g) -newHandle h = do - s <- get - let (i, s') = newPartnerId s - put s' - return TlsHandle { - clientId = i, tlsHandle = h, names = [] } - -getContentType :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g ContentType -getContentType t = do - ct <- fst `liftM` getBuf (clientId t) - (\gt -> case ct of CTNull -> gt; _ -> return ct) $ do - (ct', bf) <- getWholeWithCt t - setBuf (clientId t) (ct', bf) - return ct' - -flushAppData :: (HandleLike h, CPRG g) => - TlsHandle h g -> TlsM h g (BS.ByteString, Bool) -flushAppData t = do - ct <- getContentType t - case ct of - CTAppData -> do - (_, ad) <- tGetContent t - (bs, b) <- flushAppData t - return (ad `BS.append` bs, b) --- liftM (BS.append . snd) (tGetContent t) `ap` flushAppData t - CTAlert -> do - ((_, a), _) <- tlsGet True (t, undefined) 2 - case a of - "\1\0" -> return ("", False) - _ -> throwError "flushAppData" - _ -> return ("", True) - -tlsGet :: (HandleLike h, CPRG g) => Bool -> HandleHash h g -> - Int -> TlsM h g ((ContentType, BS.ByteString), HandleHash h g) -tlsGet b hh@(t, _) n = do - r@(ct, bs) <- buffered t n - (r ,) `liftM` case (ct, b, bs) of - (CTHandshake, _, "\0\0\0\0") -> return hh - (CTHandshake, True, _) -> updateHash hh bs - _ -> return hh - -tlsGet_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) -> - HandleHash h g -> Int -> - TlsM h g ((ContentType, BS.ByteString), HandleHash h g) -tlsGet_ rn hh@(t, _) n = (, hh) `liftM` buffered_ rn t n - -buffered :: (HandleLike h, CPRG g) => - TlsHandle h g -> Int -> TlsM h g (ContentType, BS.ByteString) -buffered t n = do - (ct, b) <- getBuf $ clientId t; let rl = n - BS.length b - if rl <= 0 - then splitRetBuf t n ct b - else do (ct', b') <- getWholeWithCt t - unless (ct' == ct) . throwError . strMsg $ - "Content Type confliction\n" ++ - "\tExpected: " ++ show ct ++ "\n" ++ - "\tActual : " ++ show ct' ++ "\n" ++ - "\tData : " ++ show b' - when (BS.null b') $ throwError "buffered: No data available" - setBuf (clientId t) (ct', b') - second (b `BS.append`) `liftM` buffered t rl - -buffered_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) -> - TlsHandle h g -> Int -> TlsM h g (ContentType, BS.ByteString) -buffered_ rn t n = do - ct0 <- getContentType t - case ct0 of - CTHandshake -> rn t >> buffered_ rn t n - _ -> do (ct, b) <- getBuf $ clientId t; let rl = n - BS.length b - if rl <= 0 - then splitRetBuf t n ct b - else do (ct', b') <- getWholeWithCt t - unless (ct' == ct) . throwError . strMsg $ - "Content Type confliction\n" - when (BS.null b') $ throwError "buffered: No data" - setBuf (clientId t) (ct', b') - second (b `BS.append`) `liftM` buffered_ rn t rl - -splitRetBuf :: HandleLike h => - TlsHandle h g -> Int -> ContentType -> BS.ByteString -> - TlsM h g (ContentType, BS.ByteString) -splitRetBuf t n ct b = do - let (ret, b') = BS.splitAt n b - setBuf (clientId t) $ if BS.null b' then (CTNull, "") else (ct, b') - return (ct, ret) - -getWholeWithCt :: (HandleLike h, CPRG g) => - TlsHandle h g -> TlsM h g (ContentType, BS.ByteString) -getWholeWithCt t = do - flush t - ct <- (either (throwError . strMsg) return . B.decode) =<< read t 1 - [_vmj, _vmn] <- BS.unpack `liftM` read t 2 - e <- read t =<< either (throwError . strMsg) return . B.decode =<< read t 2 - when (BS.null e) $ throwError "TlsHandle.getWholeWithCt: e is null" - p <- decrypt t ct e - thlDebug (tlsHandle t) "medium" . BSC.pack . (++ ": ") $ show ct - thlDebug (tlsHandle t) "medium" . BSC.pack . (++ "\n") . show $ BS.head p - thlDebug (tlsHandle t) "low" . BSC.pack . (++ "\n") $ show p - return (ct, p) - -read :: (HandleLike h, CPRG g) => TlsHandle h g -> Int -> TlsM h g BS.ByteString -read t n = do - r <- thlGet (tlsHandle t) n - unless (BS.length r == n) . throwError . strMsg $ - "TlsHandle.read: can't read " ++ show (BS.length r) ++ " " ++ show n - return r - -decrypt :: HandleLike h => - TlsHandle h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString -decrypt t ct e = do - ks <- getKeys $ clientId t - decrypt_ t ks ct e - -decrypt_ :: HandleLike h => TlsHandle h g -> - Keys -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString -decrypt_ _ Keys{ kReadCS = CipherSuite _ BE_NULL } _ e = return e -decrypt_ t ks ct e = do - let CipherSuite _ be = kReadCS ks - wk = kReadKey ks - mk = kReadMacKey ks - sn <- updateSequenceNumber t Read - hs <- case be of - AES_128_CBC_SHA -> return CT.hashSha1 - AES_128_CBC_SHA256 -> return CT.hashSha256 - _ -> throwError "TlsHandle.decrypt: not implement bulk encryption" - either (throwError . strMsg) return $ - CT.decrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") e - -tlsPut :: (HandleLike h, CPRG g) => Bool -> - HandleHash h g -> ContentType -> BS.ByteString -> TlsM h g (HandleHash h g) -tlsPut b hh@(t, _) ct p = do - (bct, bp) <- getWBuf $ clientId t - case ct of - CTCCSpec -> flush t >> setWBuf (clientId t) (ct, p) >> flush t - _ | bct /= CTNull && ct /= bct -> - flush t >> setWBuf (clientId t) (ct, p) - | otherwise -> setWBuf (clientId t) (ct, bp `BS.append` p) - case (ct, b) of - (CTHandshake, True) -> updateHash hh p - _ -> return hh - -flush :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g () -flush t = do - (bct, bp) <- getWBuf $ clientId t - setWBuf (clientId t) (CTNull, "") - unless (bct == CTNull) $ do - e <- encrypt t bct bp - thlPut (tlsHandle t) $ BS.concat [ - B.encode bct, "\x03\x03", B.addLen (undefined :: Word16) e ] - -encrypt :: (HandleLike h, CPRG g) => - TlsHandle h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString -encrypt t ct p = do - ks <- getKeys $ clientId t - encrypt_ t ks ct p - -encrypt_ :: (HandleLike h, CPRG g) => TlsHandle h g -> - Keys -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString -encrypt_ _ Keys{ kWriteCS = CipherSuite _ BE_NULL } _ p = return p -encrypt_ t ks ct p = do - let CipherSuite _ be = kWriteCS ks - wk = kWriteKey ks - mk = kWriteMacKey ks - sn <- updateSequenceNumber t Write - hs <- case be of - AES_128_CBC_SHA -> return CT.hashSha1 - AES_128_CBC_SHA256 -> return CT.hashSha256 - _ -> throwError "TlsHandle.encrypt: not implemented bulk encryption" - withRandom $ CT.encrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") p - -updateHash :: - HandleLike h => HandleHash h g -> BS.ByteString -> TlsM h g (HandleHash h g) -updateHash (th, ctx') bs = return (th, SHA256.update ctx' bs) - -updateSequenceNumber :: HandleLike h => TlsHandle h g -> RW -> TlsM h g Word64 -updateSequenceNumber t rw = do - ks <- getKeys $ clientId t - (sn, cs) <- case rw of - Read -> (, kReadCS ks) `liftM` getReadSn (clientId t) - Write -> (, kWriteCS ks) `liftM` getWriteSn (clientId t) - case cs of - CipherSuite _ BE_NULL -> return () - _ -> case rw of - Read -> succReadSn $ clientId t - Write -> succWriteSn $ clientId t - return sn - -resetSequenceNumber :: HandleLike h => TlsHandle h g -> RW -> TlsM h g () -resetSequenceNumber t rw = case rw of - Read -> resetReadSn $ clientId t - Write -> resetWriteSn $ clientId t - -generateKeys :: HandleLike h => TlsHandle h g -> Side -> CipherSuite -> - BS.ByteString -> BS.ByteString -> BS.ByteString -> TlsM h g Keys -generateKeys t p cs cr sr pms = do - let CipherSuite _ be = cs - kl <- case be of - AES_128_CBC_SHA -> return 20 - AES_128_CBC_SHA256 -> return 32 - _ -> throwError - "TlsServer.generateKeys: not implemented bulk encryption" - let (ms, cwmk, swmk, cwk, swk) = CT.makeKeys kl cr sr pms - k <- getKeys $ clientId t - return $ case p of - Client -> k { - kCachedCS = cs, - kMasterSecret = ms, - kCachedReadMacKey = swmk, kCachedWriteMacKey = cwmk, - kCachedReadKey = swk, kCachedWriteKey = cwk } - Server -> k { - kCachedCS = cs, - kMasterSecret = ms, - kCachedReadMacKey = cwmk, kCachedWriteMacKey = swmk, - kCachedReadKey = cwk, kCachedWriteKey = swk } - -data RW = Read | Write deriving Show - -flushCipherSuiteSt :: HandleLike h => RW -> PartnerId -> TlsM h g () -flushCipherSuiteSt p = case p of - Read -> flushCipherSuiteRead - Write -> flushCipherSuiteWrite - -debugCipherSuite :: HandleLike h => TlsHandle h g -> String -> TlsM h g () -debugCipherSuite t a = do - k <- getKeys $ clientId t - thlDebug (tlsHandle t) "high" . BSC.pack - . (++ (" - VERIFY WITH " ++ a ++ "\n")) . lenSpace 50 - . show $ kCachedCS k - where lenSpace n str = str ++ replicate (n - length str) ' ' - -handshakeHash :: HandleLike h => HandleHash h g -> TlsM h g BS.ByteString -handshakeHash = return . SHA256.finalize . snd - -finishedHash :: HandleLike h => HandleHash h g -> Side -> TlsM h g BS.ByteString -finishedHash (t, ctx) partner = do - ms <- kMasterSecret `liftM` getKeys (clientId t) - sha256 <- handshakeHash (t, ctx) - return $ CT.finishedHash (partner == Client) ms sha256 - -hlPut_ :: (HandleLike h, CPRG g) => TlsHandle h g -> BS.ByteString -> TlsM h g () -hlPut_ = ((>> return ()) .) . flip (tlsPut True) CTAppData . (, undefined) - -hlDebug_ :: HandleLike h => - TlsHandle h g -> DebugLevel h -> BS.ByteString -> TlsM h g () -hlDebug_ t l = lift . lift . hlDebug (tlsHandle t) l - -hlClose_ :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g () -hlClose_ t = tlsPut True (t, undefined) CTAlert "\SOH\NUL" >> - flush t >> thlClose (tlsHandle t) - -tGetLine :: (HandleLike h, CPRG g) => - TlsHandle h g -> TlsM h g (ContentType, BS.ByteString) -tGetLine t = do - (bct, bp) <- getBuf $ clientId t - case splitLine bp of - Just (l, ls) -> setBuf (clientId t) (bct, ls) >> return (bct, l) - _ -> do cp <- getWholeWithCt t - setBuf (clientId t) cp - second (bp `BS.append`) `liftM` tGetLine t - -tGetLine_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) -> - TlsHandle h g -> TlsM h g (ContentType, BS.ByteString) -tGetLine_ rn t = do - ct <- getContentType t - case ct of - CTHandshake -> rn t >> tGetLine_ rn t - _ -> do (bct, bp) <- getBuf $ clientId t - case splitLine bp of - Just (l, ls) -> do - setBuf (clientId t) (bct, ls) - return (bct, l) - _ -> do cp <- getWholeWithCt t - setBuf (clientId t) cp - second (bp `BS.append`) `liftM` - tGetLine_ rn t - -splitLine :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString) -splitLine bs = case ('\r' `BSC.elem` bs, '\n' `BSC.elem` bs) of - (True, _) -> let - (l, ls) = BSC.span (/= '\r') bs - Just ('\r', ls') = BSC.uncons ls in - case BSC.uncons ls' of - Just ('\n', ls'') -> Just (l, ls'') - _ -> Just (l, ls') - (_, True) -> let - (l, ls) = BSC.span (/= '\n') bs - Just ('\n', ls') = BSC.uncons ls in Just (l, ls') - _ -> Nothing - -tGetContent :: (HandleLike h, CPRG g) => - TlsHandle h g -> TlsM h g (ContentType, BS.ByteString) -tGetContent t = do - bcp@(_, bp) <- getBuf $ clientId t - if BS.null bp then getWholeWithCt t else - setBuf (clientId t) (CTNull, BS.empty) >> return bcp - -getClientFinishedT, getServerFinishedT :: - HandleLike h => TlsHandle h g -> TlsM h g BS.ByteString -getClientFinishedT = getClientFinished . clientId -getServerFinishedT = getServerFinished . clientId - -setClientFinishedT, setServerFinishedT :: - HandleLike h => TlsHandle h g -> BS.ByteString -> TlsM h g () -setClientFinishedT = setClientFinished . clientId -setServerFinishedT = setServerFinished . clientId - -getInitSetT :: HandleLike h => TlsHandle h g -> TlsM h g InitialSettings -getInitSetT = getInitSet . clientId - -setInitSetT :: HandleLike h => TlsHandle h g -> InitialSettings -> TlsM h g () -setInitSetT = setInitSet . clientId - -getAdBufT :: HandleLike h => TlsHandle h g -> TlsM h g BS.ByteString -getAdBufT = getAdBuf . clientId - -setAdBufT :: HandleLike h => TlsHandle h g -> BS.ByteString -> TlsM h g () -setAdBufT = setAdBuf . clientId diff --git a/src/Network/PeyoTLS/TlsMonad.hs b/src/Network/PeyoTLS/TlsMonad.hs deleted file mode 100644 --- a/src/Network/PeyoTLS/TlsMonad.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE PackageImports #-} - -module Network.PeyoTLS.TlsMonad ( - TlsM, evalTlsM, S.initState, - thlGet, thlPut, thlClose, thlDebug, thlError, - withRandom, randomByteString, - getBuf, setBuf, getWBuf, setWBuf, - getAdBuf, setAdBuf, - getReadSn, getWriteSn, succReadSn, succWriteSn, - resetReadSn, resetWriteSn, - getCipherSuiteSt, setCipherSuiteSt, - flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys, - getInitSet, setInitSet, S.InitialSettings, - S.Alert(..), S.AlertLevel(..), S.AlertDesc(..), - S.ContentType(..), - S.CipherSuite(..), S.KeyExchange(..), S.BulkEncryption(..), - S.PartnerId, S.newPartnerId, S.Keys(..), S.nullKeys, - - getClientFinished, setClientFinished, - getServerFinished, setServerFinished, - ) where - -import Control.Monad (liftM) -import "monads-tf" Control.Monad.Trans (lift) -import "monads-tf" Control.Monad.State (StateT, evalStateT, gets, modify) -import "monads-tf" Control.Monad.Error (ErrorT, runErrorT) -import Data.Word (Word64) -import Data.HandleLike (HandleLike(..)) -import "crypto-random" Crypto.Random (CPRG, cprgGenerate) - -import qualified Data.ByteString as BS - -import qualified Network.PeyoTLS.State as S ( - HandshakeState, initState, PartnerId, newPartnerId, Keys(..), nullKeys, - ContentType(..), Alert(..), AlertLevel(..), AlertDesc(..), - CipherSuite(..), KeyExchange(..), BulkEncryption(..), - randomGen, setRandomGen, - setBuf, getBuf, setWBuf, getWBuf, - setAdBuf, getAdBuf, - getReadSN, getWriteSN, succReadSN, succWriteSN, resetReadSN, resetWriteSN, - getCipherSuite, setCipherSuite, - flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys, - getInitSet, setInitSet, - getClientFinished, setClientFinished, - getServerFinished, setServerFinished, - - InitialSettings, - ) - -type TlsM h g = ErrorT S.Alert (StateT (S.HandshakeState h g) (HandleMonad h)) - -evalTlsM :: HandleLike h => - TlsM h g a -> S.HandshakeState h g -> HandleMonad h (Either S.Alert a) -evalTlsM = evalStateT . runErrorT - -getBuf, getWBuf :: HandleLike h => - S.PartnerId -> TlsM h g (S.ContentType, BS.ByteString) -getBuf = gets . S.getBuf; getWBuf = gets . S.getWBuf - -getAdBuf :: HandleLike h => S.PartnerId -> TlsM h g BS.ByteString -getAdBuf = gets . S.getAdBuf - -setAdBuf :: HandleLike h => S.PartnerId -> BS.ByteString -> TlsM h g () -setAdBuf = (modify .) . S.setAdBuf - -setBuf, setWBuf :: HandleLike h => - S.PartnerId -> (S.ContentType, BS.ByteString) -> TlsM h g () -setBuf = (modify .) . S.setBuf; setWBuf = (modify .) . S.setWBuf - -getWriteSn, getReadSn :: HandleLike h => S.PartnerId -> TlsM h g Word64 -getWriteSn = gets . S.getWriteSN; getReadSn = gets . S.getReadSN - -succWriteSn, succReadSn :: HandleLike h => S.PartnerId -> TlsM h g () -succWriteSn = modify . S.succWriteSN; succReadSn = modify . S.succReadSN - -resetWriteSn, resetReadSn :: HandleLike h => S.PartnerId -> TlsM h g () -resetWriteSn = modify . S.resetWriteSN; resetReadSn = modify . S.resetReadSN - -getCipherSuiteSt :: HandleLike h => S.PartnerId -> TlsM h g S.CipherSuite -getCipherSuiteSt = gets . S.getCipherSuite - -setCipherSuiteSt :: HandleLike h => S.PartnerId -> S.CipherSuite -> TlsM h g () -setCipherSuiteSt = (modify .) . S.setCipherSuite - -setKeys :: HandleLike h => S.PartnerId -> S.Keys -> TlsM h g () -setKeys = (modify .) . S.setKeys - -getKeys :: HandleLike h => S.PartnerId -> TlsM h g S.Keys -getKeys = gets . S.getKeys - -getInitSet :: HandleLike h => S.PartnerId -> TlsM h g S.InitialSettings -getInitSet = gets . S.getInitSet - -setInitSet :: HandleLike h => S.PartnerId -> S.InitialSettings -> TlsM h g () -setInitSet = (modify .) . S.setInitSet - -getClientFinished, getServerFinished :: - HandleLike h => S.PartnerId -> TlsM h g BS.ByteString -getClientFinished = gets . S.getClientFinished -getServerFinished = gets . S.getServerFinished - -setClientFinished, setServerFinished :: - HandleLike h => S.PartnerId -> BS.ByteString -> TlsM h g () -setClientFinished = (modify .) . S.setClientFinished -setServerFinished = (modify .) . S.setServerFinished - -flushCipherSuiteRead, flushCipherSuiteWrite :: - HandleLike h => S.PartnerId -> TlsM h g () -flushCipherSuiteRead = modify . S.flushCipherSuiteRead -flushCipherSuiteWrite = modify . S.flushCipherSuiteWrite - -withRandom :: HandleLike h => (gen -> (a, gen)) -> TlsM h gen a -withRandom p = do - (x, g') <- p `liftM` gets S.randomGen - modify $ S.setRandomGen g' - return x - -randomByteString :: (HandleLike h, CPRG g) => Int -> TlsM h g BS.ByteString -randomByteString = withRandom . cprgGenerate - -thlGet :: HandleLike h => h -> Int -> TlsM h g BS.ByteString -thlGet = ((lift . lift) .) . hlGet - -thlPut :: HandleLike h => h -> BS.ByteString -> TlsM h g () -thlPut = ((lift . lift) .) . hlPut - -thlClose :: HandleLike h => h -> TlsM h g () -thlClose = lift . lift . hlClose - -thlDebug :: HandleLike h => - h -> DebugLevel h -> BS.ByteString -> TlsM h gen () -thlDebug = (((lift . lift) .) .) . hlDebug - -thlError :: HandleLike h => h -> BS.ByteString -> TlsM h g a -thlError = ((lift . lift) .) . hlError diff --git a/src/Network/PeyoTLS/Types.hs b/src/Network/PeyoTLS/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Types.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Network.PeyoTLS.Types ( Extension(..), + Handshake(..), HandshakeItem(..), + ClientHello(..), ServerHello(..), SessionId(..), + CipherSuite(..), KeyEx(..), BulkEnc(..), + CompMethod(..), + ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..), + CertificateRequest(..), certificateRequest, ClientCertificateType(..), + SignAlg(..), HashAlg(..), + ServerHelloDone(..), ClientKeyExchange(..), Epms(..), + DigitallySigned(..), Finished(..) ) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (unless) +import Data.Word (Word8, Word16) +import Data.Word.Word24 (Word24) + +import qualified Data.ByteString as BS +import qualified Data.X509 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 Network.PeyoTLS.Hello ( Extension(..), + ClientHello(..), ServerHello(..), SessionId(..), + CipherSuite(..), KeyEx(..), BulkEnc(..), + CompMethod(..), HashAlg(..), SignAlg(..) ) +import Network.PeyoTLS.Certificate ( + CertificateRequest(..), certificateRequest, ClientCertificateType(..), + ClientKeyExchange(..), DigitallySigned(..) ) + +data Handshake + = HHelloReq + | HClientHello ClientHello | HServerHello ServerHello + | HCertificate X509.CertificateChain | HServerKeyEx BS.ByteString + | HCertificateReq CertificateRequest | HServerHelloDone + | HCertVerify DigitallySigned | HClientKeyEx ClientKeyExchange + | HFinished BS.ByteString | HRaw Type BS.ByteString + deriving Show + +instance B.Bytable Handshake where + decode = B.evalBytableM B.parse; encode = encodeH + +instance B.Parsable Handshake where + parse = do + t <- B.take 1 + len <- B.take 3 + case t of + THelloRequest -> do + unless (len == 0) $ fail "parse Handshake" + return HHelloReq + TClientHello -> HClientHello <$> B.take len + TServerHello -> HServerHello <$> B.take len + TCertificate -> HCertificate <$> B.take len + TServerKeyEx -> HServerKeyEx <$> B.take len + TCertificateReq -> HCertificateReq <$> B.take len + TServerHelloDone -> let 0 = len in return HServerHelloDone + TCertVerify -> HCertVerify <$> B.take len + TClientKeyEx -> HClientKeyEx <$> B.take len + TFinished -> HFinished <$> B.take len + _ -> HRaw t <$> B.take len + +encodeH :: Handshake -> BS.ByteString +encodeH HHelloReq = encodeH $ HRaw THelloRequest "" +encodeH (HClientHello ch) = encodeH . HRaw TClientHello $ B.encode ch +encodeH (HServerHello sh) = encodeH . HRaw TServerHello $ B.encode sh +encodeH (HCertificate crts) = encodeH . HRaw TCertificate $ B.encode crts +encodeH (HServerKeyEx ske) = encodeH $ HRaw TServerKeyEx ske +encodeH (HCertificateReq cr) = encodeH . HRaw TCertificateReq $ B.encode cr +encodeH HServerHelloDone = encodeH $ HRaw TServerHelloDone "" +encodeH (HCertVerify ds) = encodeH . HRaw TCertVerify $ B.encode ds +encodeH (HClientKeyEx epms) = encodeH . HRaw TClientKeyEx $ B.encode epms +encodeH (HFinished bs) = encodeH $ HRaw TFinished bs +encodeH (HRaw t bs) = B.encode t `BS.append` B.addLen (undefined :: Word24) bs + +class HandshakeItem hi where + fromHandshake :: Handshake -> Maybe hi; toHandshake :: hi -> Handshake + +instance HandshakeItem Handshake where + fromHandshake = Just; toHandshake = id + +instance (HandshakeItem l, HandshakeItem r) => HandshakeItem (Either l r) where + fromHandshake hs = let + l = fromHandshake hs + r = fromHandshake hs in maybe (Right <$> r) (Just . Left) l + toHandshake (Left l) = toHandshake l + toHandshake (Right r) = toHandshake r + +instance HandshakeItem ClientHello where + fromHandshake (HClientHello ch) = Just ch + fromHandshake _ = Nothing + toHandshake = HClientHello + +instance HandshakeItem ServerHello where + fromHandshake (HServerHello sh) = Just sh + fromHandshake _ = Nothing + toHandshake = HServerHello + +instance HandshakeItem X509.CertificateChain where + fromHandshake (HCertificate cc) = Just cc + fromHandshake _ = Nothing + toHandshake = HCertificate + +data ServerKeyExchange = ServerKeyEx BS.ByteString BS.ByteString + HashAlg SignAlg BS.ByteString deriving Show + +data ServerKeyExDhe = ServerKeyExDhe DH.Params DH.PublicNumber + HashAlg SignAlg BS.ByteString deriving Show + +data ServerKeyExEcdhe = ServerKeyExEcdhe ECC.Curve ECC.Point + HashAlg SignAlg BS.ByteString deriving Show + +instance HandshakeItem ServerKeyExchange where + fromHandshake = undefined + toHandshake = HServerKeyEx . B.encode + +instance HandshakeItem ServerKeyExDhe where + toHandshake = HServerKeyEx . B.encode + fromHandshake (HServerKeyEx ske) = + either (const Nothing) Just $ B.decode ske + fromHandshake _ = Nothing + +instance HandshakeItem ServerKeyExEcdhe where + toHandshake = HServerKeyEx . B.encode + fromHandshake (HServerKeyEx ske) = + either (const Nothing) Just $ B.decode ske + fromHandshake _ = Nothing + +instance B.Bytable ServerKeyExchange where + decode = undefined + encode (ServerKeyEx ps pv ha sa sn) = BS.concat [ + ps, pv, B.encode ha, B.encode sa, + B.addLen (undefined :: Word16) sn ] + +instance B.Bytable ServerKeyExDhe where + encode (ServerKeyExDhe ps pv ha sa sn) = BS.concat [ + B.encode ps, B.encode pv, B.encode ha, B.encode sa, + B.addLen (undefined :: Word16) sn ] + decode = B.evalBytableM B.parse + +instance B.Bytable ServerKeyExEcdhe where + encode (ServerKeyExEcdhe cv pnt ha sa sn) = BS.concat [ + B.encode cv, B.encode pnt, B.encode ha, B.encode sa, + B.addLen (undefined :: Word16) sn ] + decode = B.evalBytableM B.parse + +instance B.Parsable ServerKeyExDhe where + parse = do + ps <- B.parse + pv <- B.parse + (ha, sa, sn) <- hasasn + return $ ServerKeyExDhe ps pv ha sa sn + +instance B.Parsable ServerKeyExEcdhe where + parse = do + cv <- B.parse + pnt <- B.parse + (ha, sa, sn) <- hasasn + return $ ServerKeyExEcdhe cv pnt ha sa sn + +hasasn :: B.BytableM (HashAlg, SignAlg, BS.ByteString) +hasasn = (,,) <$> B.parse <*> B.parse <*> (B.take =<< B.take 2) + +instance HandshakeItem CertificateRequest where + fromHandshake (HCertificateReq cr) = Just cr + fromHandshake _ = Nothing + toHandshake = HCertificateReq + +instance HandshakeItem ServerHelloDone where + fromHandshake HServerHelloDone = Just ServerHelloDone + fromHandshake _ = Nothing + toHandshake _ = HServerHelloDone + +instance HandshakeItem DigitallySigned where + fromHandshake (HCertVerify ds) = Just ds + fromHandshake _ = Nothing + toHandshake = HCertVerify + +instance HandshakeItem ClientKeyExchange where + fromHandshake (HClientKeyEx cke) = Just cke + fromHandshake _ = Nothing + toHandshake = HClientKeyEx + +data Epms = Epms BS.ByteString + +instance HandshakeItem Epms where + fromHandshake (HClientKeyEx cke) = ckeToEpms cke + fromHandshake _ = Nothing + toHandshake = HClientKeyEx . epmsToCke + +ckeToEpms :: ClientKeyExchange -> Maybe Epms +ckeToEpms (ClientKeyExchange cke) = case B.runBytableM (B.take =<< B.take 2) cke of + Right (e, "") -> Just $ Epms e + _ -> Nothing + +epmsToCke :: Epms -> ClientKeyExchange +epmsToCke (Epms epms) = ClientKeyExchange $ B.addLen (undefined :: Word16) epms + +data Finished = Finished BS.ByteString deriving (Show, Eq) + +instance HandshakeItem Finished where + fromHandshake (HFinished f) = Just $ Finished f + fromHandshake _ = Nothing + toHandshake (Finished f) = HFinished f + +data ServerHelloDone = ServerHelloDone deriving Show + +data Type + = THelloRequest | TClientHello | TServerHello + | TCertificate | TServerKeyEx | TCertificateReq | TServerHelloDone + | TCertVerify | TClientKeyEx | TFinished | TRaw Word8 + deriving Show + +instance B.Bytable Type where + decode bs = case BS.unpack bs of + [0] -> Right THelloRequest + [1] -> Right TClientHello + [2] -> Right TServerHello + [11] -> Right TCertificate + [12] -> Right TServerKeyEx + [13] -> Right TCertificateReq + [14] -> Right TServerHelloDone + [15] -> Right TCertVerify + [16] -> Right TClientKeyEx + [20] -> Right TFinished + [ht] -> Right $ TRaw ht + _ -> Left "Handshake.decodeT" + encode THelloRequest = BS.pack [0] + encode TClientHello = BS.pack [1] + encode TServerHello = BS.pack [2] + encode TCertificate = BS.pack [11] + encode TServerKeyEx = BS.pack [12] + encode TCertificateReq = BS.pack [13] + encode TServerHelloDone = BS.pack [14] + encode TCertVerify = BS.pack [15] + encode TClientKeyEx = BS.pack [16] + encode TFinished = BS.pack [20] + encode (TRaw w) = BS.pack [w] diff --git a/test/testReneg.hs b/test/testReneg.hs --- a/test/testReneg.hs +++ b/test/testReneg.hs @@ -40,7 +40,7 @@ main :: IO () main = do b <- randomIO - (if b then runRsa "low" else ecdsa "low") =<< randomFrom cipherSuites + (if b then runRsa "critical" else ecdsa "critical") =<< randomFrom cipherSuites runRsa :: Priority -> [CipherSuite] -> IO () runRsa p cs = do