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.24 +version: 0.1.0.0 stability: Experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo @@ -283,7 +283,7 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/peyotls.git - tag: peyotls-0.0.0.24 + tag: peyotls-0.1.0.0 library hs-source-dirs: src @@ -291,14 +291,14 @@ Network.PeyoTLS.Client, Network.PeyoTLS.Server, Network.PeyoTLS.ReadFile other-modules: Network.PeyoTLS.Base, - Network.PeyoTLS.Types, - Network.PeyoTLS.Hello, Network.PeyoTLS.Extension, - Network.PeyoTLS.CipherSuite, Network.PeyoTLS.HSAlg, - Network.PeyoTLS.Certificate, + Network.PeyoTLS.Codec, + Network.PeyoTLS.Codec.Hello, Network.PeyoTLS.Codec.Extension, + Network.PeyoTLS.CipherSuite, Network.PeyoTLS.Codec.HSAlg, + Network.PeyoTLS.Codec.Certificate, Network.PeyoTLS.Run, - Network.PeyoTLS.Handle, - Network.PeyoTLS.Monad, Network.PeyoTLS.State, - Network.PeyoTLS.Crypto, + Network.PeyoTLS.Run.Handle, + Network.PeyoTLS.Run.Monad, Network.PeyoTLS.Run.State, + Network.PeyoTLS.Run.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 --- a/src/Network/PeyoTLS/Base.hs +++ b/src/Network/PeyoTLS/Base.hs @@ -9,23 +9,22 @@ AlertLevel(..), AlertDesc(..), throw, debugCipherSuite, debug, ValidateHandle(..), handshakeValidate, validateAlert, - TlsHandleBase, names, getNames, + HandleBase, getNames, CertSecretKey(..), isRsaKey, isEcdsaKey, readHandshake, writeHandshake, - ChangeCipherSpec(..), + CCSpec(..), Handshake(HHelloReq), - ClientHello(..), ServerHello(..), SessionId(..), Extension(..), - isRenegoInfo, emptyRenegoInfo, + ClHello(..), SvHello(..), SssnId(..), Extension(..), isRnInfo, emptyRnInfo, CipherSuite(..), KeyEx(..), BulkEnc(..), - CompMethod(..), HashAlg(..), SignAlg(..), + CmpMtd(..), HashAlg(..), SignAlg(..), getCipherSuite, setCipherSuite, checkClRenego, checkSvRenego, makeClRenego, makeSvRenego, - ServerKeyEx(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..), + SvKeyEx(..), SvKeyExDhe(..), SvKeyExEcdhe(..), SvSignSecretKey(..), SvSignPublicKey(..), CertReq(..), certReq, ClCertType(..), - ServerHelloDone(..), - ClientKeyEx(..), Epms(..), makeKeys, - DigitallySigned(..), ClSignPublicKey(..), ClSignSecretKey(..), + SHDone(..), + ClKeyEx(..), Epms(..), makeKeys, + DigitSigned(..), ClSignPublicKey(..), ClSignSecretKey(..), handshakeHash, RW(..), flushCipherSuite, Side(..), finishedHash, @@ -33,7 +32,7 @@ import Control.Arrow (first) import Control.Monad (unless, liftM, ap) -import "monads-tf" Control.Monad.State (gets, lift) +import "monads-tf" Control.Monad.Reader (lift, ask) import Data.Bits (shiftR) import Data.HandleLike (HandleLike(..)) import System.IO (Handle) @@ -59,18 +58,18 @@ import qualified Crypto.PubKey.HashDescr as HD import qualified Crypto.PubKey.RSA.PKCS15 as RSA -import Network.PeyoTLS.Types ( +import Network.PeyoTLS.Codec ( Handshake(..), HandshakeItem(..), - ClientHello(..), ServerHello(..), SessionId(..), + ClHello(..), SvHello(..), SssnId(..), CipherSuite(..), KeyEx(..), BulkEnc(..), - CompMethod(..), Extension(..), isRenegoInfo, emptyRenegoInfo, - ServerKeyEx(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..), + CmpMtd(..), Extension(..), isRnInfo, emptyRnInfo, + SvKeyEx(..), SvKeyExDhe(..), SvKeyExEcdhe(..), CertReq(..), certReq, ClCertType(..), SignAlg(..), HashAlg(..), - ServerHelloDone(..), ClientKeyEx(..), Epms(..), - DigitallySigned(..), ChangeCipherSpec(..), Finished(..) ) + SHDone(..), ClKeyEx(..), Epms(..), + DigitSigned(..), CCSpec(..), Finished(..) ) import qualified Network.PeyoTLS.Run as RUN (finishedHash, debug) import Network.PeyoTLS.Run ( - TlsM, run, TlsHandleBase(..), getNames, + TlsM, run, HandleBase, getNames, chGet, hsPut, updateHash, ccsPut, adGet, adGetLine, adGetContent, adPut, adDebug, adClose, HandshakeM, execHandshakeM, rerunHandshakeM, @@ -93,8 +92,8 @@ debug :: (HandleLike h, Show a) => DebugLevel h -> a -> HandshakeM h g () debug p x = do - t <- gets fst - lift . RUN.debug t p . BSC.pack . (++ "\n") $ show x + t <- ask + lift . lift . RUN.debug t p . BSC.pack . (++ "\n") $ show x readHandshake :: (HandleLike h, CPRG g, HandshakeItem hi) => HandshakeM h g hi readHandshake = do @@ -102,17 +101,17 @@ case ch of Left 1 -> case fromHandshake HCCSpec of Just i -> return i - _ -> throw ALFatal ADUnexMsg $ + _ -> throw ALFtl ADUnexMsg $ modNm ++ ".readHandshake: " ++ show HCCSpec Right bs -> case B.decode bs of Right HHelloReq -> readHandshake Right hs -> case fromHandshake hs of Just i -> updateHash bs >> return i - _ -> throw ALFatal ADUnexMsg $ + _ -> throw ALFtl ADUnexMsg $ modNm ++ ".readHandshake: " ++ show hs - Left em -> throw ALFatal ADInternalError $ + Left em -> throw ALFtl ADInternalErr $ modNm ++ ".readHandshake: " ++ em - _ -> throw ALFatal ADUnexMsg $ modNm ++ ".readHandshake: uk ccs" + _ -> throw ALFtl ADUnexMsg $ modNm ++ ".readHandshake: uk ccs" writeHandshake:: (HandleLike h, CPRG g, HandshakeItem hi) => hi -> HandshakeM h g () writeHandshake hi = do @@ -131,23 +130,23 @@ return fh checkClRenego, checkSvRenego :: HandleLike h => Extension -> HandshakeM h g () -checkClRenego (ERenegoInfo ri) = do +checkClRenego (ERnInfo ri) = do ok <- (ri ==) `liftM` getClFinished - unless ok . throw ALFatal ADHsFailure $ + unless ok . throw ALFtl ADHsFailure $ modNm ++ ".checkClRenego: renego info is not match" -checkClRenego _ = throw ALFatal ADInternalError $ +checkClRenego _ = throw ALFtl ADInternalErr $ modNm ++ ".checkClRenego: not renego info" -checkSvRenego (ERenegoInfo ri) = do +checkSvRenego (ERnInfo ri) = do ok <- (ri ==) `liftM` (BS.append `liftM` getClFinished `ap` getSvFinished) - unless ok . throw ALFatal ADHsFailure $ + unless ok . throw ALFtl ADHsFailure $ modNm ++ ".checkSvRenego: renego info is not match" -checkSvRenego _ = throw ALFatal ADInternalError $ +checkSvRenego _ = throw ALFtl ADInternalErr $ modNm ++ ".checkSvRenego: not renego info" makeClRenego, makeSvRenego :: HandleLike h => HandshakeM h g Extension -makeClRenego = ERenegoInfo `liftM` getClFinished +makeClRenego = ERnInfo `liftM` getClFinished makeSvRenego = - ERenegoInfo `liftM` (BS.append `liftM` getClFinished `ap` getSvFinished) + ERnInfo `liftM` (BS.append `liftM` getClFinished `ap` getSvFinished) class DhParam b where type Secret b diff --git a/src/Network/PeyoTLS/Certificate.hs b/src/Network/PeyoTLS/Certificate.hs deleted file mode 100644 --- a/src/Network/PeyoTLS/Certificate.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Network.PeyoTLS.Certificate ( - CertReq(..), certReq, ClCertType(..), - ClientKeyEx(..), DigitallySigned(..)) where - -import Control.Applicative ((<$>), (<*>)) -import Data.Word (Word8, Word16) -import Data.Word.Word24 (Word24) - -import qualified Data.ByteString as BS -import qualified Data.ASN1.Types as ASN1 -import qualified Data.ASN1.Encoding as ASN1 -import qualified Data.ASN1.BinaryEncoding as ASN1 -import qualified Data.X509 as X509 -import qualified Data.X509.CertificateStore as X509 -import qualified Codec.Bytable.BigEndian as B - -import Network.PeyoTLS.HSAlg (HashAlg, SignAlg) - -instance B.Bytable X509.CertificateChain where - decode = B.evalBytableM B.parse - encode = B.addLen w24 . cmap (B.addLen w24) - . (\(X509.CertificateChainRaw ccr) -> ccr) - . X509.encodeCertificateChain - . (\(X509.CertificateChain cs) -> - X509.CertificateChain $ cs) - -instance B.Parsable X509.CertificateChain where - parse = do - ecc <- X509.decodeCertificateChain . X509.CertificateChainRaw <$> - (flip B.list (B.take =<< B.take 3) =<< B.take 3) - case ecc of - Right (X509.CertificateChain cs) -> - return . X509.CertificateChain $ cs - Left (n, err) -> fail $ show n ++ " " ++ err - -data CertReq = CertReq [ClCertType] [(HashAlg, SignAlg)] [X509.DistinguishedName] - deriving Show - -certReq :: [ClCertType] -> [(HashAlg, SignAlg)] -> - X509.CertificateStore -> CertReq -certReq t a = CertReq t a - . map (X509.certIssuerDN . X509.signedObject . X509.getSigned) - . X509.listCertificates - -instance B.Bytable CertReq where - encode (CertReq t a n) = BS.concat [ - B.addLen w8 $ cmap B.encode t, - B.addLen w16 . BS.concat $ - concatMap (\(h, s) -> [B.encode h, B.encode s]) a, - B.addLen w16 . flip cmap n $ B.addLen w16 . - ASN1.encodeASN1' ASN1.DER . flip ASN1.toASN1 [] ] --- encode (CertReq bs) = bs - decode = B.evalBytableM $ do - t <- flip B.list (B.take 1) =<< B.take 1 - a <- flip B.list ((,) <$> B.take 1 <*> B.take 1) =<< B.take 2 - n <- (B.take 2 >>=) . flip B.list $ do - bs <- B.take =<< B.take 2 - a1 <- either (fail . show) return $ - ASN1.decodeASN1' ASN1.DER bs - either (fail . show) (return . fst) $ ASN1.fromASN1 a1 - return $ CertReq t a n - -data ClCertType = CTRsaSign | CTEcdsaSign | CTRaw Word8 - deriving (Show, Eq) - -instance B.Bytable ClCertType where - encode CTRsaSign = "\x01" - encode CTEcdsaSign = "\x40" - encode (CTRaw w) = BS.pack [w] - decode bs = case BS.unpack bs of - [w] -> Right $ case w of - 1 -> CTRsaSign; 64 -> CTEcdsaSign; _ -> CTRaw w - _ -> Left "Certificate: ClCertType.decode" - -data ClientKeyEx = ClientKeyEx BS.ByteString deriving Show - -instance B.Bytable ClientKeyEx where - decode = Right . ClientKeyEx - encode (ClientKeyEx epms) = epms - -data DigitallySigned - = DigitallySigned (HashAlg, SignAlg) BS.ByteString - | DigitallySignedRaw BS.ByteString - deriving Show - -instance B.Bytable DigitallySigned where - decode = B.evalBytableM $ - DigitallySigned - <$> ((,) <$> B.take 1 <*> B.take 1) - <*> (B.take =<< B.take 2) - encode (DigitallySigned (ha, sa) bs) = BS.concat [ - B.encode ha, B.encode sa, B.addLen w16 bs ] - encode (DigitallySignedRaw bs) = bs - -w8 :: Word8; w8 = undefined -w16 :: Word16; w16 = undefined -w24 :: Word24; w24 = undefined - -cmap :: (a -> BS.ByteString) -> [a] -> BS.ByteString -cmap = (BS.concat .) . map 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 @@ -10,72 +10,59 @@ import qualified Data.ByteString as BS import qualified Codec.Bytable.BigEndian as B +modNm :: String +modNm = "Network.PeyoTLS.CipherSuite" + data CipherSuite = CipherSuite KeyEx BulkEnc | EMPTY_RENEGOTIATION_INFO | CipherSuiteRaw Word8 Word8 deriving (Show, Read, Eq) -data KeyEx - = RSA - | DHE_RSA - | ECDHE_RSA - | ECDHE_ECDSA --- | ECDHE_PSK - | KE_NULL +data KeyEx = RSA | DHE_RSA | ECDHE_RSA | ECDHE_ECDSA | KE_NULL deriving (Show, Read, Eq) -data BulkEnc - = AES_128_CBC_SHA - | AES_128_CBC_SHA256 --- | CAMELLIA_128_CBC_SHA --- | NULL_SHA - | BE_NULL +data BulkEnc = AES_128_CBC_SHA | AES_128_CBC_SHA256 | BE_NULL deriving (Show, Read, Eq) instance B.Bytable CipherSuite where - decode = decodeCipherSuite - encode = encodeCipherSuite + decode = decodeCs + encode = encodeCs -decodeCipherSuite :: BS.ByteString -> Either String CipherSuite -decodeCipherSuite bs = case BS.unpack bs of +decodeCs :: BS.ByteString -> Either String CipherSuite +decodeCs bs = case BS.unpack bs of [w1, w2] -> Right $ case (w1, w2) of (0x00, 0x00) -> CipherSuite KE_NULL BE_NULL (0x00, 0x2f) -> CipherSuite RSA AES_128_CBC_SHA (0x00, 0x33) -> CipherSuite DHE_RSA AES_128_CBC_SHA --- (0x00, 0x39) -> CipherSuite ECDHE_PSK NULL_SHA (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) -> 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 (0xc0, 0x27) -> CipherSuite ECDHE_RSA AES_128_CBC_SHA256 + (0x00, 0xff) -> EMPTY_RENEGOTIATION_INFO _ -> CipherSuiteRaw w1 w2 - _ -> Left "CipherSuite.decodeCipherSuite: not 2 byte" - -encodeCipherSuite :: CipherSuite -> BS.ByteString -encodeCipherSuite (CipherSuite KE_NULL BE_NULL) = "\x00\x00" -encodeCipherSuite (CipherSuite RSA AES_128_CBC_SHA) = "\x00\x2f" -encodeCipherSuite (CipherSuite DHE_RSA AES_128_CBC_SHA) = "\x00\x33" --- encodeCipherSuite (CipherSuite ECDHE_PSK NULL_SHA) = "\x00\x39" -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 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" -encodeCipherSuite (CipherSuite ECDHE_RSA AES_128_CBC_SHA256) = "\xc0\x27" -encodeCipherSuite (CipherSuiteRaw w1 w2) = BS.pack [w1, w2] -encodeCipherSuite _ = error "CipherSuite.encodeCipherSuite: unknown cipher suite" + _ -> Left $ modNm ++ ".decodeCs: not 2 byte" -separateByWith :: String -> (String, String) -separateByWith "" = error "CipherSuite: parse error" -separateByWith ('_' : 'W' : 'I' : 'T' : 'H' : '_' : be) = ("", be) -separateByWith (k : r) = (k :) `first` separateByWith r +encodeCs :: CipherSuite -> BS.ByteString +encodeCs (CipherSuite KE_NULL BE_NULL) = "\x00\x00" +encodeCs (CipherSuite RSA AES_128_CBC_SHA) = "\x00\x2f" +encodeCs (CipherSuite DHE_RSA AES_128_CBC_SHA) = "\x00\x33" +encodeCs (CipherSuite RSA AES_128_CBC_SHA256) = "\x00\x3c" +encodeCs (CipherSuite DHE_RSA AES_128_CBC_SHA256) = "\x00\x67" +encodeCs (CipherSuite ECDHE_ECDSA AES_128_CBC_SHA) = "\xc0\x09" +encodeCs (CipherSuite ECDHE_RSA AES_128_CBC_SHA) = "\xc0\x13" +encodeCs (CipherSuite ECDHE_ECDSA AES_128_CBC_SHA256) = "\xc0\x23" +encodeCs (CipherSuite ECDHE_RSA AES_128_CBC_SHA256) = "\xc0\x27" +encodeCs (CipherSuiteRaw w1 w2) = BS.pack [w1, w2] +encodeCs EMPTY_RENEGOTIATION_INFO = "\x00\xff" +encodeCs _ = error $ modNm ++ ".encodeCs: unknown cipher suite" instance IsString CipherSuite where - fromString = uncurry CipherSuite . (read *** read) . separateByWith . drop 4 + fromString = uncurry CipherSuite . (read *** read) . sep . drop 4 + where + sep "" = error $ modNm ++ ".separateByWith: parse error" + sep ('_' : 'W' : 'I' : 'T' : 'H' : '_' : be) = ("", be) + sep (k : r) = (k :) `first` sep r 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 @@ -12,7 +12,7 @@ module Network.PeyoTLS.Client ( -- * Basic - PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, names, getNames, + PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, getNames, -- * Renegotiation renegotiate, setCipherSuites, setKeyCerts, setCertificateStore, -- * Cipher Suite @@ -40,7 +40,7 @@ import qualified Crypto.PubKey.RSA.PKCS15 as RSA import qualified "monads-tf" Control.Monad.Error as E -import qualified Network.PeyoTLS.Base as BASE (names, getNames) +import qualified Network.PeyoTLS.Base as BASE (getNames) import Network.PeyoTLS.Base ( debug, PeyotlsM, TlsM, run, getSettingsC, setSettingsC, @@ -49,24 +49,24 @@ withRandom, flushAd, AlertLevel(..), AlertDesc(..), throw, ValidateHandle(..), handshakeValidate, validateAlert, - TlsHandleBase, CertSecretKey(..), - readHandshake, writeHandshake, ChangeCipherSpec(..), - ClientHello(..), ServerHello(..), SessionId(..), isRenegoInfo, + HandleBase, CertSecretKey(..), + readHandshake, writeHandshake, CCSpec(..), + ClHello(..), SvHello(..), SssnId(..), isRnInfo, CipherSuite(..), KeyEx(..), BulkEnc(..), - CompMethod(..), HashAlg(..), SignAlg(..), + CmpMtd(..), HashAlg(..), SignAlg(..), setCipherSuite, checkSvRenego, makeClRenego, - ServerKeyExEcdhe(..), ServerKeyExDhe(..), SvSignPublicKey(..), + SvKeyExEcdhe(..), SvKeyExDhe(..), SvSignPublicKey(..), CertReq(..), ClCertType(..), - ServerHelloDone(..), - ClientKeyEx(..), Epms(..), makeKeys, - DigitallySigned(..), ClSignSecretKey(..), handshakeHash, + SHDone(..), + ClKeyEx(..), Epms(..), makeKeys, + DigitSigned(..), ClSignSecretKey(..), handshakeHash, Side(..), RW(..), finishedHash, flushCipherSuite, DhParam(..), ecdsaPubKey ) type PeyotlsHandle = TlsHandle Handle SystemRNG -newtype TlsHandle h g = TlsHandleC { tlsHandleC :: TlsHandleBase h g } deriving Show +newtype TlsHandle h g = TlsHandleC { tlsHandleC :: HandleBase h g } deriving Show instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandle h g) where type HandleMonad (TlsHandle h g) = TlsM h g @@ -78,13 +78,8 @@ hlDebug = adDebug . tlsHandleC hlClose = adClose . tlsHandleC -moduleName :: String -moduleName = "Network.PeyoTLS.Client" - -{-# DEPRECATED names "Use getNames instead" #-} - -names :: TlsHandle h g -> [String] -names = BASE.names . tlsHandleC +modNm :: String +modNm = "Network.PeyoTLS.Client" getNames :: HandleLike h => TlsHandle h g -> TlsM h g [String] getNames = BASE.getNames . tlsHandleC @@ -119,7 +114,7 @@ (cscl, crts, _) <- getSettingsC setSettingsC (cscl, crts, cs) -rehandshake :: (ValidateHandle h, CPRG g) => TlsHandleBase h g -> TlsM h g () +rehandshake :: (ValidateHandle h, CPRG g) => HandleBase h g -> TlsM h g () rehandshake t = rerunHandshakeM t $ do (cscl, crts, ca) <- getSettingsC handshake crts ca =<< clientHello cscl @@ -129,7 +124,7 @@ clientHello cscl = do cr <- withRandom $ cprgGenerate 32 ((>>) <$> writeHandshake <*> debug "low") - . ClientHello (3, 3) cr (SessionId "") cscl [CompMethodNull] + . ClHello (3, 3) cr (SssnId "") cscl [CmpMtdNull] . Just . (: []) =<< makeClRenego return cr @@ -143,24 +138,23 @@ DHE_RSA -> dheHandshake (undefined :: DH.Params) ECDHE_RSA -> dheHandshake (undefined :: ECC.Curve) ECDHE_ECDSA -> dheHandshake (undefined :: ECC.Curve) - _ -> \_ _ _ -> throw ALFatal ADHsFailure $ - moduleName ++ ".handshake: not implemented" + _ -> \_ _ _ -> throw ALFtl ADHsFailure $ + modNm ++ ".handshake: not implemented" serverHello :: (HandleLike h, CPRG g) => HandshakeM h g (BS.ByteString, KeyEx) serverHello = do - ServerHello v sr _sid cs@(CipherSuite ke _) cm e <- readHandshake + SvHello v sr _sid cs@(CipherSuite ke _) cm e <- readHandshake case v of (3, 3) -> return () - _ -> throw ALFatal ADProtocolVersion $ - moduleName ++ ".serverHello: only TLS 1.2" + _ -> throw ALFtl ADProtoVer $ + modNm ++ ".serverHello: only TLS 1.2" case cm of - CompMethodNull -> return () - _ -> throw ALFatal ADHsFailure $ - moduleName ++ ".serverHello: only compression method null" - case find isRenegoInfo $ fromMaybe [] e of + CmpMtdNull -> return () + _ -> throw ALFtl ADHsFailure $ + modNm ++ ".serverHello: only compression method null" + case find isRnInfo $ fromMaybe [] e of Just ri -> checkSvRenego ri - _ -> throw ALFatal ADInsufficientSecurity $ - moduleName ++ ".serverHello: require secure renegotiation" + _ -> throw ALFtl ADInsSec $ modNm ++ ".serverHello: no sec renego" setCipherSuite cs return (sr, ke) @@ -170,12 +164,11 @@ rsaHandshake rs crts ca = do cc@(X509.CertificateChain (c : _)) <- readHandshake vr <- handshakeValidate ca cc - unless (null vr) . throw ALFatal (validateAlert vr) $ - moduleName ++ ".rsaHandshake: validate failure" + unless (null vr) . throw ALFtl (validateAlert vr) $ + modNm ++ ".rsaHandshake: validate failure" pk <- case X509.certPubKey . X509.signedObject $ X509.getSigned c of X509.PubKeyRSA k -> return k - _ -> throw ALFatal ADIllegalParameter $ - moduleName ++ ".rsaHandshake: require RSA public key" + _ -> throw ALFtl ADIllParam $ modNm ++ ".rsaHandshake: RSA pk" crt <- clientCertificate crts pms <- ("\x03\x03" `BS.append`) `liftM` withRandom (cprgGenerate 46) makeKeys Client rs pms @@ -195,13 +188,13 @@ dheHandshake t rs crts ca = do cc@(X509.CertificateChain (c : _)) <- readHandshake vr <- handshakeValidate ca cc - unless (null vr) . throw ALFatal (validateAlert vr) $ - moduleName ++ ".succeed: validate failure" + unless (null vr) . throw ALFtl (validateAlert vr) $ + modNm ++ ".succeed: validate failure" case X509.certPubKey . X509.signedObject $ X509.getSigned c of X509.PubKeyRSA pk -> succeed t pk rs crts X509.PubKeyECDSA cv pt -> succeed t (ecdsaPubKey cv pt) rs crts - _ -> throw ALFatal ADHsFailure $ - moduleName ++ ".dheHandshake: not implemented" + _ -> throw ALFtl ADHsFailure $ + modNm ++ ".dheHandshake: not implemented" succeed :: (ValidateHandle h, CPRG g, SvSignPublicKey pk, KeyExchangeClass ke, Show (Secret ke), Show (Public ke)) => @@ -210,16 +203,16 @@ succeed t pk rs@(cr, sr) crts = do (ps, pv, ha, sa, sn) <- serverKeyExchange let _ = ps `asTypeOf` t - unless (sa == sspAlgorithm pk) . throw ALFatal ADHsFailure $ + unless (sa == sspAlgorithm pk) . throw ALFtl ADHsFailure $ pre ++ "sign algorithm unmatch" unless (ssVerify ha pk sn $ BS.concat [cr, sr, B.encode ps, B.encode pv]) . - throw ALFatal ADDecryptError $ pre ++ "verify failure" + throw ALFtl ADDecryptErr $ pre ++ "verify failure" crt <- clientCertificate crts sv <- withRandom $ generateSecret ps makeKeys Client rs $ calculateShared ps sv pv - writeHandshake . ClientKeyEx . B.encode $ calculatePublic ps sv + writeHandshake . ClKeyEx . B.encode $ calculatePublic ps sv finishHandshake crt - where pre = moduleName ++ ".succeed: " + where pre = modNm ++ ".succeed: " class (DhParam bs, B.Bytable bs, B.Bytable (Public bs)) => KeyExchangeClass bs where serverKeyExchange :: (HandleLike h, CPRG g) => HandshakeM h g @@ -227,12 +220,12 @@ instance KeyExchangeClass ECC.Curve where serverKeyExchange = do - ServerKeyExEcdhe cv pnt ha sa sn <- readHandshake + SvKeyExEcdhe cv pnt ha sa sn <- readHandshake return (cv, pnt, ha, sa, sn) instance KeyExchangeClass DH.Params where serverKeyExchange = do - ServerKeyExDhe ps pv ha sa sn <- readHandshake + SvKeyExDhe ps pv ha sa sn <- readHandshake return (ps, pv, ha, sa, sn) clientCertificate :: (HandleLike h, CPRG g) => @@ -245,7 +238,7 @@ case find (isMatchedCert cct a dn) crts of Just c -> (>>) <$> writeHandshake . snd <*> return . Just $ c - _ -> throw ALFatal ADUnknownCa $ moduleName ++ + _ -> throw ALFtl ADUnkCa $ modNm ++ ".clientCertificate: no certificate" isMatchedCert :: [ClCertType] -> [(HashAlg, SignAlg)] -> @@ -259,7 +252,7 @@ ccrt (X509.CertificateChain cs@(c : _)) = cpk (X509.certPubKey $ obj c) && not (null . intersect dn $ map (X509.certIssuerDN . obj) cs) - ccrt _ = error $ moduleName ++ ".isMatchedCert: empty certificate chain" + ccrt _ = error $ modNm ++ ".isMatchedCert: empty certificate chain" cpk X509.PubKeyRSA{} = rsa; cpk X509.PubKeyECDSA{} = ecdsa; cpk _ = False finishHandshake :: (HandleLike h, CPRG g) => @@ -268,15 +261,15 @@ hs <- handshakeHash case fst <$> crt of Just (RsaKey sk) -> writeHandshake $ - DigitallySigned (cssAlgorithm sk) $ csSign sk hs + DigitSigned (cssAlgorithm sk) $ csSign sk hs Just (EcdsaKey sk) -> writeHandshake $ - DigitallySigned (cssAlgorithm sk) $ csSign sk hs + DigitSigned (cssAlgorithm sk) $ csSign sk hs _ -> return () - writeHandshake ChangeCipherSpec + writeHandshake CCSpec flushCipherSuite Write writeHandshake =<< finishedHash Client - ChangeCipherSpec <- readHandshake + CCSpec <- readHandshake flushCipherSuite Read (==) `liftM` finishedHash Server `ap` readHandshake >>= flip unless - (throw ALFatal ADDecryptError $ - moduleName ++ ".finishHandshake: finished hash failure") + (throw ALFtl ADDecryptErr $ + modNm ++ ".finishHandshake: finished hash failure") diff --git a/src/Network/PeyoTLS/Codec.hs b/src/Network/PeyoTLS/Codec.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Codec.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.PeyoTLS.Codec ( + Handshake(..), HandshakeItem(..), + ClHello(..), SvHello(..), SssnId(..), + CipherSuite(..), KeyEx(..), BulkEnc(..), + CmpMtd(..), Extension(..), isRnInfo, emptyRnInfo, + SvKeyEx(..), SvKeyExDhe(..), SvKeyExEcdhe(..), + CertReq(..), certReq, ClCertType(..), SignAlg(..), HashAlg(..), + SHDone(..), ClKeyEx(..), Epms(..), + DigitSigned(..), Finished(..), + CCSpec(..), ) 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.Codec.Hello ( + ClHello(..), SvHello(..), SssnId(..), + CipherSuite(..), KeyEx(..), BulkEnc(..), + CmpMtd(..), HashAlg(..), SignAlg(..), + Extension(..), isRnInfo, emptyRnInfo ) +import Network.PeyoTLS.Codec.Certificate ( + CertReq(..), certReq, ClCertType(..), ClKeyEx(..), DigitSigned(..) ) + +modNm :: String +modNm = "Network.PeyoTLS.Types" + +data Handshake + = HCCSpec | HHelloReq + | HClHello ClHello | HSvHello SvHello + | HCert X509.CertificateChain | HSvKeyEx BS.ByteString + | HCertReq CertReq | HSHDone + | HCertVer DigitSigned | HClKeyEx ClKeyEx + | 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 = (,) <$> B.take 1 <*> B.take 3 >>= \(t, l) -> case t of + THelloReq -> const HHelloReq <$> + unless (l == 0) (fail $ modNm ++ ": Handshake.parse") + TClHello -> HClHello <$> B.take l + TSvHello -> HSvHello <$> B.take l + TCert -> HCert <$> B.take l + TSvKeyEx -> HSvKeyEx <$> B.take l + TCertReq -> HCertReq <$> B.take l + TSHDone -> const HSHDone <$> + unless (l == 0) (fail $ modNm ++ ": Handshake.parse") + TCertVer -> HCertVer <$> B.take l + TClKeyEx -> HClKeyEx <$> B.take l + TFinished -> HFinished <$> B.take l + _ -> HRaw t <$> B.take l + +encodeH :: Handshake -> BS.ByteString +encodeH HHelloReq = encodeH $ HRaw THelloReq "" +encodeH (HClHello ch) = encodeH . HRaw TClHello $ B.encode ch +encodeH (HSvHello sh) = encodeH . HRaw TSvHello $ B.encode sh +encodeH (HCert crts) = encodeH . HRaw TCert $ B.encode crts +encodeH (HSvKeyEx ske) = encodeH $ HRaw TSvKeyEx ske +encodeH (HCertReq cr) = encodeH . HRaw TCertReq $ B.encode cr +encodeH HSHDone = encodeH $ HRaw TSHDone "" +encodeH (HCertVer ds) = encodeH . HRaw TCertVer $ B.encode ds +encodeH (HClKeyEx epms) = encodeH . HRaw TClKeyEx $ B.encode epms +encodeH (HFinished bs) = encodeH $ HRaw TFinished bs +encodeH (HRaw t bs) = B.encode t `BS.append` B.addLen w24 bs +encodeH HCCSpec = B.encode CCSpec + +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 + +data CCSpec = CCSpec | CCSpecRaw Word8 deriving Show + +instance HandshakeItem CCSpec where + fromHandshake HCCSpec = Just CCSpec + fromHandshake _ = Nothing + toHandshake CCSpec = HCCSpec + toHandshake (CCSpecRaw _) = error $ modNm ++ ": CCSpec.toHandshake" + +instance B.Bytable CCSpec where + decode bs = case BS.unpack bs of + [1] -> Right CCSpec + [w] -> Right $ CCSpecRaw w + _ -> Left $ modNm ++ ": CCSpec.decode" + encode CCSpec = BS.pack [1] + encode (CCSpecRaw w) = BS.pack [w] + +instance HandshakeItem ClHello where + fromHandshake (HClHello ch) = Just ch + fromHandshake _ = Nothing + toHandshake = HClHello + +instance HandshakeItem SvHello where + fromHandshake (HSvHello sh) = Just sh + fromHandshake _ = Nothing + toHandshake = HSvHello + +instance HandshakeItem X509.CertificateChain where + fromHandshake (HCert cc) = Just cc + fromHandshake _ = Nothing + toHandshake = HCert + +data SvKeyEx = SvKeyEx BS.ByteString BS.ByteString HashAlg SignAlg BS.ByteString + deriving Show + +instance HandshakeItem SvKeyEx where + fromHandshake = undefined + toHandshake = HSvKeyEx . B.encode + +instance B.Bytable SvKeyEx where + decode = undefined + encode (SvKeyEx ps pv h s sn) = BS.concat [ + ps, pv, B.encode h, B.encode s, B.addLen w16 sn ] + +data SvKeyExDhe = SvKeyExDhe DH.Params DH.PublicNumber HashAlg SignAlg BS.ByteString + deriving Show + +instance HandshakeItem SvKeyExDhe where + fromHandshake (HSvKeyEx ske) = either (const Nothing) Just $ B.decode ske + fromHandshake _ = Nothing + toHandshake = HSvKeyEx . B.encode + +instance B.Bytable SvKeyExDhe where + encode (SvKeyExDhe ps pn h s sn) = BS.concat [ + B.encode ps, B.encode pn, B.encode h, B.encode s, B.addLen w16 sn ] + decode = B.evalBytableM B.parse + +instance B.Parsable SvKeyExDhe where + parse = SvKeyExDhe <$> B.parse <*> B.parse + <*> B.parse <*> B.parse <*> (B.take =<< B.take 2) + +data SvKeyExEcdhe = SvKeyExEcdhe ECC.Curve ECC.Point HashAlg SignAlg BS.ByteString + deriving Show + +instance HandshakeItem SvKeyExEcdhe where + fromHandshake (HSvKeyEx ske) = either (const Nothing) Just $ B.decode ske + fromHandshake _ = Nothing + toHandshake = HSvKeyEx . B.encode + +instance B.Bytable SvKeyExEcdhe where + encode (SvKeyExEcdhe cv pnt h s sn) = BS.concat [ + B.encode cv, B.encode pnt, B.encode h, B.encode s, B.addLen w16 sn ] + decode = B.evalBytableM B.parse + +instance B.Parsable SvKeyExEcdhe where + parse = SvKeyExEcdhe <$> B.parse <*> B.parse + <*> B.parse <*> B.parse <*> (B.take =<< B.take 2) + +instance HandshakeItem CertReq where + fromHandshake (HCertReq cr) = Just cr + fromHandshake _ = Nothing + toHandshake = HCertReq + +data SHDone = SHDone deriving Show + +instance HandshakeItem SHDone where + fromHandshake HSHDone = Just SHDone + fromHandshake _ = Nothing + toHandshake _ = HSHDone + +instance HandshakeItem DigitSigned where + fromHandshake (HCertVer ds) = Just ds + fromHandshake _ = Nothing + toHandshake = HCertVer + +instance HandshakeItem ClKeyEx where + fromHandshake (HClKeyEx cke) = Just cke + fromHandshake _ = Nothing + toHandshake = HClKeyEx + +data Epms = Epms BS.ByteString + +instance HandshakeItem Epms where + fromHandshake (HClKeyEx (ClKeyEx cke)) = + case B.runBytableM (B.take =<< B.take 2) cke of + Right (e, "") -> Just $ Epms e + _ -> Nothing + fromHandshake _ = Nothing + toHandshake (Epms epms) = HClKeyEx . ClKeyEx $ B.addLen w16 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 Type + = THelloReq | TClHello | TSvHello | TCert | TSvKeyEx | TCertReq | TSHDone + | TCertVer | TClKeyEx | TFinished | TRaw Word8 deriving Show + +instance B.Bytable Type where + decode bs = case BS.unpack bs of + [0] -> Right THelloReq + [1] -> Right TClHello + [2] -> Right TSvHello + [11] -> Right TCert + [12] -> Right TSvKeyEx + [13] -> Right TCertReq + [14] -> Right TSHDone + [15] -> Right TCertVer + [16] -> Right TClKeyEx + [20] -> Right TFinished + [ht] -> Right $ TRaw ht + _ -> Left $ modNm ++ ": Type.decode" + encode THelloReq = BS.pack [0] + encode TClHello = BS.pack [1] + encode TSvHello = BS.pack [2] + encode TCert = BS.pack [11] + encode TSvKeyEx = BS.pack [12] + encode TCertReq = BS.pack [13] + encode TSHDone = BS.pack [14] + encode TCertVer = BS.pack [15] + encode TClKeyEx = BS.pack [16] + encode TFinished = BS.pack [20] + encode (TRaw w) = BS.pack [w] + +w16 :: Word16; w16 = undefined +w24 :: Word24; w24 = undefined diff --git a/src/Network/PeyoTLS/Codec/Certificate.hs b/src/Network/PeyoTLS/Codec/Certificate.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Codec/Certificate.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Network.PeyoTLS.Codec.Certificate ( + CertReq(..), certReq, ClCertType(..), ClKeyEx(..), DigitSigned(..)) where + +import Control.Applicative ((<$>), (<*>)) +import Data.Word (Word8, Word16) +import Data.Word.Word24 (Word24) + +import qualified Data.ByteString as BS +import qualified Data.ASN1.Types as ASN1 +import qualified Data.ASN1.Encoding as ASN1 +import qualified Data.ASN1.BinaryEncoding as ASN1 +import qualified Data.X509 as X509 +import qualified Data.X509.CertificateStore as X509 +import qualified Codec.Bytable.BigEndian as B + +import Network.PeyoTLS.Codec.HSAlg (HashAlg, SignAlg) + +modNm :: String +modNm = "Network.PeyoTLS.Codec.Certificate" + +instance B.Bytable X509.CertificateChain where + decode = B.evalBytableM B.parse + encode = B.addLen w24 . cmap (B.addLen w24) + . (\(X509.CertificateChainRaw c) -> c) . X509.encodeCertificateChain + . (\(X509.CertificateChain cs) -> X509.CertificateChain cs) + +instance B.Parsable X509.CertificateChain where + parse = X509.decodeCertificateChain . X509.CertificateChainRaw <$> + (flip B.list (B.take =<< B.take 3) =<< B.take 3) >>= \ecc -> + case ecc of + Right (X509.CertificateChain cs) -> + return $ X509.CertificateChain cs + Left (n, em) -> fail $ modNm ++ ": " ++ + "X509.CertificateChain.parse" ++ show n ++ " " ++ em + +data CertReq = CertReq [ClCertType] [(HashAlg, SignAlg)] [X509.DistinguishedName] + deriving Show + +certReq :: [ClCertType] -> [(HashAlg, SignAlg)] -> X509.CertificateStore -> CertReq +certReq t a = CertReq t a + . map (X509.certIssuerDN . X509.signedObject . X509.getSigned) + . X509.listCertificates + +instance B.Bytable CertReq where + encode (CertReq t a n) = BS.concat [ + B.addLen w8 $ cmap B.encode t, + B.addLen w16 $ + cmap (\(h, s) -> B.encode h `BS.append` B.encode s) a, + B.addLen w16 . flip cmap n $ B.addLen w16 . + ASN1.encodeASN1' ASN1.DER . flip ASN1.toASN1 [] ] + decode = B.evalBytableM $ CertReq + <$> (flip B.list (B.take 1) =<< B.take 1) + <*> (flip B.list ((,) <$> B.take 1 <*> B.take 1) =<< B.take 2) + <*> ((B.take 2 >>=) . flip B.list $ + either (fail . show) (return . fst) . ASN1.fromASN1 =<< + either (fail . show) return . ASN1.decodeASN1' ASN1.DER =<< + B.take =<< B.take 2) + +data ClCertType = CTRsaSign | CTEcdsaSign | CTRaw Word8 deriving (Show, Eq) + +instance B.Bytable ClCertType where + encode CTRsaSign = "\x01" + encode CTEcdsaSign = "\x40" + encode (CTRaw w) = BS.pack [w] + decode bs = case BS.unpack bs of + [w] -> Right $ case w of + 1 -> CTRsaSign; 64 -> CTEcdsaSign; _ -> CTRaw w + _ -> Left $ modNm ++ ": ClCertType.decode" + +data ClKeyEx = ClKeyEx BS.ByteString deriving Show +instance B.Bytable ClKeyEx where decode = Right . ClKeyEx; encode (ClKeyEx e) = e + +data DigitSigned + = DigitSigned (HashAlg, SignAlg) BS.ByteString + | DigitSignedRaw BS.ByteString + deriving Show + +instance B.Bytable DigitSigned where + decode = B.evalBytableM $ DigitSigned + <$> ((,) <$> B.take 1 <*> B.take 1) <*> (B.take =<< B.take 2) + encode (DigitSigned (ha, sa) bs) = BS.concat + [B.encode ha, B.encode sa, B.addLen w16 bs] + encode (DigitSignedRaw bs) = bs + +cmap :: (a -> BS.ByteString) -> [a] -> BS.ByteString +cmap = (BS.concat .) . map + +w8 :: Word8; w8 = undefined +w16 :: Word16; w16 = undefined +w24 :: Word24; w24 = undefined diff --git a/src/Network/PeyoTLS/Codec/Extension.hs b/src/Network/PeyoTLS/Codec/Extension.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Codec/Extension.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Network.PeyoTLS.Codec.Extension ( + Extension(..), isRnInfo, emptyRnInfo, SignAlg(..), HashAlg(..) ) where + +import Control.Applicative ((<$>), (<*>)) +import Data.Bits (shiftL, (.|.)) +import Data.Word (Word8, Word16) + +import qualified Data.ByteString as BS +import qualified Codec.Bytable.BigEndian as B +import qualified Crypto.Types.PubKey.DH as DH +import qualified Crypto.Types.PubKey.ECC as ECC + +import Network.PeyoTLS.Codec.HSAlg(HashAlg(..), SignAlg(..)) + +modNm :: String +modNm = "Network.PeyoTLS.Codec.Extension" + +data Extension + = ESName [SName] + | EECrv [ECC.CurveName] | EEPFrmt [EPFrmt] + | ESsnTcktTls BS.ByteString | ENxPrtNego BS.ByteString + | ERnInfo BS.ByteString | ERaw EType BS.ByteString + deriving (Show, Eq) + +instance B.Bytable Extension where + encode (ESName n) = B.encode . ERaw TSName . B.addLen w16 $ cmap B.encode n + encode (EECrv c) = B.encode . ERaw TECrv . B.addLen w16 $ cmap B.encode c + encode (EEPFrmt f) = B.encode . ERaw TEPFrmt . B.addLen w8 $ cmap B.encode f + encode (ESsnTcktTls t) = B.encode $ ERaw TSsnTcktTls t + encode (ENxPrtNego n) = B.encode $ ERaw TNxPrtNego n + encode (ERnInfo i) = B.encode . ERaw TRnInfo $ B.addLen w8 i + encode (ERaw t e) = B.encode t `BS.append` B.addLen w16 e + decode = B.evalBytableM B.parse + +instance B.Parsable Extension where + parse = (,) <$> B.take 2 <*> B.take 2 >>= \(t, l) -> case t of + TSName -> ESName <$> (flip B.list B.parse =<< B.take 2) + TECrv -> EECrv <$> (flip B.list (B.take 2) =<< B.take 2) + TEPFrmt -> EEPFrmt <$> (flip B.list (B.take 1) =<< B.take 1) + TSsnTcktTls -> ESsnTcktTls <$> B.take l + TNxPrtNego -> ENxPrtNego <$> B.take l + TRnInfo -> ERnInfo <$> (B.take =<< B.take 1) + _ -> ERaw t <$> B.take l + +cmap :: (a -> BS.ByteString) -> [a] -> BS.ByteString +cmap = (BS.concat .) . map + +data EType + = TSName | TECrv | TEPFrmt | TSsnTcktTls + | TNxPrtNego | TRnInfo | TRaw Word16 deriving (Show, Eq) + +instance B.Bytable EType where + encode TSName = B.encode (0 :: Word16) + encode TECrv = B.encode (10 :: Word16) + encode TEPFrmt = B.encode (11 :: Word16) + encode TSsnTcktTls = B.encode (35 :: Word16) + encode TNxPrtNego = B.encode (13172 :: Word16) + encode TRnInfo = B.encode (65281 :: Word16) + encode (TRaw et) = B.encode et + decode bs = case BS.unpack bs of + [w1, w2] -> Right $ + case fromIntegral w1 `shiftL` 8 .|. fromIntegral w2 of + 0 -> TSName + 10 -> TECrv + 11 -> TEPFrmt + 35 -> TSsnTcktTls + 13172 -> TNxPrtNego + 65281 -> TRnInfo + et -> TRaw et + _ -> Left $ modNm ++ ": EType.decode" + +data SName = SNHName BS.ByteString | SNRaw NType BS.ByteString deriving (Show, Eq) + +instance B.Bytable SName where + encode (SNHName nm) = B.encode $ SNRaw NTHName nm + encode (SNRaw nt nm) = B.encode nt `BS.append` B.addLen w16 nm + decode = B.evalBytableM B.parse + +instance B.Parsable SName where + parse = (\t n -> case t of NTHName -> SNHName n; _ -> SNRaw t n) + <$> B.take 1 <*> (B.take =<< B.take 2) + +data NType = NTHName | NTRaw Word8 deriving (Show, Eq) + +instance B.Bytable NType where + encode NTHName = BS.pack [0] + encode (NTRaw t) = BS.pack [t] + decode bs = case BS.unpack bs of + [t] -> Right $ case t of 0 -> NTHName; _ -> NTRaw t + _ -> Left $ modNm ++ ": NType.decode" + +instance B.Bytable DH.Params where + encode (DH.Params p g) = BS.concat + [B.addLen w16 $ B.encode p, B.addLen w16 $ B.encode g] + decode = B.evalBytableM B.parse + +instance B.Parsable DH.Params where + parse = DH.Params <$> (B.take =<< B.take 2) <*> (B.take =<< B.take 2) + +instance B.Bytable DH.PublicNumber where + encode = B.addLen w16 . B.encode . \(DH.PublicNumber pn) -> pn + decode = B.evalBytableM B.parse + +instance B.Parsable DH.PublicNumber where + parse = fromInteger <$> (B.take =<< B.take 2) + +data ECType = ExpPrm | ExpCh2 | NmdCrv | CRaw Word8 deriving Show + +instance B.Bytable ECType where + encode ExpPrm = BS.pack [1] + encode ExpCh2 = BS.pack [2] + encode NmdCrv = BS.pack [3] + encode (CRaw w) = BS.pack [w] + decode = B.evalBytableM B.parse + +instance B.Parsable ECType where + parse = (\t -> case t of 1 -> ExpPrm; 2 -> ExpCh2; 3 -> NmdCrv; _ -> CRaw t) + <$> B.head + +instance B.Bytable ECC.CurveName where + encode ECC.SEC_t163k1 = B.encode (1 :: Word16) + encode ECC.SEC_t163r1 = B.encode (2 :: Word16) + encode ECC.SEC_t163r2 = B.encode (3 :: Word16) + encode ECC.SEC_t193r1 = B.encode (4 :: Word16) + encode ECC.SEC_t193r2 = B.encode (5 :: Word16) + encode ECC.SEC_t233k1 = B.encode (6 :: Word16) + encode ECC.SEC_t233r1 = B.encode (7 :: Word16) + encode ECC.SEC_t239k1 = B.encode (8 :: Word16) + encode ECC.SEC_t283k1 = B.encode (9 :: Word16) + encode ECC.SEC_t283r1 = B.encode (10 :: Word16) + encode ECC.SEC_t409k1 = B.encode (11 :: Word16) + encode ECC.SEC_t409r1 = B.encode (12 :: Word16) + encode ECC.SEC_t571k1 = B.encode (13 :: Word16) + encode ECC.SEC_t571r1 = B.encode (14 :: Word16) + encode ECC.SEC_p160k1 = B.encode (15 :: Word16) + encode ECC.SEC_p160r1 = B.encode (16 :: Word16) + encode ECC.SEC_p160r2 = B.encode (17 :: Word16) + encode ECC.SEC_p192k1 = B.encode (18 :: Word16) + encode ECC.SEC_p192r1 = B.encode (19 :: Word16) + encode ECC.SEC_p224k1 = B.encode (20 :: Word16) + encode ECC.SEC_p224r1 = B.encode (21 :: Word16) + encode ECC.SEC_p256k1 = B.encode (22 :: Word16) + encode ECC.SEC_p256r1 = B.encode (23 :: Word16) + encode ECC.SEC_p384r1 = B.encode (24 :: Word16) + encode ECC.SEC_p521r1 = B.encode (25 :: Word16) + encode _ = error "Extension.encodeCN: not implemented" + decode bs = case BS.unpack bs of + [w1, w2] -> case fromIntegral w1 `shiftL` 8 .|. fromIntegral w2 of + (1 :: Word16) -> Right ECC.SEC_t163k1 + (2 :: Word16) -> Right ECC.SEC_t163r1 + (3 :: Word16) -> Right ECC.SEC_t163r2 + (4 :: Word16) -> Right ECC.SEC_t193r1 + (5 :: Word16) -> Right ECC.SEC_t193r2 + (6 :: Word16) -> Right ECC.SEC_t233k1 + (7 :: Word16) -> Right ECC.SEC_t233r1 + (8 :: Word16) -> Right ECC.SEC_t239k1 + (9 :: Word16) -> Right ECC.SEC_t283k1 + (10 :: Word16) -> Right ECC.SEC_t283r1 + (11 :: Word16) -> Right ECC.SEC_t409k1 + (12 :: Word16) -> Right ECC.SEC_t409r1 + (13 :: Word16) -> Right ECC.SEC_t571k1 + (14 :: Word16) -> Right ECC.SEC_t571r1 + (15 :: Word16) -> Right ECC.SEC_p160k1 + (16 :: Word16) -> Right ECC.SEC_p160r1 + (17 :: Word16) -> Right ECC.SEC_p160r2 + (18 :: Word16) -> Right ECC.SEC_p192k1 + (19 :: Word16) -> Right ECC.SEC_p192r1 + (20 :: Word16) -> Right ECC.SEC_p224k1 + (21 :: Word16) -> Right ECC.SEC_p224r1 + (22 :: Word16) -> Right ECC.SEC_p256k1 + (23 :: Word16) -> Right ECC.SEC_p256r1 + (24 :: Word16) -> Right ECC.SEC_p384r1 + (25 :: Word16) -> Right ECC.SEC_p521r1 + n -> Left $ modNm ++ ": CurveName.decode: unknown crv: " ++ + show n + _ -> Left $ modNm ++ ": CurveName.decode: bad format" + +instance B.Parsable ECC.CurveName where parse = B.take 2 + +instance B.Bytable ECC.Curve where + encode c + | c == ECC.getCurveByName ECC.SEC_p256r1 = + B.encode NmdCrv `BS.append` B.encode ECC.SEC_p256r1 + | c == ECC.getCurveByName ECC.SEC_p384r1 = + B.encode NmdCrv `BS.append` B.encode ECC.SEC_p384r1 + | c == ECC.getCurveByName ECC.SEC_p521r1 = + B.encode NmdCrv `BS.append` B.encode ECC.SEC_p521r1 + | otherwise = error $ modNm ++ ": ECC.Curve.encode: not implemented" + decode = B.evalBytableM B.parse + +instance B.Parsable ECC.Curve where + parse = (ECC.getCurveByName <$>) $ B.parse >>= \t -> case t of + NmdCrv -> B.parse + _ -> error $ modNm ++ ": ECC.Curve.parse: not implemented" + +data EPFrmt = EPFUncomp | EPFRaw Word8 deriving (Show, Eq) + +instance B.Bytable EPFrmt where + encode EPFUncomp = BS.pack [0] + encode (EPFRaw f) = BS.pack [f] + decode bs = case BS.unpack bs of + [f] -> Right $ case f of 0 -> EPFUncomp; _ -> EPFRaw f + _ -> Left $ modNm ++ ": Bytable.decode" + +instance B.Bytable ECC.Point where + encode (ECC.Point x y) = B.addLen w8 $ + 4 `BS.cons` pad 32 0 (B.encode x) `BS.append` pad 32 0 (B.encode y) + where pad n w s = BS.replicate (n - BS.length s) w `BS.append` s + encode ECC.PointO = error $ modNm ++ ": EC.Point.encode" + decode = B.evalBytableM B.parse + +instance B.Parsable ECC.Point where + parse = (B.take =<< B.take 1) >>= \bs -> case BS.uncons bs of + Just (4, xy) -> return $ let (x, y) = BS.splitAt 32 xy in ECC.Point + (either error id $ B.decode x) + (either error id $ B.decode y) + _ -> fail $ modNm ++ ": ECC.Point.parse" + +isRnInfo :: Extension -> Bool +isRnInfo (ERnInfo _) = True +isRnInfo _ = False + +emptyRnInfo :: Extension +emptyRnInfo = ERnInfo "" + +w8 :: Word8; w8 = undefined +w16 :: Word16; w16 = undefined diff --git a/src/Network/PeyoTLS/Codec/HSAlg.hs b/src/Network/PeyoTLS/Codec/HSAlg.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Codec/HSAlg.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.PeyoTLS.Codec.HSAlg (SignAlg(..), HashAlg(..)) where + +import Data.Word (Word8) + +import qualified Data.ByteString as BS +import qualified Codec.Bytable.BigEndian as B + +modNm :: String +modNm = "Network.PeyoTLS.Codec.HSAlg" + +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 $ modNm ++ ": HashAlg.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 $ modNm ++ ": SignAlg.decode" +instance B.Parsable SignAlg where parse = B.take 1 diff --git a/src/Network/PeyoTLS/Codec/Hello.hs b/src/Network/PeyoTLS/Codec/Hello.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Codec/Hello.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.PeyoTLS.Codec.Hello ( + ClHello(..), SvHello(..), SssnId(..), + CipherSuite(..), KeyEx(..), BulkEnc(..), + CmpMtd(..), SignAlg(..), HashAlg(..), + Extension(..), isRnInfo, emptyRnInfo ) where + +import Control.Applicative ((<$>), (<*>)) +import Data.Word (Word8, Word16) + +import qualified Data.ByteString as BS +import qualified Codec.Bytable.BigEndian as B + +import Network.PeyoTLS.Codec.Extension ( + Extension(..), isRnInfo, emptyRnInfo, SignAlg(..), HashAlg(..) ) +import Network.PeyoTLS.CipherSuite (CipherSuite(..), KeyEx(..), BulkEnc(..)) + +modNm :: String +modNm = "Network.PeyoTLS.Codec.Hello" + +data ClHello + = ClHello (Word8, Word8) BS.ByteString SssnId [CipherSuite] [CmpMtd] + (Maybe [Extension]) + | ClHelloRaw BS.ByteString + deriving Show + +instance B.Bytable ClHello where + decode = B.evalBytableM $ ClHello + <$> ((,) <$> B.head <*> B.head) + <*> B.take 32 <*> (B.take =<< B.take 1) + <*> (flip B.list (B.take 2) =<< B.take 2) + <*> (flip B.list (B.take 1) =<< B.take 1) + <*> do nl <- B.null + if nl then return Nothing else Just <$> + (flip B.list B.parse =<< B.take 2) + encode (ClHello (vj, vn) r sid css cms mel) = BS.concat [ + B.encode vj, B.encode vn, B.encode r, B.addLen w8 $ B.encode sid, + B.addLen w16 . BS.concat $ map B.encode css, + B.addLen w8 . BS.concat $ map B.encode cms, + maybe "" (B.addLen w16 . BS.concat . map B.encode) mel ] + encode (ClHelloRaw bs) = bs + +data SvHello + = SvHello (Word8, Word8) BS.ByteString SssnId CipherSuite CmpMtd + (Maybe [Extension]) + | SvHelloRaw BS.ByteString + deriving Show + +instance B.Bytable SvHello where + decode = B.evalBytableM $ SvHello + <$> ((,) <$> B.head <*> B.head) + <*> B.take 32 <*> (B.take =<< B.take 1) <*> B.take 2 <*> B.take 1 + <*> do n <- B.null + if n then return Nothing else Just <$> + (flip B.list B.parse =<< B.take 2) + encode (SvHello (vj, vn) r sid cs cm mes) = BS.concat [ + B.encode vj, B.encode vn, B.encode r, B.addLen w8 $ B.encode sid, + B.encode cs, B.encode cm, + maybe "" (B.addLen w16 . BS.concat . map B.encode) mes ] + encode (SvHelloRaw sh) = sh + +data SssnId = SssnId BS.ByteString deriving Show + +instance B.Bytable SssnId where decode = Right . SssnId; encode (SssnId bs) = bs + +data CmpMtd = CmpMtdNull | CmpMtdRaw Word8 deriving (Show, Eq) + +instance B.Bytable CmpMtd where + decode bs = case BS.unpack bs of + [cm] -> Right $ case cm of 0 -> CmpMtdNull; _ -> CmpMtdRaw cm + _ -> Left $ modNm ++ ": CmpMtd.decode" + encode CmpMtdNull = "\0" + encode (CmpMtdRaw cm) = BS.pack [cm] + +w8 :: Word8; w8 = undefined +w16 :: Word16; w16 = undefined diff --git a/src/Network/PeyoTLS/Crypto.hs b/src/Network/PeyoTLS/Crypto.hs deleted file mode 100644 --- a/src/Network/PeyoTLS/Crypto.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE OverloadedStrings, PackageImports, TupleSections #-} - -module Network.PeyoTLS.Crypto ( - makeKeys, encrypt, decrypt, hashSha1, hashSha256, - Side(..), 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 - -data Side = Server | Client deriving (Show, Eq) - -finishedHash :: Side -> BS.ByteString -> BS.ByteString -> BS.ByteString -finishedHash s ms hash = take 12 . prf ms . (`BS.append` hash) $ case s of - Client -> "client finished" - Server -> "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 deleted file mode 100644 --- a/src/Network/PeyoTLS/Extension.hs +++ /dev/null @@ -1,220 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Network.PeyoTLS.Extension (Extension(..), SignAlg(..), HashAlg(..)) where - -import Control.Applicative ((<$>), (<*>)) -import Data.Bits (shiftL, (.|.)) -import Data.Word (Word8, Word16) - -import qualified Data.ByteString as BS -import qualified Codec.Bytable.BigEndian as B -import qualified Crypto.Types.PubKey.DH as DH -import qualified Crypto.Types.PubKey.ECC as ECC - -import Network.PeyoTLS.HSAlg(HashAlg(..), SignAlg(..)) - -data Extension - = ESName [ServerName] - | EECurve [ECC.CurveName] | EEcPFrt [EcPointFormat] - | ESsnTicketTls BS.ByteString - | ENextProtoNego BS.ByteString - | ERenegoInfo BS.ByteString - | ERaw EType BS.ByteString - deriving (Show, Eq) - -instance B.Bytable Extension where - encode = encodeE; decode = B.evalBytableM B.parse - -instance B.Parsable Extension where - parse = parseE - -encodeE :: Extension -> BS.ByteString -encodeE (ESName sn) = encodeE . ERaw TSName . B.addLen w16 $ cmap B.encode sn -encodeE (EECurve ec) = encodeE . ERaw TECurve . B.addLen w16 $ cmap B.encode ec -encodeE (EEcPFrt pf) = encodeE . ERaw TEcPFrt . B.addLen w8 $ cmap B.encode pf -encodeE (ESsnTicketTls stt) = encodeE $ ERaw TSsnTicketTls stt -encodeE (ENextProtoNego npn) = encodeE $ ERaw TNextProtoNego npn -encodeE (ERenegoInfo ri) = encodeE . ERaw TRenegoInfo $ B.addLen w8 ri -encodeE (ERaw et body) = B.encode et `BS.append` B.addLen w16 body - -parseE :: B.BytableM Extension -parseE = do - (t, l) <- (,) <$> B.take 2 <*> B.take 2 - case t of - TSName -> ESName <$> (flip B.list B.parse =<< B.take 2) - TECurve -> EECurve <$> (flip B.list (B.take 2) =<< B.take 2) - TEcPFrt -> EEcPFrt <$> (flip B.list (B.take 1) =<< B.take 1) - TSsnTicketTls -> ESsnTicketTls <$> B.take l - TNextProtoNego -> ENextProtoNego <$> B.take l - TRenegoInfo -> ERenegoInfo <$> (B.take =<< B.take 1) - _ -> ERaw t <$> B.take l - -data EType - = TSName | TECurve | TEcPFrt | TSsnTicketTls - | TNextProtoNego | TRenegoInfo | TRaw Word16 deriving (Show, Eq) - -instance B.Bytable EType where - encode TSName = B.encode (0 :: Word16) - encode TECurve = B.encode (10 :: Word16) - encode TEcPFrt = B.encode (11 :: Word16) - encode TSsnTicketTls = B.encode (35 :: Word16) - encode TNextProtoNego = B.encode (13172 :: Word16) - encode TRenegoInfo = B.encode (65281 :: Word16) - encode (TRaw et) = B.encode et - decode bs = case BS.unpack bs of - [w1, w2] -> Right $ - case fromIntegral w1 `shiftL` 8 .|. fromIntegral w2 of - 0 -> TSName - 10 -> TECurve - 11 -> TEcPFrt - 35 -> TSsnTicketTls - 13172 -> TNextProtoNego - 65281 -> TRenegoInfo - et -> TRaw et - _ -> Left "Extension: EType.decode" - -data ServerName = SNHostName BS.ByteString | SNRaw NameType BS.ByteString - deriving (Show, Eq) - -instance B.Bytable ServerName where - encode (SNHostName nm) = B.encode $ SNRaw NTHostName nm - encode (SNRaw nt nm) = B.encode nt `BS.append` B.addLen w16 nm - decode = B.evalBytableM B.parse - -instance B.Parsable ServerName where - parse = do - (t, n) <- (,) <$> B.take 1 <*> (B.take =<< B.take 2) - return $ case t of - NTHostName -> SNHostName n; _ -> SNRaw t n - -data NameType = NTHostName | NTRaw Word8 deriving (Show, Eq) - -instance B.Bytable NameType where - encode NTHostName = BS.pack [0] - encode (NTRaw t) = BS.pack [t] - decode bs = case BS.unpack bs of - [t] -> Right $ case t of 0 -> NTHostName; _ -> NTRaw t - _ -> Left "Extension: NameType.decode" - -instance B.Bytable DH.Params where - encode (DH.Params p g) = - BS.concat [B.addLen w16 $ B.encode p, B.addLen w16 $ B.encode g] - decode = B.evalBytableM B.parse - -instance B.Parsable DH.Params where - parse = DH.Params - <$> (B.take =<< B.take 2) - <*> (B.take =<< B.take 2) - -instance B.Bytable DH.PublicNumber where - encode = B.addLen w16 . B.encode . \(DH.PublicNumber pn) -> pn - decode = B.evalBytableM B.parse - -instance B.Parsable DH.PublicNumber where - parse = fromInteger <$> (B.take =<< B.take 2) - -data EcCurveType = ExplicitPrime | ExplicitChar2 | NamedCurve | ECTRaw Word8 - deriving Show - -instance B.Bytable EcCurveType where - encode ExplicitPrime = BS.pack [1] - encode ExplicitChar2 = BS.pack [2] - encode NamedCurve = BS.pack [3] - encode (ECTRaw w) = BS.pack [w] - decode = B.evalBytableM B.parse - -instance B.Parsable EcCurveType where - parse = do - ct <- B.head - return $ case ct of - 1 -> ExplicitPrime - 2 -> ExplicitChar2 - 3 -> NamedCurve - w -> ECTRaw w - -instance B.Bytable ECC.CurveName where - encode ECC.SEC_t163k1 = B.encode (1 :: Word16) - encode ECC.SEC_t163r1 = B.encode (2 :: Word16) - encode ECC.SEC_t163r2 = B.encode (3 :: Word16) - encode ECC.SEC_t193r1 = B.encode (4 :: Word16) - encode ECC.SEC_t193r2 = B.encode (5 :: Word16) - encode ECC.SEC_t233k1 = B.encode (6 :: Word16) - encode ECC.SEC_t233r1 = B.encode (7 :: Word16) - encode ECC.SEC_t409k1 = B.encode (11 :: Word16) - encode ECC.SEC_t409r1 = B.encode (12 :: Word16) - encode ECC.SEC_t571k1 = B.encode (13 :: Word16) - encode ECC.SEC_t571r1 = B.encode (14 :: Word16) - encode ECC.SEC_p256r1 = B.encode (23 :: Word16) - encode ECC.SEC_p384r1 = B.encode (24 :: Word16) - encode ECC.SEC_p521r1 = B.encode (25 :: Word16) - encode _ = error "Extension.encodeCN: not implemented" - decode bs = case BS.unpack bs of - [w1, w2] -> case fromIntegral w1 `shiftL` 8 .|. fromIntegral w2 of - (1 :: Word16) -> Right ECC.SEC_t163k1 - (2 :: Word16) -> Right ECC.SEC_t163r1 - (3 :: Word16) -> Right ECC.SEC_t163r2 - (4 :: Word16) -> Right ECC.SEC_t193r1 - (5 :: Word16) -> Right ECC.SEC_t193r2 - (6 :: Word16) -> Right ECC.SEC_t233k1 - (7 :: Word16) -> Right ECC.SEC_t233r1 - (11 :: Word16) -> Right ECC.SEC_t409k1 - (12 :: Word16) -> Right ECC.SEC_t409r1 - (13 :: Word16) -> Right ECC.SEC_t571k1 - (14 :: Word16) -> Right ECC.SEC_t571r1 - (23 :: Word16) -> Right ECC.SEC_p256r1 - (24 :: Word16) -> Right ECC.SEC_p384r1 - (25 :: Word16) -> Right ECC.SEC_p521r1 - n -> Left $ "Extension: CurveName.decode: unknown curve: " ++ - show n - _ -> Left "Extension: CurveName.decode: bad format" - -instance B.Parsable ECC.CurveName where - parse = B.take 2 - -instance B.Bytable ECC.Curve where - encode c - | c == ECC.getCurveByName ECC.SEC_p256r1 = - B.encode NamedCurve `BS.append` B.encode ECC.SEC_p256r1 - | otherwise = error "TlsServer.encodeC: not implemented" - decode = B.evalBytableM B.parse - -instance B.Parsable ECC.Curve where - parse = ECC.getCurveByName <$> do - NamedCurve <- B.parse - B.parse - -data EcPointFormat = EPFUncompressed | EPFRaw Word8 deriving (Show, Eq) - -instance B.Bytable EcPointFormat where - encode EPFUncompressed = BS.pack [0] - encode (EPFRaw f) = BS.pack [f] - decode bs = case BS.unpack bs of - [f] -> Right $ case f of 0 -> EPFUncompressed; _ -> EPFRaw f - _ -> Left "Extension: Bytable.decode" - -instance B.Bytable ECC.Point where - encode (ECC.Point x y) = B.addLen w8 $ - 4 `BS.cons` padd 32 0 (B.encode x) `BS.append` - padd 32 0 (B.encode y) - encode ECC.PointO = error "Extension: EC.Point.encode" - decode = B.evalBytableM B.parse - -padd :: Int -> Word8 -> BS.ByteString -> BS.ByteString -padd n w s = BS.replicate (n - BS.length s) w `BS.append` s - -instance B.Parsable ECC.Point where - parse = do - bs <- B.take =<< B.take 1 - case BS.uncons bs of - Just (4, rest) -> return $ let (x, y) = BS.splitAt 32 rest in - ECC.Point - (either error id $ B.decode x) - (either error id $ B.decode y) - _ -> fail "Extension: ECC.Point.parse" - -w8 :: Word8; w8 = undefined -w16 :: Word16; w16 = undefined - -cmap :: (a -> BS.ByteString) -> [a] -> BS.ByteString -cmap = (BS.concat .) . map diff --git a/src/Network/PeyoTLS/HSAlg.hs b/src/Network/PeyoTLS/HSAlg.hs deleted file mode 100644 --- a/src/Network/PeyoTLS/HSAlg.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Network/PeyoTLS/Handle.hs +++ /dev/null @@ -1,496 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports #-} - -module Network.PeyoTLS.Handle ( debug, - M.TlsM, run, M.withRandom, - TlsHandleBase(names), M.CipherSuite, - newHandle, chGet, ccsPut, hsPut, - adGet, adGetLine, adGetContent, adPut, adDebug, adClose, - flushAd, getBuf, setBuf, - getCipherSuite, setCipherSuite, - M.SettingsC, getSettingsC, setSettingsC, - M.SettingsS, getSettingsS, setSettingsS, - getClFinished, getSvFinished, setClFinished, setSvFinished, - makeKeys, setKeys, - getNames, setNames, - C.Side(..), finishedHash, - M.RW(..), flushCipherSuite, - ValidateHandle(..), tValidate, - M.CertSecretKey(..), M.isRsaKey, M.isEcdsaKey, - M.Alert(..), M.AlertLevel(..), M.AlertDesc(..), debugCipherSuite ) where - -import Control.Arrow (second) -import Control.Monad (when, unless, liftM) -import "monads-tf" Control.Monad.State (lift, get, put) -import "monads-tf" Control.Monad.Error (catchError, throwError) -import Data.Word (Word8, Word16, Word64) -import Data.HandleLike (HandleLike(..)) -import System.IO (Handle) -import "crypto-random" Crypto.Random (CPRG) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC -import qualified Data.X509 as X509 -import qualified Data.X509.Validation as X509 -import qualified Data.X509.CertificateStore as X509 -import qualified Codec.Bytable.BigEndian as B - -import qualified Network.PeyoTLS.Monad as M ( - TlsM, evalTlsM, initState, withRandom, - Alert(..), AlertLevel(..), AlertDesc(..), - tGet, tPut, tClose, tDebug, - PartnerId, newPartnerId, ContentType(..), - getRBuf, getWBuf, getAdBuf, setRBuf, setWBuf, setAdBuf, - getRSn, getWSn, sccRSn, sccWSn, rstRSn, rstWSn, - getClFinished, getSvFinished, setClFinished, setSvFinished, - getNames, setNames, - CipherSuite(..), BulkEnc(..), CertSecretKey(..), isRsaKey, isEcdsaKey, - SettingsC, getSettingsC, setSettingsC, - SettingsS, getSettingsS, setSettingsS, - RW(..), getCipherSuite, setCipherSuite, flushCipherSuite, - Keys(..), getKeys, setKeys ) -import qualified Network.PeyoTLS.Crypto as C ( - makeKeys, encrypt, decrypt, hashSha1, hashSha256, - Side(..), finishedHash ) - -class HandleLike h => ValidateHandle h where - validate :: h -> X509.CertificateStore -> X509.CertificateChain -> - HandleMonad h [X509.FailedReason] - -tValidate :: ValidateHandle h => - TlsHandleBase h g -> X509.CertificateStore -> X509.CertificateChain -> - M.TlsM h g [X509.FailedReason] -tValidate t cs cc = lift . lift $ validate (tlsHandle t) cs cc - -instance ValidateHandle Handle where - validate _ cs cc = - X509.validate X509.HashSHA256 X509.defaultHooks ch cs ca ("", "") cc - where - ch = X509.defaultChecks { X509.checkFQHN = False } - ca = X509.ValidationCache - (\_ _ _ -> return X509.ValidationCacheUnknown) - (\_ _ _ -> return ()) - -data TlsHandleBase h g = TlsHandleBase { - partnerId :: M.PartnerId, - tlsHandle :: h, - names :: [String] } - deriving Show - -run :: HandleLike h => M.TlsM h g a -> g -> HandleMonad h a -run m g = do - ret <- (`M.evalTlsM` M.initState g) $ m `catchError` \a -> throwError a - case ret of - Right r -> return r - Left a -> error $ show a - -newHandle :: HandleLike h => h -> M.TlsM h g (TlsHandleBase h g) -newHandle h = do - s <- get - let (i, s') = M.newPartnerId s - put s' - return TlsHandleBase { - partnerId = i, tlsHandle = h, names = [] } - -getContentType :: (HandleLike h, CPRG g) => TlsHandleBase h g -> M.TlsM h g M.ContentType -getContentType t = do - (ct, bs) <- M.getRBuf (partnerId t) - (\gt -> case (ct, bs) of (M.CTNull, _) -> gt; (_, "") -> gt; _ -> return ct) $ - do (ct', bf) <- getWholeWithCt t - M.setRBuf (partnerId t) (ct', bf) - return ct' - -flushAd :: (HandleLike h, CPRG g) => - TlsHandleBase h g -> M.TlsM h g (BS.ByteString, Bool) -flushAd t = do - lift . lift $ hlDebug (tlsHandle t) "low" "begin flushAd\n" - ct <- getContentType t - lift . lift $ hlDebug (tlsHandle t) "low" "after getContentType\n" - case ct of - M.CTAppData -> do - lift . lift $ hlDebug (tlsHandle t) "low" "CTAppData\n" - (ct', ad) <- tGetContent t - lift . lift $ hlDebug (tlsHandle t) "low" . - BSC.pack $ show (ct', ad) ++ "\n" - (bs, b) <- flushAd t - lift . lift . hlDebug (tlsHandle t) "low" . - BSC.pack $ show bs - return (ad `BS.append` bs, b) - M.CTAlert -> do - (_, a) <- buffered t 2 - lift . lift $ hlDebug (tlsHandle t) "low" . - BSC.pack $ show a - case a of - "\1\0" -> return ("", False) - _ -> throwError "flushAd" - _ -> do lift . lift $ hlDebug (tlsHandle t) "low" . - BSC.pack $ show ct - return ("", True) - -chGet :: (HandleLike h, CPRG g) => - TlsHandleBase h g -> Int -> M.TlsM h g (Either Word8 BS.ByteString) -chGet _ 0 = return $ Right "" -chGet t n = do - lift . lift . hlDebug (tlsHandle t) "critical" . - BSC.pack . (++ "\n") $ show n - ct <- getContentType t - lift . lift . hlDebug (tlsHandle t) "critical" . - BSC.pack . (++ "\n") $ show ct - case ct of - M.CTCCSpec -> do - (M.CTCCSpec, bs) <- buffered t 1 - resetSequenceNumber t M.Read - return . Left . (\[w] -> w) $ BS.unpack bs - M.CTHandshake -> do - (M.CTHandshake, bs) <- buffered t n - return $ Right bs - M.CTAlert -> do - (M.CTAlert, al) <- buffered t 2 - throw M.ALFatal M.ADUnclasified $ show al - _ -> throwError "not handshake" - -buffered :: (HandleLike h, CPRG g) => - TlsHandleBase h g -> Int -> M.TlsM h g (M.ContentType, BS.ByteString) -buffered t n = do - (ct, b) <- M.getRBuf $ partnerId 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) . throw M.ALFatal M.ADUnclasified $ - "Content Type confliction\n" ++ - "\tExpected: " ++ show ct ++ "\n" ++ - "\tActual : " ++ show ct' ++ "\n" ++ - "\tData : " ++ show b' - when (BS.null b') $ throwError "buffered: No data available" - M.setRBuf (partnerId t) (ct', b') - second (b `BS.append`) `liftM` buffered t rl - -adGet :: (HandleLike h, CPRG g) => (TlsHandleBase h g -> M.TlsM h g ()) -> - TlsHandleBase h g -> Int -> M.TlsM h g BS.ByteString -adGet rn t n = buffered_ rn t n - -buffered_ :: (HandleLike h, CPRG g) => (TlsHandleBase h g -> M.TlsM h g ()) -> - TlsHandleBase h g -> Int -> M.TlsM h g BS.ByteString -buffered_ rn t n = do - ct0 <- getContentType t - case ct0 of - M.CTHandshake -> rn t >> buffered_ rn t n - M.CTAlert -> do - (M.CTAlert, b) <- M.getRBuf $ partnerId t - let rl = 2 - BS.length b - al <- if rl <= 0 - then snd `liftM` splitRetBuf t 2 M.CTAlert b - else do (ct', b') <- getWholeWithCt t - unless (ct' == M.CTAlert) $ throw - M.ALFatal M.ADUnclasified - "Content Type confliction\n" - when (BS.null b') $ throwError "buffered: No data" - M.setRBuf (partnerId t) (ct', b') - (b `BS.append`) `liftM` buffered_ rn t rl - case al of - "\SOH\NULL" -> do - tlsPut t M.CTAlert "\SOH\NULL" - throw M.ALFatal M.ADUnclasified "EOF" - _ -> throw M.ALFatal M.ADUnclasified $ - "Alert: " ++ show al - _ -> do (ct, b) <- M.getRBuf $ partnerId t; let rl = n - BS.length b - if rl <= 0 - then snd `liftM` splitRetBuf t n ct b - else do - (ct', b') <- getWholeWithCt t - unless (ct' == ct) $ throw M.ALFatal M.ADUnclasified - "Content Type confliction\n" - when (BS.null b') $ throwError "buffered: No data" - M.setRBuf (partnerId t) (ct', b') - (b `BS.append`) `liftM` buffered_ rn t rl - -splitRetBuf :: HandleLike h => - TlsHandleBase h g -> Int -> M.ContentType -> BS.ByteString -> - M.TlsM h g (M.ContentType, BS.ByteString) -splitRetBuf t n ct b = do - let (ret, b') = BS.splitAt n b - M.setRBuf (partnerId t) $ if BS.null b' then (M.CTNull, "") else (ct, b') - return (ct, ret) - -getWholeWithCt :: (HandleLike h, CPRG g) => - TlsHandleBase h g -> M.TlsM h g (M.ContentType, BS.ByteString) -getWholeWithCt t = do - flush t - ct <- (either (throw M.ALFatal M.ADUnclasified) return . B.decode) =<< rd 1 - [_vmj, _vmn] <- BS.unpack `liftM` rd 2 - e <- rd =<< either (throw M.ALFatal M.ADUnclasified) return . B.decode =<< rd 2 - when (BS.null e) $ throwError "TlsHandleBase.getWholeWithCt: e is null" - p <- decrypt t ct e - M.tDebug (tlsHandle t) "medium" . BSC.pack . (++ ": ") $ show ct - M.tDebug (tlsHandle t) "medium" . BSC.pack . (++ "\n") . show $ BS.head p - M.tDebug (tlsHandle t) "low" . BSC.pack . (++ "\n") $ show p - return (ct, p) - where rd n = do - r <- M.tGet (tlsHandle t) n - unless (BS.length r == n) . throw M.ALFatal M.ADUnclasified $ - "TlsHandleBase.rd: can't read " ++ show (BS.length r) ++ " " ++ show n - return r - -decrypt :: HandleLike h => - TlsHandleBase h g -> M.ContentType -> BS.ByteString -> M.TlsM h g BS.ByteString -decrypt t ct e = do - ks <- M.getKeys $ partnerId t - decrypt_ t ks ct e - -decrypt_ :: HandleLike h => TlsHandleBase h g -> - M.Keys -> M.ContentType -> BS.ByteString -> M.TlsM h g BS.ByteString -decrypt_ _ M.Keys{ M.kReadCS = M.CipherSuite _ M.BE_NULL } _ e = return e -decrypt_ t ks ct e = do - let M.CipherSuite _ be = M.kReadCS ks - wk = M.kReadKey ks - mk = M.kReadMacKey ks - sn <- updateSequenceNumber t M.Read - hs <- case be of - M.AES_128_CBC_SHA -> return C.hashSha1 - M.AES_128_CBC_SHA256 -> return C.hashSha256 - _ -> throwError "TlsHandleBase.decrypt: not implement bulk encryption" - either (throw M.ALFatal M.ADUnclasified) return $ - C.decrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") e - -tlsPut :: (HandleLike h, CPRG g) => - TlsHandleBase h g -> M.ContentType -> BS.ByteString -> M.TlsM h g () -tlsPut t ct p = do - (bct, bp) <- M.getWBuf $ partnerId t - case ct of - M.CTCCSpec -> flush t >> M.setWBuf (partnerId t) (ct, p) >> flush t - _ | bct /= M.CTNull && ct /= bct -> - flush t >> M.setWBuf (partnerId t) (ct, p) - | otherwise -> M.setWBuf (partnerId t) (ct, bp `BS.append` p) - -flush :: (HandleLike h, CPRG g) => TlsHandleBase h g -> M.TlsM h g () -flush t = do - (bct, bp) <- M.getWBuf $ partnerId t - M.setWBuf (partnerId t) (M.CTNull, "") - unless (bct == M.CTNull) $ do - e <- encrypt t bct bp - M.tPut (tlsHandle t) $ BS.concat [ - B.encode bct, "\x03\x03", B.addLen (undefined :: Word16) e ] - -encrypt :: (HandleLike h, CPRG g) => - TlsHandleBase h g -> M.ContentType -> BS.ByteString -> M.TlsM h g BS.ByteString -encrypt t ct p = do - ks <- M.getKeys $ partnerId t - encrypt_ t ks ct p - -encrypt_ :: (HandleLike h, CPRG g) => TlsHandleBase h g -> - M.Keys -> M.ContentType -> BS.ByteString -> M.TlsM h g BS.ByteString -encrypt_ _ M.Keys{ M.kWriteCS = M.CipherSuite _ M.BE_NULL } _ p = return p -encrypt_ t ks ct p = do - let M.CipherSuite _ be = M.kWriteCS ks - wk = M.kWriteKey ks - mk = M.kWriteMacKey ks - sn <- updateSequenceNumber t M.Write - hs <- case be of - M.AES_128_CBC_SHA -> return C.hashSha1 - M.AES_128_CBC_SHA256 -> return C.hashSha256 - _ -> throwError "TlsHandleBase.encrypt: not implemented bulk encryption" - M.withRandom $ C.encrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") p - -updateSequenceNumber :: HandleLike h => TlsHandleBase h g -> M.RW -> M.TlsM h g Word64 -updateSequenceNumber t rw = do - ks <- M.getKeys $ partnerId t - (sn, cs) <- case rw of - M.Read -> (, M.kReadCS ks) `liftM` M.getRSn (partnerId t) - M.Write -> (, M.kWriteCS ks) `liftM` M.getWSn (partnerId t) - case cs of - M.CipherSuite _ M.BE_NULL -> return () - _ -> case rw of - M.Read -> M.sccRSn $ partnerId t - M.Write -> M.sccWSn $ partnerId t - return sn - -resetSequenceNumber :: HandleLike h => TlsHandleBase h g -> M.RW -> M.TlsM h g () -resetSequenceNumber t rw = case rw of - M.Read -> M.rstRSn $ partnerId t - M.Write -> M.rstWSn $ partnerId t - -makeKeys :: HandleLike h => - TlsHandleBase h g -> C.Side -> BS.ByteString -> BS.ByteString -> - BS.ByteString -> M.CipherSuite -> M.TlsM h g M.Keys -makeKeys t p cr sr pms cs = do - let M.CipherSuite _ be = cs - kl <- case be of - M.AES_128_CBC_SHA -> return 20 - M.AES_128_CBC_SHA256 -> return 32 - _ -> throwError - "TlsServer.makeKeys: not implemented bulk encryption" - let (ms, cwmk, swmk, cwk, swk) = C.makeKeys kl cr sr pms - k <- M.getKeys $ partnerId t - return $ case p of - C.Client -> k { - M.kCachedCS = cs, - M.kMasterSecret = ms, - M.kCachedReadMacKey = swmk, M.kCachedWriteMacKey = cwmk, - M.kCachedReadKey = swk, M.kCachedWriteKey = cwk } - C.Server -> k { - M.kCachedCS = cs, - M.kMasterSecret = ms, - M.kCachedReadMacKey = cwmk, M.kCachedWriteMacKey = swmk, - M.kCachedReadKey = cwk, M.kCachedWriteKey = swk } - -flushCipherSuite :: HandleLike h => M.RW -> TlsHandleBase h g -> M.TlsM h g () -flushCipherSuite rw = M.flushCipherSuite rw . partnerId - -debugCipherSuite :: HandleLike h => TlsHandleBase h g -> String -> M.TlsM h g () -debugCipherSuite t a = do - k <- M.getKeys $ partnerId t - M.tDebug (tlsHandle t) "high" . BSC.pack - . (++ (" - VERIFY WITH " ++ a ++ "\n")) . lenSpace 50 - . show $ M.kCachedCS k - where lenSpace n str = str ++ replicate (n - length str) ' ' - -finishedHash :: HandleLike h => - C.Side -> TlsHandleBase h g -> BS.ByteString -> M.TlsM h g BS.ByteString -finishedHash s t hs = do - ms <- M.kMasterSecret `liftM` M.getKeys (partnerId t) - return $ C.finishedHash s ms hs - -adPut, hlPut_ :: (HandleLike h, CPRG g) => TlsHandleBase h g -> BS.ByteString -> M.TlsM h g () -adPut = hlPut_ -hlPut_ = ((>> return ()) .) . flip tlsPut M.CTAppData - -adDebug, hlDebug_ :: HandleLike h => - TlsHandleBase h g -> DebugLevel h -> BS.ByteString -> M.TlsM h g () -adDebug = hlDebug_ -hlDebug_ = M.tDebug . tlsHandle - -adClose, hlClose_ :: (HandleLike h, CPRG g) => TlsHandleBase h g -> M.TlsM h g () -adClose = hlClose_ -hlClose_ t = tlsPut t M.CTAlert "\SOH\NUL" >> flush t >> M.tClose (tlsHandle t) - -adGetLine, tGetLine_ :: (HandleLike h, CPRG g) => (TlsHandleBase h g -> M.TlsM h g ()) -> - TlsHandleBase h g -> M.TlsM h g BS.ByteString -adGetLine = tGetLine_ -tGetLine_ rn t = do - ct <- getContentType t - case ct of - M.CTHandshake -> rn t >> tGetLine_ rn t - M.CTAlert -> do - (M.CTAlert, b) <- M.getRBuf $ partnerId t - let rl = 2 - BS.length b - al <- if rl <= 0 - then snd `liftM` splitRetBuf t 2 M.CTAlert b - else do (ct', b') <- getWholeWithCt t - unless (ct' == M.CTAlert) . throw M.ALFatal M.ADUnclasified $ - "Content Type confliction\n" - when (BS.null b') $ throwError "buffered: No data" - M.setRBuf (partnerId t) (ct', b') - (b `BS.append`) `liftM` buffered_ rn t rl - case al of - "\SOH\NULL" -> do - tlsPut t M.CTAlert "\SOH\NULL" - throw M.ALFatal M.ADUnclasified "EOF" - _ -> throw M.ALFatal M.ADUnclasified $ - "Alert: " ++ show al - _ -> do (bct, bp) <- M.getRBuf $ partnerId t - case splitLine bp of - Just (l, ls) -> do - M.setRBuf (partnerId t) (if BS.null ls then M.CTNull else bct, ls) - return l - _ -> do cp <- getWholeWithCt t - M.setRBuf (partnerId t) cp - (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) => - TlsHandleBase h g -> M.TlsM h g (M.ContentType, BS.ByteString) -tGetContent t = do - bcp@(_, bp) <- M.getRBuf $ partnerId t - if BS.null bp then getWholeWithCt t else - M.setRBuf (partnerId t) (M.CTNull, BS.empty) >> return bcp - -getClFinished, getSvFinished :: - HandleLike h => TlsHandleBase h g -> M.TlsM h g BS.ByteString -getClFinished = M.getClFinished . partnerId -getSvFinished = M.getSvFinished . partnerId - -setClFinished, setSvFinished :: - HandleLike h => TlsHandleBase h g -> BS.ByteString -> M.TlsM h g () -setClFinished = M.setClFinished . partnerId -setSvFinished = M.setSvFinished . partnerId - -getSettingsS :: HandleLike h => TlsHandleBase h g -> M.TlsM h g M.SettingsS -getSettingsS = M.getSettingsS . partnerId - -setSettingsS :: HandleLike h => TlsHandleBase h g -> M.SettingsS -> M.TlsM h g () -setSettingsS = M.setSettingsS . partnerId - -getBuf :: HandleLike h => TlsHandleBase h g -> M.TlsM h g BS.ByteString -getBuf = M.getAdBuf . partnerId - -setBuf :: HandleLike h => TlsHandleBase h g -> BS.ByteString -> M.TlsM h g () -setBuf = M.setAdBuf . partnerId - -adGetContent, tGetContent_ :: (HandleLike h, CPRG g) => - (TlsHandleBase h g -> M.TlsM h g ()) -> - TlsHandleBase h g -> M.TlsM h g BS.ByteString -adGetContent = tGetContent_ -tGetContent_ rn t = do - ct <- getContentType t - case ct of - M.CTHandshake -> rn t >> tGetContent_ rn t - M.CTAlert -> do - (M.CTAlert, al) <- buffered t 2 - case al of - "\SOH\NULL" -> do - tlsPut t M.CTAlert "\SOH\NUL" - throw M.ALFatal M.ADUnclasified $ - ".checkAppData: EOF" - _ -> throw M.ALFatal M.ADUnclasified $ - "Alert: " ++ show al - _ -> snd `liftM` tGetContent t - -hsPut :: (HandleLike h, CPRG g) => TlsHandleBase h g -> BS.ByteString -> M.TlsM h g () -hsPut = flip tlsPut M.CTHandshake - -ccsPut :: (HandleLike h, CPRG g) => TlsHandleBase h g -> Word8 -> M.TlsM h g () -ccsPut t w = do - ret <- tlsPut t M.CTCCSpec $ BS.pack [w] - resetSequenceNumber t M.Write - return ret - -getSettingsC :: HandleLike h => TlsHandleBase h g -> M.TlsM h g M.SettingsC -getSettingsC = M.getSettingsC . partnerId - -setSettingsC :: HandleLike h => TlsHandleBase h g -> - M.SettingsC -> M.TlsM h g () -setSettingsC = M.setSettingsC . partnerId - -getCipherSuite :: HandleLike h => TlsHandleBase h g -> M.TlsM h g M.CipherSuite -getCipherSuite = M.getCipherSuite . partnerId - -setCipherSuite :: HandleLike h => TlsHandleBase h g -> M.CipherSuite -> M.TlsM h g () -setCipherSuite = M.setCipherSuite . partnerId - -getNames :: HandleLike h => TlsHandleBase h g -> M.TlsM h g [String] -getNames = M.getNames . partnerId - -setNames :: HandleLike h => TlsHandleBase h g -> [String] -> M.TlsM h g () -setNames = M.setNames . partnerId - -setKeys :: HandleLike h => TlsHandleBase h g -> M.Keys -> M.TlsM h g () -setKeys = M.setKeys . partnerId - -throw :: HandleLike h => M.AlertLevel -> M.AlertDesc -> String -> M.TlsM h g a -throw = ((throwError .) .) . M.Alert - -debug :: (HandleLike h, Show a) => - TlsHandleBase h g -> DebugLevel h -> a -> M.TlsM h g () -debug t l x = lift . lift . hlDebug (tlsHandle t) l . - BSC.pack . (++ "\n") $ show x diff --git a/src/Network/PeyoTLS/Hello.hs b/src/Network/PeyoTLS/Hello.hs deleted file mode 100644 --- a/src/Network/PeyoTLS/Hello.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Network.PeyoTLS.Hello ( Extension(..), - ClientHello(..), ServerHello(..), SessionId(..), - CipherSuite(..), KeyEx(..), BulkEnc(..), - CompMethod(..), - SignAlg(..), HashAlg(..) ) where - -import Control.Applicative ((<$>), (<*>)) -import Data.Word (Word8, Word16) -import Numeric (showHex) - -import qualified Data.ByteString as BS -import qualified Codec.Bytable.BigEndian as B - -import Network.PeyoTLS.Extension (Extension(..), SignAlg(..), HashAlg(..)) -import Network.PeyoTLS.CipherSuite ( - CipherSuite(..), KeyEx(..), BulkEnc(..)) - -data ClientHello - = ClientHello (Word8, Word8) BS.ByteString SessionId - [CipherSuite] [CompMethod] (Maybe [Extension]) - | ClientHelloRaw BS.ByteString - deriving Show - -instance B.Bytable ClientHello where - decode = B.evalBytableM $ do - (pv, r, sid) <- (,,) <$> ((,) <$> B.head <*> B.head) - <*> B.take 32 <*> (B.take =<< B.take 1) - cs <- flip B.list (B.take 2) =<< B.take 2 - cm <- flip B.list (B.take 1) =<< B.take 1 - nl <- B.null - me <- if nl then return Nothing else - Just <$> (flip B.list B.parse =<< B.take 2) - return $ ClientHello pv r sid cs cm me - encode = encodeCh - -encodeCh :: ClientHello -> BS.ByteString -encodeCh (ClientHello (vmjr, vmnr) r sid css cms mel) = BS.concat [ - B.encode vmjr, B.encode vmnr, B.encode r, - B.addLen (undefined :: Word8) $ B.encode sid, - B.addLen (undefined :: Word16) . BS.concat $ map B.encode css, - B.addLen (undefined :: Word8) . BS.concat $ map B.encode cms, - maybe "" (B.addLen (undefined :: Word16) . BS.concat . map B.encode) mel ] -encodeCh (ClientHelloRaw bs) = bs - -data ServerHello - = ServerHello (Word8, Word8) BS.ByteString SessionId - CipherSuite CompMethod (Maybe [Extension]) - | ServerHelloRaw BS.ByteString - deriving Show - -instance B.Bytable ServerHello where - decode = B.evalBytableM $ do - (pv, r, sid) <- (,,) <$> ((,) <$> B.head <*> B.head) - <*> B.take 32 <*> (B.take =<< B.take 1) - cs <- B.take 2 - cm <- B.take 1 - e <- B.null - me <- if e then return Nothing else do - mel <- B.take 2 - Just <$> B.list mel B.parse - return $ ServerHello pv r sid cs cm me - encode = encodeSh - -encodeSh :: ServerHello -> BS.ByteString -encodeSh (ServerHello (vmjr, vmnr) r sid cs cm mes) = BS.concat [ - B.encode vmjr, B.encode vmnr, B.encode r, - B.addLen (undefined :: Word8) $ B.encode sid, - B.encode cs, B.encode cm, - maybe "" (B.addLen (undefined :: Word16) . BS.concat . map B.encode) mes ] -encodeSh (ServerHelloRaw sh) = sh - -data CompMethod = CompMethodNull | CompMethodRaw Word8 - deriving (Show, Eq) - -instance B.Bytable CompMethod where - decode bs = case BS.unpack bs of - [cm] -> Right $ case cm of - 0 -> CompMethodNull - _ -> CompMethodRaw cm - _ -> Left "Hello.decodeCm" - encode CompMethodNull = "\0" - encode (CompMethodRaw cm) = BS.pack [cm] - -data SessionId = SessionId BS.ByteString - -instance Show SessionId where - show (SessionId sid) = "(SessionID " ++ - concatMap (`showHex` "") (BS.unpack sid) ++ ")" - -instance B.Bytable SessionId where - decode = Right . SessionId - encode (SessionId bs) = bs diff --git a/src/Network/PeyoTLS/Monad.hs b/src/Network/PeyoTLS/Monad.hs deleted file mode 100644 --- a/src/Network/PeyoTLS/Monad.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# LANGUAGE OverloadedStrings, PackageImports #-} - -module Network.PeyoTLS.Monad ( - TlsM, evalTlsM, S.initState, - tGet, tPut, tClose, tDebug, thlError, - withRandom, - getRBuf, setRBuf, getWBuf, setWBuf, - getAdBuf, setAdBuf, - getRSn, getWSn, sccRSn, sccWSn, rstRSn, rstWSn, - getCipherSuite, setCipherSuite, - getNames, setNames, - setKeys, getKeys, - S.SettingsS, getSettingsS, setSettingsS, - S.Alert(..), S.AlertLevel(..), S.AlertDesc(..), - S.ContentType(..), - S.CipherSuite(..), S.KeyEx(..), S.BulkEnc(..), - S.PartnerId, S.newPartnerId, S.Keys(..), S.nullKeys, - - getClFinished, setClFinished, - getSvFinished, setSvFinished, - S.CertSecretKey(..), S.isRsaKey, S.isEcdsaKey, - - SettingsC, getSettingsC, setSettingsC, - RW(..), - flushCipherSuite, - ) where - -import Control.Arrow ((***)) -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, throwError) -import Data.Word (Word64) -import Data.HandleLike (HandleLike(..)) - -import qualified Data.ByteString as BS -import qualified Data.X509 as X509 -import qualified Data.X509.CertificateStore as X509 - -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, - setNames, getNames, - setKeys, getKeys, - getSettings, setSettings, - getInitSet, setInitSet, - getClientFinished, setClientFinished, - getServerFinished, setServerFinished, - - flushCipherSuiteRead, flushCipherSuiteWrite, - - SettingsS, Settings, - CertSecretKey(..), isRsaKey, isEcdsaKey, - ) - -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 - -getRBuf, getWBuf :: HandleLike h => - S.PartnerId -> TlsM h g (S.ContentType, BS.ByteString) -getRBuf = 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 - -setRBuf, setWBuf :: HandleLike h => - S.PartnerId -> (S.ContentType, BS.ByteString) -> TlsM h g () -setRBuf = (modify .) . S.setBuf; setWBuf = (modify .) . S.setWBuf - -getWSn, getRSn :: HandleLike h => S.PartnerId -> TlsM h g Word64 -getWSn = gets . S.getWriteSN; getRSn = gets . S.getReadSN - -sccWSn, sccRSn :: HandleLike h => S.PartnerId -> TlsM h g () -sccWSn = modify . S.succWriteSN; sccRSn = modify . S.succReadSN - -rstWSn, rstRSn :: HandleLike h => S.PartnerId -> TlsM h g () -rstWSn = modify . S.resetWriteSN; rstRSn = modify . S.resetReadSN - -getCipherSuite :: HandleLike h => S.PartnerId -> TlsM h g S.CipherSuite -getCipherSuite = gets . S.getCipherSuite - -setCipherSuite :: HandleLike h => S.PartnerId -> S.CipherSuite -> TlsM h g () -setCipherSuite = (modify .) . S.setCipherSuite - -getNames :: HandleLike h => S.PartnerId -> TlsM h g [String] -getNames = gets . S.getNames - -setNames :: HandleLike h => S.PartnerId -> [String] -> TlsM h g () -setNames = (modify .) . S.setNames - -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 - -getSettingsS :: HandleLike h => S.PartnerId -> TlsM h g S.SettingsS -getSettingsS = gets . S.getInitSet - -getSettings :: HandleLike h => S.PartnerId -> TlsM h g S.Settings -getSettings = gets . S.getSettings - -setSettingsS :: HandleLike h => S.PartnerId -> S.SettingsS -> TlsM h g () -setSettingsS = (modify .) . S.setInitSet - -setSettings :: HandleLike h => S.PartnerId -> S.Settings -> TlsM h g () -setSettings = (modify .) . S.setSettings - -getClFinished, getSvFinished :: - HandleLike h => S.PartnerId -> TlsM h g BS.ByteString -getClFinished = gets . S.getClientFinished -getSvFinished = gets . S.getServerFinished - -setClFinished, setSvFinished :: - HandleLike h => S.PartnerId -> BS.ByteString -> TlsM h g () -setClFinished = (modify .) . S.setClientFinished -setSvFinished = (modify .) . S.setServerFinished - -flushCipherSuite :: HandleLike h => RW -> S.PartnerId -> TlsM h g () -flushCipherSuite rw = case rw of - Read -> flushCipherSuiteRead - Write -> flushCipherSuiteWrite - -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 = p `liftM` gets S.randomGen >>= - uncurry (flip (>>)) . (return *** modify . S.setRandomGen) - -tGet :: HandleLike h => h -> Int -> TlsM h g BS.ByteString -tGet = ((lift . lift) .) . hlGet - -tPut :: HandleLike h => h -> BS.ByteString -> TlsM h g () -tPut = ((lift . lift) .) . hlPut - -tClose :: HandleLike h => h -> TlsM h g () -tClose = lift . lift . hlClose - -tDebug :: HandleLike h => - h -> DebugLevel h -> BS.ByteString -> TlsM h gen () -tDebug = (((lift . lift) .) .) . hlDebug - -thlError :: HandleLike h => h -> BS.ByteString -> TlsM h g a -thlError = ((lift . lift) .) . hlError - -getSettingsC :: HandleLike h => S.PartnerId -> TlsM h g SettingsC -getSettingsC i = do - (css, crts, mcs) <- getSettings i - case mcs of - Just cs -> return (css, crts, cs) - _ -> throwError "Network.PeyoTLS.Base.getSettingsC" - -setSettingsC :: HandleLike h => S.PartnerId -> SettingsC -> TlsM h g () -setSettingsC i (css, crts, cs) = setSettings i (css, crts, Just cs) - -type SettingsC = ( - [S.CipherSuite], - [(S.CertSecretKey, X509.CertificateChain)], - X509.CertificateStore ) - -data RW = Read | Write deriving Show diff --git a/src/Network/PeyoTLS/Run.hs b/src/Network/PeyoTLS/Run.hs --- a/src/Network/PeyoTLS/Run.hs +++ b/src/Network/PeyoTLS/Run.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, PackageImports #-} module Network.PeyoTLS.Run ( H.debug, - H.TlsM, H.run, H.TlsHandleBase(..), + H.TlsM, H.run, H.HandleBase, adGet, adGetLine, adGetContent, H.adPut, H.adDebug, H.adClose, HandshakeM, execHandshakeM, rerunHandshakeM, withRandom, chGet, ccsPut, hsPut, updateHash, flushAd, @@ -17,18 +17,16 @@ H.AlertLevel(..), H.AlertDesc(..), debugCipherSuite, throw ) where import Control.Applicative ((<$>), (<*>)) -import Control.Arrow (first, second, (***)) +import Control.Arrow ((***)) import Control.Monad (liftM) -import "monads-tf" Control.Monad.Trans (lift) -import "monads-tf" Control.Monad.State ( - StateT, evalStateT, execStateT, get, gets, modify ) +import "monads-tf" Control.Monad.Reader (ReaderT, runReaderT, lift, ask) +import "monads-tf" Control.Monad.State (StateT, evalStateT, get, modify ) import "monads-tf" Control.Monad.Error (throwError) import Data.Word (Word8) 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 Data.ASN1.Types as ASN1 import qualified Data.X509 as X509 import qualified Data.X509.Validation as X509 @@ -36,9 +34,9 @@ import qualified Codec.Bytable.BigEndian as B import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Network.PeyoTLS.Handle as H ( debug, +import qualified Network.PeyoTLS.Run.Handle as H ( debug, TlsM, run, withRandom, - TlsHandleBase(..), CipherSuite, + HandleBase, CipherSuite, newHandle, chGet, ccsPut, hsPut, adGet, adGetLine, adGetContent, adPut, adDebug, adClose, flushAd, getBuf, setBuf, @@ -52,52 +50,51 @@ RW(..), flushCipherSuite, ValidateHandle(..), tValidate, CertSecretKey(..), isRsaKey, isEcdsaKey, - Alert(..), AlertLevel(..), AlertDesc(..), debugCipherSuite ) + Alert(..), AlertLevel(..), AlertDesc(..), debugCipherSuite, + splitLine ) modNm :: String modNm = "Network.PeyoTLS.Run" -type RenegoProc h g = H.TlsHandleBase h g -> H.TlsM h g () +type RenegoProc h g = H.HandleBase h g -> H.TlsM h g () adGet :: (HandleLike h, CPRG g) => - RenegoProc h g -> H.TlsHandleBase h g -> Int -> H.TlsM h g BS.ByteString + RenegoProc h g -> H.HandleBase h g -> Int -> H.TlsM h g BS.ByteString adGet rp t n = H.getBuf t >>= \b -> if BS.length b >= n then uncurry (>>) . (H.setBuf t *** return) $ BS.splitAt n b else BS.append b `liftM` H.adGet rp t (n - BS.length b) adGetLine :: (HandleLike h, CPRG g) => - RenegoProc h g -> H.TlsHandleBase h g -> H.TlsM h g BS.ByteString -adGetLine rp t = H.getBuf t >>= \b -> if '\n' `BSC.elem` b || '\r' `BSC.elem` b - then uncurry (>>) . (H.setBuf t *** return) $ case BSC.span (/= '\r') b of - (_, "") -> second BS.tail $ BSC.span (/= '\n') b - (l, ls) -> case BSC.uncons ls of - Just ('\r', ls') -> case BSC.uncons ls' of - Just ('\n', ls'') -> (l, ls'') - _ -> (l, ls') - _ -> (l, ls) - else (b `BS.append`) `liftM` H.adGetLine rp t + RenegoProc h g -> H.HandleBase h g -> H.TlsM h g BS.ByteString +adGetLine rp t = H.getBuf t >>= \b -> case H.splitLine b of + Just (l, ls) -> H.setBuf t ls >> return l + _ -> (b `BS.append`) `liftM` H.adGetLine rp t adGetContent :: (HandleLike h, CPRG g) => - RenegoProc h g -> H.TlsHandleBase h g -> H.TlsM h g BS.ByteString + RenegoProc h g -> H.HandleBase h g -> H.TlsM h g BS.ByteString adGetContent rp t = H.getBuf t >>= \b -> if BS.null b then H.adGetContent rp t else H.setBuf t "" >> return b -type HandshakeM h g = StateT (H.TlsHandleBase h g, SHA256.Ctx) (H.TlsM h g) +type HandshakeM h g = + ReaderT (H.HandleBase h g) (StateT SHA256.Ctx (H.TlsM h g)) execHandshakeM :: - HandleLike h => h -> HandshakeM h g () -> H.TlsM h g (H.TlsHandleBase h g) -execHandshakeM h = - liftM fst . ((, SHA256.init) `liftM` H.newHandle h >>=) . execStateT + HandleLike h => h -> HandshakeM h g () -> H.TlsM h g (H.HandleBase h g) +execHandshakeM h m = do + t <- H.newHandle h + m `runReaderT` t `evalStateT` SHA256.init + return t +-- liftM fst . ((, SHA256.init) `liftM` H.newHandle h >>=) . execStateT rerunHandshakeM :: - HandleLike h => H.TlsHandleBase h g -> HandshakeM h g a -> H.TlsM h g a -rerunHandshakeM = flip evalStateT . (, SHA256.init) + HandleLike h => H.HandleBase h g -> HandshakeM h g a -> H.TlsM h g a +rerunHandshakeM t m = m `runReaderT` t `evalStateT` SHA256.init withRandom :: HandleLike h => (g -> (a, g)) -> HandshakeM h g a -withRandom = lift . H.withRandom +withRandom = lift . lift . H.withRandom chGet :: (HandleLike h, CPRG g) => HandshakeM h g (Either Word8 BS.ByteString) -chGet = gets fst >>= lift . flip H.chGet 1 >>= \ch -> case ch of +chGet = ask >>= lift . lift . flip H.chGet 1 >>= \ch -> case ch of Left w -> return $ Left w Right t -> Right `liftM` do len <- hsGet 3 @@ -105,77 +102,79 @@ return $ BS.concat [t, len, body] hsGet :: (HandleLike h, CPRG g) => Int -> HandshakeM h g BS.ByteString -hsGet n = gets fst >>= lift . flip H.chGet n >>= \ch -> case ch of +hsGet n = ask >>= lift . lift . flip H.chGet n >>= \ch -> case ch of Right bs -> return bs - _ -> throw H.ALFatal H.ADUnexMsg $ modNm ++ ".hsGet: not handshake" + _ -> throw H.ALFtl H.ADUnexMsg $ modNm ++ ".hsGet: not handshake" ccsPut :: (HandleLike h, CPRG g) => Word8 -> HandshakeM h g () -ccsPut = (gets fst >>=) . (lift .) . flip H.ccsPut +ccsPut = (ask >>=) . ((lift . lift) .) . flip H.ccsPut hsPut :: (HandleLike h, CPRG g) => BS.ByteString -> HandshakeM h g () -hsPut = (gets fst >>=) . (lift .) . flip H.hsPut +hsPut = (ask >>=) . ((lift . lift) .) . flip H.hsPut updateHash :: HandleLike h => BS.ByteString -> HandshakeM h g () -updateHash = modify . second . flip SHA256.update +updateHash = modify . flip SHA256.update flushAd :: (HandleLike h, CPRG g) => HandshakeM h g Bool -flushAd = gets fst >>= lift . H.flushAd >>= uncurry (>>) . (push *** return) - where push bs = gets fst >>= lift . H.getBuf >>= - (gets fst >>=) . (lift .) . flip H.setBuf . (`BS.append` bs) +flushAd = ask >>= lift . lift . H.flushAd >>= uncurry (>>) . (push *** return) + where push bs = ask >>= lift . lift . H.getBuf >>= + (ask >>=) . ((lift . lift) .) . flip H.setBuf . (`BS.append` bs) getSettingsC :: HandleLike h => HandshakeM h g H.SettingsC -getSettingsC = gets fst >>= lift . H.getSettingsC +getSettingsC = ask >>= lift . lift . H.getSettingsC setSettingsC :: HandleLike h => H.SettingsC -> HandshakeM h g () -setSettingsC = (gets fst >>=) . (lift .) . flip H.setSettingsC +setSettingsC = (ask >>=) . ((lift . lift) .) . flip H.setSettingsC getSettingsS :: HandleLike h => HandshakeM h g H.SettingsS -getSettingsS = gets fst >>= lift . H.getSettingsS +getSettingsS = ask >>= lift . lift . H.getSettingsS setSettingsS :: HandleLike h => H.SettingsS -> HandshakeM h g () -setSettingsS = (gets fst >>=) . (lift .) . flip H.setSettingsS +setSettingsS = (ask >>=) . ((lift . lift) .) . flip H.setSettingsS getCipherSuite :: HandleLike h => HandshakeM h g H.CipherSuite -getCipherSuite = gets fst >>= lift . H.getCipherSuite +getCipherSuite = ask >>= lift . lift . H.getCipherSuite setCipherSuite :: HandleLike h => H.CipherSuite -> HandshakeM h g () -setCipherSuite = (gets fst >>=) . (lift .) . flip H.setCipherSuite +setCipherSuite = (ask >>=) . ((lift . lift) .) . flip H.setCipherSuite getClFinished, getSvFinished :: HandleLike h => HandshakeM h g BS.ByteString -getClFinished = gets fst >>= lift . H.getClFinished -getSvFinished = gets fst >>= lift . H.getSvFinished +getClFinished = ask >>= lift . lift . H.getClFinished +getSvFinished = ask >>= lift . lift . H.getSvFinished setClFinished, setSvFinished :: HandleLike h => BS.ByteString -> HandshakeM h g () -setClFinished = (gets fst >>=) . (lift .) . flip H.setClFinished -setSvFinished = (gets fst >>=) . (lift .) . flip H.setSvFinished +setClFinished = (ask >>=) . ((lift . lift) .) . flip H.setClFinished +setSvFinished = (ask >>=) . ((lift . lift) .) . flip H.setSvFinished flushCipherSuite :: (HandleLike h, CPRG g) => H.RW -> HandshakeM h g () -flushCipherSuite = (gets fst >>=) . (lift .) . H.flushCipherSuite +flushCipherSuite = (ask >>=) . ((lift . lift) .) . H.flushCipherSuite makeKeys :: HandleLike h => H.Side -> (BS.ByteString, BS.ByteString) -> BS.ByteString -> HandshakeM h g () -makeKeys s (cr, sr) pms = gets fst >>= \t -> lift $ +makeKeys s (cr, sr) pms = ask >>= \t -> lift . lift $ H.getCipherSuite t >>= H.makeKeys t s cr sr pms >>= H.setKeys t handshakeHash :: HandleLike h => HandshakeM h g BS.ByteString -handshakeHash = SHA256.finalize `liftM` gets snd +handshakeHash = SHA256.finalize `liftM` get finishedHash :: (HandleLike h, CPRG g) => H.Side -> HandshakeM h g BS.ByteString -finishedHash s = get >>= lift . uncurry (H.finishedHash s) . second SHA256.finalize +finishedHash s = do + t <- ask + h <- get + lift . lift $ H.finishedHash s t (SHA256.finalize h) validateAlert :: [X509.FailedReason] -> H.AlertDesc validateAlert vr - | X509.UnknownCA `elem` vr = H.ADUnknownCa - | X509.Expired `elem` vr = H.ADCertificateExpired - | X509.InFuture `elem` vr = H.ADCertificateExpired - | otherwise = H.ADCertificateUnknown + | X509.UnknownCA `elem` vr = H.ADUnkCa + | X509.Expired `elem` vr = H.ADCertEx + | X509.InFuture `elem` vr = H.ADCertEx + | otherwise = H.ADCertUnk handshakeValidate :: H.ValidateHandle h => X509.CertificateStore -> X509.CertificateChain -> HandshakeM h g [X509.FailedReason] -handshakeValidate cs cc@(X509.CertificateChain (c : _)) = gets fst >>= \t -> do - lift . H.setNames t . certNames $ X509.getCertificate c - modify . first $ const t { H.names = certNames $ X509.getCertificate c } - lift $ H.tValidate t cs cc +handshakeValidate cs cc@(X509.CertificateChain (c : _)) = ask >>= \t -> do + lift . lift . H.setNames t . certNames $ X509.getCertificate c + lift . lift $ H.tValidate t cs cc handshakeValidate _ _ = error $ modNm ++ ".handshakeValidate: empty cert chain" certNames :: X509.Certificate -> [String] @@ -188,7 +187,7 @@ . X509.extensionGet . X509.certExtensions debugCipherSuite :: HandleLike h => String -> HandshakeM h g () -debugCipherSuite = (gets fst >>=) . (lift .) . flip H.debugCipherSuite +debugCipherSuite = (ask >>=) . ((lift . lift) .) . flip H.debugCipherSuite throw :: HandleLike h => H.AlertLevel -> H.AlertDesc -> String -> HandshakeM h g a throw = ((throwError .) .) . H.Alert diff --git a/src/Network/PeyoTLS/Run/Crypto.hs b/src/Network/PeyoTLS/Run/Crypto.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Run/Crypto.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports #-} + +module Network.PeyoTLS.Run.Crypto ( + makeKeys, decrypt, encrypt, sha1, sha256, + Side(..), finishedHash ) where + +import Prelude hiding (splitAt, take) + +import Control.Arrow (first) +import Data.Bits (xor) +import Data.Word (Word16, Word64) +import "crypto-random" Crypto.Random (CPRG, cprgGenerate) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Codec.Bytable.BigEndian as B +import qualified Crypto.Hash.SHA1 as SHA1 +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Crypto.Cipher.AES as AES + +modNm :: String +modNm = "Network.PeyoTLS.Crypto" + +type Hash = BS.ByteString -> BS.ByteString + +sha1, sha256 :: (Hash, Int) +sha1 = (SHA1.hash, 20) +sha256 = (SHA256.hash, 32) + +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] = sep kls ems in (ms, cwmk, swmk, cwk, swk) + where + sep [] _ = [] + sep (n : ns) bs + | BSL.null bs = [] + | otherwise = let (x, bs') = splitAt n bs in x : sep 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 + +decrypt :: (Hash, Int) -> BS.ByteString -> BS.ByteString -> Word64 -> + BS.ByteString -> BS.ByteString -> Either String BS.ByteString +decrypt (hs, ml) k mk sn pre enc = + if rm == em then Right b else Left $ modNm ++ ".decrypt: bad MAC\n" + where + pln = uncurry (AES.decryptCBC $ AES.initAES k) $ BS.splitAt 16 enc + up = BS.take (BS.length pln - fromIntegral (lst pln) - 1) pln + (b, rm) = BS.splitAt (BS.length up - ml) up + em = calcMac hs mk sn $ pre `BS.append` B.addLen w16 b + lst "" = error $ modNm ++ ".decrypt" + lst bs = BS.last bs + +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 + +calcMac :: Hash -> BS.ByteString -> Word64 -> BS.ByteString -> BS.ByteString +calcMac hs mk sn m = hmac hs 64 mk $ B.encode sn `BS.append` m + +data Side = Server | Client deriving (Show, Eq) + +finishedHash :: Side -> BS.ByteString -> BS.ByteString -> BS.ByteString +finishedHash s hs ms = take 12 . prf ms . (`BS.append` hs) $ case s of + Client -> "client finished" + Server -> "server finished" + +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/Run/Handle.hs b/src/Network/PeyoTLS/Run/Handle.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Run/Handle.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports #-} + +module Network.PeyoTLS.Run.Handle ( debug, + M.TlsM, M.run, M.withRandom, + HandleBase, M.CipherSuite, + newHandle, chGet, ccsPut, hsPut, + adGet, adGetLine, splitLine, adGetContent, adPut, adDebug, adClose, + flushAd, getBuf, setBuf, + getCipherSuite, setCipherSuite, + M.SettingsC, getSettingsC, setSettingsC, + M.SettingsS, getSettingsS, setSettingsS, + getClFinished, getSvFinished, setClFinished, setSvFinished, + getNames, setNames, makeKeys, setKeys, + M.Side(..), finishedHash, + M.RW(..), flushCipherSuite, + ValidateHandle(..), tValidate, + M.CertSecretKey(..), M.isRsaKey, M.isEcdsaKey, + M.Alert(..), M.AlertLevel(..), M.AlertDesc(..), debugCipherSuite ) where + +import Control.Arrow (first, second) +import Control.Monad (when, unless, liftM, ap) +import "monads-tf" Control.Monad.State (lift, get, put) +import Data.Word (Word8, Word16) +import Data.HandleLike (HandleLike(..)) +import System.IO (Handle) +import "crypto-random" Crypto.Random (CPRG) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.X509 as X509 +import qualified Data.X509.Validation as X509 +import qualified Data.X509.CertificateStore as X509 +import qualified Codec.Bytable.BigEndian as B + +import qualified Network.PeyoTLS.Run.Monad as M ( + TlsM, run, throw, withRandom, + Alert(..), AlertLevel(..), AlertDesc(..), + tGet, decrypt, tPut, encrypt, tClose, tDebug, + PartnerId, newPartner, ContType(..), + getRBuf, getWBuf, getAdBuf, setRBuf, setWBuf, setAdBuf, rstSn, + getClFinished, getSvFinished, setClFinished, setSvFinished, + getNames, setNames, + CipherSuite(..), CertSecretKey(..), isRsaKey, isEcdsaKey, + SettingsC, getSettingsC, setSettingsC, + SettingsS, getSettingsS, setSettingsS, + RW(..), getCipherSuite, setCipherSuite, flushCipherSuite, + Keys(..), makeKeys, getKeys, setKeys, + Side(..), finishedHash ) + +modNm :: String +modNm = "Network.PeyoTLS.Handle" + +vrsn :: BS.ByteString +vrsn = "\x03\x03" + +data HandleBase h g = Handle { pid :: M.PartnerId, handle :: h } deriving Show + +newHandle :: HandleLike h => h -> M.TlsM h g (HandleBase h g) +newHandle h = M.newPartner `liftM` get >>= \(i, s) -> + put s >> return Handle { pid = i, handle = h } + +chGet :: (HandleLike h, CPRG g) => + HandleBase h g -> Int -> M.TlsM h g (Either Word8 BS.ByteString) +chGet _ 0 = return $ Right "" +chGet h n = getType h >>= \ct -> case ct of + M.CTCCSpec -> (Left . head . BS.unpack) `liftM` + (const `liftM` tRead h 1 `ap` M.rstSn M.Read (pid h)) + M.CTHandshake -> Right `liftM` tRead h n + M.CTAlert -> M.throw M.ALFtl M.ADUnk + . ((modNm ++ ".chGet: ") ++) . show =<< tRead h 2 + _ -> M.throw M.ALFtl M.ADUnk $ modNm ++ ".chGet: not handshake" + +tRead :: (HandleLike h, CPRG g) => HandleBase h g -> Int -> M.TlsM h g BS.ByteString +tRead h n = do + (ct, b) <- M.getRBuf $ pid h; let n' = n - BS.length b + if n' <= 0 + then cut h n ct b + else do (ct', b') <- getCont h + unless (ct' == ct) . M.throw M.ALFtl M.ADUnk $ + modNm ++ ".tRead: content type confliction\n" + when (BS.null b') $ M.throw M.ALFtl M.ADUnk $ + modNm ++ ".tRead: no data available\n" + M.setRBuf (pid h) (ct', b') + (b `BS.append`) `liftM` tRead h n' + +cut :: HandleLike h => HandleBase h g -> + Int -> M.ContType -> BS.ByteString -> M.TlsM h g BS.ByteString +cut h n ct b = (const r `liftM`) . M.setRBuf (pid h) $ + (if BS.null b' then M.CTNull else ct, b') + where (r, b') = BS.splitAt n b + +ccsPut :: (HandleLike h, CPRG g) => HandleBase h g -> Word8 -> M.TlsM h g () +ccsPut t w = + const `liftM` tWrite t M.CTCCSpec (BS.pack [w]) `ap` M.rstSn M.Write (pid t) + +hsPut :: (HandleLike h, CPRG g) => HandleBase h g -> BS.ByteString -> M.TlsM h g () +hsPut = flip tWrite M.CTHandshake + +adGet :: (HandleLike h, CPRG g) => (HandleBase h g -> M.TlsM h g ()) -> + HandleBase h g -> Int -> M.TlsM h g BS.ByteString +adGet rp h n = getType h >>= \ct -> case ct of + M.CTAppData -> tRead h n + M.CTHandshake -> rp h >> adGet rp h n + M.CTAlert -> tRead h 2 >>= \al -> case al of + "\SOH\NUL" -> tWrite h M.CTAlert "\SOH\NUL" >> + M.throw M.ALFtl M.ADUnk "EOF" + _ -> M.throw M.ALFtl M.ADUnk $ "Alert: " ++ show al + _ -> M.throw M.ALFtl M.ADUnk $ modNm ++ ".adGet" + +adGetLine :: (HandleLike h, CPRG g) => (HandleBase h g -> M.TlsM h g ()) -> + HandleBase h g -> M.TlsM h g BS.ByteString +adGetLine rp h = getType h >>= \ct -> case ct of + M.CTAppData -> M.getRBuf (pid h) >>= \(bct, bbs) -> case splitLine bbs of + Just (l, ls) -> do + M.setRBuf (pid h) (if BS.null ls then M.CTNull else bct, ls) + return l + _ -> do getCont h >>= M.setRBuf (pid h) + (bbs `BS.append`) `liftM` adGetLine rp h + M.CTHandshake -> rp h >> adGetLine rp h + M.CTAlert -> tRead h 2 >>= \al -> case al of + "\SOH\NUL" -> tWrite h M.CTAlert "\SOH\NUL" >> + M.throw M.ALFtl M.ADUnk "EOF" + _ -> M.throw M.ALFtl M.ADUnk $ "Alert: " ++ show al + _ -> M.throw M.ALFtl M.ADUnk $ modNm ++ ".adGetLine" + +splitLine :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString) +splitLine bs = case ('\r' `BSC.elem` bs, '\n' `BSC.elem` bs) of + (True, _) -> case BSC.uncons rls of + Just ('\n', rnls) -> Just (rl, rnls) + _ -> Just (rl, rls) + (_, True) -> Just (nl, nls) + _ -> Nothing + where + (rl, Just ('\r', rls)) = second BSC.uncons $ BSC.span (/= '\r') bs + (nl, Just ('\n', nls)) = second BSC.uncons $ BSC.span (/= '\n') bs + +adGetContent :: (HandleLike h, CPRG g) => (HandleBase h g -> M.TlsM h g ()) -> + HandleBase h g -> M.TlsM h g BS.ByteString +adGetContent rp h = getType h >>= \ct -> case ct of + M.CTAppData -> bCont h + M.CTHandshake -> rp h >> adGetContent rp h + M.CTAlert -> tRead h 2 >>= \al -> case al of + "\SOH\NUL" -> do + tWrite h M.CTAlert "\SOH\NUL" + M.throw M.ALFtl M.ADUnk $ modNm ++ ".adGetContent" + _ -> M.throw M.ALFtl M.ADUnk $ modNm ++ ".adGetcontent" + _ -> M.throw M.ALFtl M.ADUnk $ modNm ++ ".adGetContent" + +bCont :: (HandleLike h, CPRG g) => HandleBase h g -> M.TlsM h g BS.ByteString +bCont h = snd `liftM` M.getRBuf (pid h) >>= \bp -> if BS.null bp + then snd `liftM` getCont h + else M.setRBuf (pid h) (M.CTNull, BS.empty) >> return bp + +adPut :: (HandleLike h, CPRG g) => HandleBase h g -> BS.ByteString -> M.TlsM h g () +adPut = flip tWrite M.CTAppData + +adDebug :: HandleLike h => + HandleBase h g -> DebugLevel h -> BS.ByteString -> M.TlsM h g () +adDebug = M.tDebug . handle + +adClose :: (HandleLike h, CPRG g) => HandleBase h g -> M.TlsM h g () +adClose t = tWrite t M.CTAlert "\SOH\NUL" >> wFlush t >> M.tClose (handle t) + +flushAd :: (HandleLike h, CPRG g) => + HandleBase h g -> M.TlsM h g (BS.ByteString, Bool) +flushAd t = getType t >>= \ct -> case ct of + M.CTAppData -> bCont t >>= \ad -> first (ad `BS.append`) `liftM` flushAd t + M.CTAlert -> tRead t 2 >>= \a -> case a of + "\1\0" -> return ("", False) + _ -> M.throw M.ALFtl M.ADUnk $ modNm ++ ".flushAd: " ++ show a + _ -> return ("", True) + +getBuf :: HandleLike h => HandleBase h g -> M.TlsM h g BS.ByteString +getBuf = M.getAdBuf . pid + +setBuf :: HandleLike h => HandleBase h g -> BS.ByteString -> M.TlsM h g () +setBuf = M.setAdBuf . pid + +getType :: (HandleLike h, CPRG g) => HandleBase h g -> M.TlsM h g M.ContType +getType h = M.getRBuf (pid h) >>= \(t, b) -> + (\p -> case (t, b) of (M.CTNull, _) -> p; (_, "") -> p; _ -> return t) $ do + c@(t', _) <- getCont h + M.setRBuf (pid h) c >> return t' + +getCont :: (HandleLike h, CPRG g) => + HandleBase h g -> M.TlsM h g (M.ContType, BS.ByteString) +getCont h = do + wFlush h + ct <- (either (M.throw M.ALFtl M.ADUnk) return . B.decode) =<< rd 1 + _v <- rd 2 + e <- rd =<< either (M.throw M.ALFtl M.ADUnk) return . B.decode =<< rd 2 + (ct ,) `liftM` M.decrypt (pid h) ct e + where rd = M.tGet $ handle h + +tWrite :: (HandleLike h, CPRG g) => + HandleBase h g -> M.ContType -> BS.ByteString -> M.TlsM h g () +tWrite h ct p = do + (bct, bp) <- M.getWBuf $ pid h + case ct of + M.CTCCSpec -> wFlush h >> M.setWBuf (pid h) (ct, p) >> wFlush h + _ | bct /= M.CTNull && ct /= bct -> + wFlush h >> M.setWBuf (pid h) (ct, p) + | otherwise -> M.setWBuf (pid h) (ct, bp `BS.append` p) + +wFlush :: (HandleLike h, CPRG g) => HandleBase h g -> M.TlsM h g () +wFlush h = M.getWBuf (pid h) >>= \(bct, bp) -> do + M.setWBuf (pid h) (M.CTNull, "") + unless (bct == M.CTNull) $ M.encrypt (pid h) bct bp >>= \e -> + M.tPut (handle h) $ BS.concat + [B.encode bct, vrsn, B.addLen (undefined :: Word16) e] + +getCipherSuite :: HandleLike h => HandleBase h g -> M.TlsM h g M.CipherSuite +getCipherSuite = M.getCipherSuite . pid + +setCipherSuite :: HandleLike h => HandleBase h g -> M.CipherSuite -> M.TlsM h g () +setCipherSuite = M.setCipherSuite . pid + +getSettingsC :: HandleLike h => HandleBase h g -> M.TlsM h g M.SettingsC +getSettingsC = M.getSettingsC . pid + +setSettingsC :: HandleLike h => HandleBase h g -> M.SettingsC -> M.TlsM h g () +setSettingsC = M.setSettingsC . pid + +getSettingsS :: HandleLike h => HandleBase h g -> M.TlsM h g M.SettingsS +getSettingsS = M.getSettingsS . pid + +setSettingsS :: HandleLike h => HandleBase h g -> M.SettingsS -> M.TlsM h g () +setSettingsS = M.setSettingsS . pid + +getClFinished, getSvFinished :: + HandleLike h => HandleBase h g -> M.TlsM h g BS.ByteString +getClFinished = M.getClFinished . pid +getSvFinished = M.getSvFinished . pid + +setClFinished, setSvFinished :: + HandleLike h => HandleBase h g -> BS.ByteString -> M.TlsM h g () +setClFinished = M.setClFinished . pid +setSvFinished = M.setSvFinished . pid + +getNames :: HandleLike h => HandleBase h g -> M.TlsM h g [String] +getNames = M.getNames . pid + +setNames :: HandleLike h => HandleBase h g -> [String] -> M.TlsM h g () +setNames = M.setNames . pid + +makeKeys :: HandleLike h => HandleBase h g -> M.Side -> + BS.ByteString -> BS.ByteString -> BS.ByteString -> M.CipherSuite -> + M.TlsM h g M.Keys +makeKeys = flip M.makeKeys . pid + +setKeys :: HandleLike h => HandleBase h g -> M.Keys -> M.TlsM h g () +setKeys = M.setKeys . pid + +flushCipherSuite :: HandleLike h => M.RW -> HandleBase h g -> M.TlsM h g () +flushCipherSuite rw = M.flushCipherSuite rw . pid + +finishedHash :: HandleLike h => + M.Side -> HandleBase h g -> BS.ByteString -> M.TlsM h g BS.ByteString +finishedHash s = M.finishedHash s . pid + +debug :: (HandleLike h, Show a) => + HandleBase h g -> DebugLevel h -> a -> M.TlsM h g () +debug t l x = lift . lift . hlDebug (handle t) l . BSC.pack . (++ "\n") $ show x + +class HandleLike h => ValidateHandle h where + validate :: h -> X509.CertificateStore -> X509.CertificateChain -> + HandleMonad h [X509.FailedReason] + +tValidate :: ValidateHandle h => HandleBase h g -> X509.CertificateStore -> + X509.CertificateChain -> M.TlsM h g [X509.FailedReason] +tValidate = (((lift . lift) .) .) . validate . handle + +instance ValidateHandle Handle where + validate _ cs = + X509.validate X509.HashSHA256 X509.defaultHooks ch cs ca ("", "") + where + ch = X509.defaultChecks { X509.checkFQHN = False } + ca = X509.ValidationCache + (\_ _ _ -> return X509.ValidationCacheUnknown) + (\_ _ _ -> return ()) + +debugCipherSuite :: HandleLike h => HandleBase h g -> String -> M.TlsM h g () +debugCipherSuite h a = do + k <- M.getKeys $ pid h + M.tDebug (handle h) "high" . BSC.pack + . (++ (" - VERIFY WITH " ++ a ++ "\n")) . lenSpace 50 + . show $ M.kCchCSuite k + where lenSpace n str = str ++ replicate (n - length str) ' ' diff --git a/src/Network/PeyoTLS/Run/Monad.hs b/src/Network/PeyoTLS/Run/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Run/Monad.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE OverloadedStrings, PackageImports #-} + +module Network.PeyoTLS.Run.Monad ( + TlsM, run, throw, withRandom, + Alert(..), AlertLevel(..), AlertDesc(..), + tGet, decrypt, tPut, encrypt, tClose, tDebug, + S.PartnerId, S.newPartner, S.ContType(..), + getRBuf, getWBuf, getAdBuf, setRBuf, setWBuf, setAdBuf, rstSn, + getClFinished, getSvFinished, setClFinished, setSvFinished, + getNames, setNames, + S.CipherSuite(..), S.CertSecretKey(..), S.isRsaKey, S.isEcdsaKey, + S.SettingsC, getSettingsC, setSettingsC, + S.SettingsS, getSettingsS, setSettingsS, + S.RW(..), getCipherSuite, setCipherSuite, flushCipherSuite, + S.Keys(..), makeKeys, getKeys, setKeys, + C.Side(..), finishedHash ) where + +import Control.Arrow ((***)) +import Control.Monad (unless, liftM, ap) +import "monads-tf" Control.Monad.State (lift, StateT, evalStateT, gets, modify) +import "monads-tf" Control.Monad.Error (ErrorT, runErrorT, throwError) +import "monads-tf" Control.Monad.Error.Class (Error(..)) +import Data.Word (Word8, Word64) +import Data.HandleLike (HandleLike(..)) +import "crypto-random" Crypto.Random (CPRG) + +import qualified Data.ByteString as BS +import qualified Codec.Bytable.BigEndian as B + +import qualified Network.PeyoTLS.Run.State as S ( + TlsState, initState, PartnerId, newPartner, + getGen, setGen, getNames, setNames, + getRSn, getWSn, rstRSn, rstWSn, sccRSn, sccWSn, + getClFinished, getSvFinished, setClFinished, setSvFinished, + ContType(..), getRBuf, getWBuf, getAdBuf, setRBuf, setWBuf, setAdBuf, + CipherSuite(..), BulkEnc(..), RW(..), + getCipherSuite, setCipherSuite, flushCipherSuite, + Keys(..), getKeys, setKeys, + SettingsC, getSettingsC, setSettingsC, + SettingsS, getSettingsS, setSettingsS, + CertSecretKey(..), isRsaKey, isEcdsaKey ) +import qualified Network.PeyoTLS.Run.Crypto as C ( + makeKeys, encrypt, decrypt, sha1, sha256, Side(..), finishedHash ) + +modNm :: String +modNm = "Network.PeyoTLS.Monad" + +vrsn :: BS.ByteString +vrsn = "\3\3" + +type TlsM h g = ErrorT Alert (StateT (S.TlsState h g) (HandleMonad h)) + +run :: HandleLike h => TlsM h g a -> g -> HandleMonad h a +run m g = evalStateT (runErrorT m) (S.initState g) >>= \er -> case er of + Right r -> return r + Left a -> error $ show a + +throw :: HandleLike h => AlertLevel -> AlertDesc -> String -> TlsM h g a +throw = ((throwError .) .) . Alert + +data Alert = Alert AlertLevel AlertDesc String | NotDetected String deriving Show + +data AlertLevel = ALWarning | ALFtl | ALRaw Word8 deriving Show + +data AlertDesc + = ADCloseNotify | ADUnexMsg | ADBadRecMac | ADRecOverflow | ADDecFail + | ADHsFailure | ADUnsCert | ADCertEx | ADCertUnk | ADIllParam + | ADUnkCa | ADDecodeErr | ADDecryptErr | ADProtoVer | ADInsSec + | ADInternalErr | ADUnk | ADRaw Word8 + deriving Show + +instance Error Alert where strMsg = NotDetected + +withRandom :: HandleLike h => (gen -> (a, gen)) -> TlsM h gen a +withRandom p = p `liftM` gets S.getGen >>= + uncurry (flip (>>)) . (return *** modify . S.setGen) + +tGet :: HandleLike h => h -> Int -> TlsM h g BS.ByteString +tGet h n = lift (lift $ hlGet h n) >>= \b -> do + unless (BS.length b == n) . throw ALFtl ADUnk $ + modNm ++ ".tGet: read err " ++ show (BS.length b) ++ " " ++ show n + return b + +decrypt :: HandleLike h => + S.PartnerId -> S.ContType -> BS.ByteString -> TlsM h g BS.ByteString +decrypt i ct e = do + ks <- getKeys i + let S.CipherSuite _ be = S.kRCSuite ks; + wk = S.kRKey ks; mk = S.kRMKey ks + sn <- udSn S.Read i + case be of + S.AES_128_CBC_SHA -> either (throw ALFtl ADUnk) return $ + C.decrypt C.sha1 wk mk sn (B.encode ct `BS.append` vrsn) e + S.AES_128_CBC_SHA256 -> either (throw ALFtl ADUnk) return $ + C.decrypt C.sha256 wk mk sn (B.encode ct `BS.append` vrsn) e + S.BE_NULL -> return e + +tPut :: HandleLike h => h -> BS.ByteString -> TlsM h g () +tPut = ((lift . lift) .) . hlPut + +encrypt :: (HandleLike h, CPRG g) => + S.PartnerId -> S.ContType -> BS.ByteString -> TlsM h g BS.ByteString +encrypt i ct p = do + ks <- getKeys i + let S.CipherSuite _ be = S.kWCSuite ks + wk = S.kWKey ks; mk = S.kWMKey ks + sn <- udSn S.Write i + case be of + S.AES_128_CBC_SHA -> withRandom $ + C.encrypt C.sha1 wk mk sn (B.encode ct `BS.append` vrsn) p + S.AES_128_CBC_SHA256 -> withRandom $ + C.encrypt C.sha256 wk mk sn (B.encode ct `BS.append` vrsn) p + S.BE_NULL -> return p + +tClose :: HandleLike h => h -> TlsM h g () +tClose = lift . lift . hlClose + +tDebug :: HandleLike h => h -> DebugLevel h -> BS.ByteString -> TlsM h gen () +tDebug = (((lift . lift) .) .) . hlDebug + +getRBuf, getWBuf :: HandleLike h => + S.PartnerId -> TlsM h g (S.ContType, BS.ByteString) +getRBuf = gets . S.getRBuf; getWBuf = gets . S.getWBuf + +getAdBuf :: HandleLike h => S.PartnerId -> TlsM h g BS.ByteString +getAdBuf = gets . S.getAdBuf + +setRBuf, setWBuf :: HandleLike h => + S.PartnerId -> (S.ContType, BS.ByteString) -> TlsM h g () +setRBuf = (modify .) . S.setRBuf; setWBuf = (modify .) . S.setWBuf + +setAdBuf :: HandleLike h => S.PartnerId -> BS.ByteString -> TlsM h g () +setAdBuf = (modify .) . S.setAdBuf + +udSn :: HandleLike h => S.RW -> S.PartnerId -> TlsM h g Word64 +udSn rw i = case rw of + S.Read -> const `liftM` gets (S.getRSn i) `ap` modify (S.sccRSn i) + S.Write -> const `liftM` gets (S.getWSn i) `ap` modify (S.sccWSn i) + +rstSn :: HandleLike h => S.RW -> S.PartnerId -> TlsM h g () +rstSn rw = case rw of S.Read -> modify . S.rstRSn; S.Write -> modify . S.rstWSn + +getClFinished, getSvFinished :: + HandleLike h => S.PartnerId -> TlsM h g BS.ByteString +getClFinished = gets . S.getClFinished +getSvFinished = gets . S.getSvFinished + +setClFinished, setSvFinished :: + HandleLike h => S.PartnerId -> BS.ByteString -> TlsM h g () +setClFinished = (modify .) . S.setClFinished +setSvFinished = (modify .) . S.setSvFinished + +getNames :: HandleLike h => S.PartnerId -> TlsM h g [String] +getNames = gets . S.getNames + +setNames :: HandleLike h => S.PartnerId -> [String] -> TlsM h g () +setNames = (modify .) . S.setNames + +getSettingsC :: HandleLike h => S.PartnerId -> TlsM h g S.SettingsC +getSettingsC i = gets (S.getSettingsC i ) >>= maybe (throw ALFtl ADUnk "...") return + +getSettingsS :: HandleLike h => S.PartnerId -> TlsM h g S.SettingsS +getSettingsS = gets . S.getSettingsS + +setSettingsC :: HandleLike h => S.PartnerId -> S.SettingsC -> TlsM h g () +setSettingsC = (modify .) . S.setSettingsC + +setSettingsS :: HandleLike h => S.PartnerId -> S.SettingsS -> TlsM h g () +setSettingsS = (modify .) . S.setSettingsS + +getCipherSuite :: HandleLike h => S.PartnerId -> TlsM h g S.CipherSuite +getCipherSuite = gets . S.getCipherSuite + +setCipherSuite :: HandleLike h => S.PartnerId -> S.CipherSuite -> TlsM h g () +setCipherSuite = (modify .) . S.setCipherSuite + +flushCipherSuite :: HandleLike h => S.RW -> S.PartnerId -> TlsM h g () +flushCipherSuite = (modify .) . S.flushCipherSuite + +makeKeys :: HandleLike h => C.Side -> S.PartnerId -> + BS.ByteString -> BS.ByteString -> BS.ByteString -> S.CipherSuite -> + TlsM h g S.Keys +makeKeys s t cr sr pms cs@(S.CipherSuite _ be) = do + kl <- case be of + S.AES_128_CBC_SHA -> return $ snd C.sha1 + S.AES_128_CBC_SHA256 -> return $ snd C.sha256 + _ -> throw ALFtl ADUnk $ modNm ++ ".makeKeys: bad bulk enc" + let (ms, cwmk, swmk, cwk, swk) = C.makeKeys kl cr sr pms + getKeys t >>= \k -> return $ case s of + C.Client -> k { + S.kCchCSuite = cs, S.kMSec = ms, + S.kCchRMKey = swmk, S.kCchWMKey = cwmk, + S.kCchRKey = swk, S.kCchWKey = cwk } + C.Server -> k { + S.kCchCSuite = cs, S.kMSec = ms, + S.kCchRMKey = cwmk, S.kCchWMKey = swmk, + S.kCchRKey = cwk, S.kCchWKey = swk } +makeKeys _ _ _ _ _ _ = throw ALFtl ADUnk $ modNm ++ ".makeKeys" + +getKeys :: HandleLike h => S.PartnerId -> TlsM h g S.Keys +getKeys = gets . S.getKeys + +setKeys :: HandleLike h => S.PartnerId -> S.Keys -> TlsM h g () +setKeys = (modify .) . S.setKeys + +finishedHash :: HandleLike h => + C.Side -> S.PartnerId -> BS.ByteString -> TlsM h g BS.ByteString +finishedHash s t hs = C.finishedHash s hs `liftM` S.kMSec `liftM` getKeys t diff --git a/src/Network/PeyoTLS/Run/State.hs b/src/Network/PeyoTLS/Run/State.hs new file mode 100644 --- /dev/null +++ b/src/Network/PeyoTLS/Run/State.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports #-} + +module Network.PeyoTLS.Run.State ( + TlsState, initState, PartnerId, newPartner, + getGen, setGen, getNames, setNames, + getRSn, getWSn, rstRSn, rstWSn, sccRSn, sccWSn, + getClFinished, setClFinished, getSvFinished, setSvFinished, + ContType(..), getRBuf, getWBuf, getAdBuf, setRBuf, setWBuf, setAdBuf, + CipherSuite(..), BulkEnc(..), RW(..), + getCipherSuite, setCipherSuite, flushCipherSuite, + Keys(..), getKeys, setKeys, + SettingsC, getSettingsC, setSettingsC, + SettingsS, getSettingsS, setSettingsS, + CertSecretKey(..), isRsaKey, isEcdsaKey ) where + +import Control.Applicative ((<$>)) +import Control.Arrow (first) +import Data.Maybe (maybeToList) +import Data.List (find) +import Data.Word (Word8, Word64) + +import qualified Data.ByteString as BS +import qualified Data.X509 as X509 +import qualified Data.X509.CertificateStore as X509 +import qualified Codec.Bytable.BigEndian as B +import qualified Crypto.PubKey.RSA as RSA +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA + +import Network.PeyoTLS.CertSecretKey (CertSecretKey(..), isRsaKey, isEcdsaKey) +import Network.PeyoTLS.CipherSuite (CipherSuite(..), KeyEx(KE_NULL), BulkEnc(..)) + +modNm :: String +modNm = "Network.PeyoTLS.State" + +type Modify s = s -> s + +data TlsState h g = + TlsState { gen :: g, nextPid :: Int, states :: [(PartnerId, State1 g)] } + +initState :: g -> TlsState h g +initState g = TlsState{ gen = g, nextPid = 0, states = [] } + +getState :: PartnerId -> TlsState h g -> State1 g +getState i s = case lookup i $ states s of + Just s1 -> s1 + _ -> error $ modNm ++ ".getState" + +modState :: Modify (State1 g) -> PartnerId -> Modify (TlsState h g) +modState f i s = s { states = (i, f $ getState i s) : states s } + +setState :: (a -> Modify (State1 g)) -> PartnerId -> a -> Modify (TlsState h g) +setState f i x s = modState (f x) i s + +data State1 g = State1 { + settings :: Settings, + rnClFinished :: BS.ByteString, rnSvFinished :: BS.ByteString, + sKeys :: Keys, readSN :: Word64, writeSN :: Word64, + rBuffer :: (ContType, BS.ByteString), wBuffer :: (ContType, BS.ByteString), + adBuffer :: BS.ByteString, + sNames :: [String] } + +type Settings = ( + [CipherSuite], [(CertSecretKey, X509.CertificateChain)], + Maybe X509.CertificateStore ) + +data PartnerId = PartnerId Int deriving (Show, Eq) + +newPartner :: TlsState h g -> (PartnerId, TlsState h g) +newPartner s@TlsState { nextPid = np, states = ss } = ( + PartnerId np , + s { nextPid = succ np, states = (PartnerId np, s1) : ss } ) + where + s1 = State1 { + settings = ([], [], Nothing), + rnClFinished = "", rnSvFinished = "", + sKeys = nullKeys, readSN = 0, writeSN = 0, + rBuffer = (CTNull, ""), wBuffer = (CTNull, ""), adBuffer = "", + sNames = [] } + +getGen :: TlsState h g -> g +getGen = gen + +setGen :: g -> TlsState h g -> TlsState h g +setGen g st = st { gen = g } + +getNames :: PartnerId -> TlsState h g -> [String] +getNames = (sNames .) . getState + +setNames :: PartnerId -> [String] -> Modify (TlsState h g) +setNames = setState $ \n st -> st { sNames = n } + +getRSn, getWSn :: PartnerId -> TlsState h g -> Word64 +getRSn = (readSN .) . getState; getWSn = (writeSN .) . getState + +rstRSn, rstWSn :: PartnerId -> Modify (TlsState h g) +rstRSn = modState $ \s -> s { readSN = 0 } +rstWSn = modState $ \s -> s { writeSN = 0 } + +sccRSn, sccWSn :: PartnerId -> Modify (TlsState h g) +sccRSn = modState $ \s -> s { readSN = succ $ readSN s } +sccWSn = modState $ \s -> s { writeSN = succ $ writeSN s } + +getClFinished, getSvFinished :: PartnerId -> TlsState h g -> BS.ByteString +getClFinished = (rnClFinished .) . getState +getSvFinished = (rnSvFinished .) . getState + +setClFinished, setSvFinished :: PartnerId -> BS.ByteString -> Modify (TlsState h g) +setClFinished = setState $ \cf st -> st { rnClFinished = cf } +setSvFinished = setState $ \sf st -> st { rnSvFinished = sf } + +data ContType = CTCCSpec | CTAlert | CTHandshake | CTAppData | CTNull | CTRaw Word8 + deriving (Show, Eq) + +instance B.Bytable ContType where + encode CTNull = BS.pack [0] + encode CTCCSpec = BS.pack [20] + encode CTAlert = BS.pack [21] + encode CTHandshake = BS.pack [22] + encode CTAppData = BS.pack [23] + encode (CTRaw ct) = BS.pack [ct] + decode "\0" = Right CTNull + decode "\20" = Right CTCCSpec + decode "\21" = Right CTAlert + decode "\22" = Right CTHandshake + decode "\23" = Right CTAppData + decode bs | [ct] <- BS.unpack bs = Right $ CTRaw ct + decode _ = Left $ modNm ++ ": ContType.decode" + +getRBuf, getWBuf :: PartnerId -> TlsState h g -> (ContType, BS.ByteString) +getRBuf = (rBuffer .) . getState; getWBuf = (wBuffer .) . getState + +getAdBuf :: PartnerId -> TlsState h g -> BS.ByteString +getAdBuf = (adBuffer .) . getState + +setRBuf, setWBuf :: PartnerId -> (ContType, BS.ByteString) -> Modify (TlsState h g) +setRBuf = setState $ \bs st -> st { rBuffer = bs } +setWBuf = setState $ \bs st -> st { wBuffer = bs } + +setAdBuf :: PartnerId -> BS.ByteString -> Modify (TlsState h g) +setAdBuf = setState $ \bs st -> st { adBuffer = bs } + +data RW = Read | Write deriving Show + +getCipherSuite :: PartnerId -> TlsState h g -> CipherSuite +getCipherSuite = ((kCchCSuite . sKeys) .) . getState + +setCipherSuite :: PartnerId -> CipherSuite -> Modify (TlsState h g) +setCipherSuite = setState $ \cs st -> st { sKeys = (sKeys st) { kCchCSuite = cs } } + +flushCipherSuite :: RW -> PartnerId -> Modify (TlsState h g) +flushCipherSuite Read = flushCipherSuiteRead +flushCipherSuite Write = flushCipherSuiteWrite + +flushCipherSuiteRead :: PartnerId -> Modify (TlsState h g) +flushCipherSuiteRead = modState $ \st -> st { sKeys = (sKeys st) { + kRCSuite = kCchCSuite (sKeys st), kRMKey = kCchRMKey (sKeys st), + kRKey = kCchRKey (sKeys st) } } + +flushCipherSuiteWrite :: PartnerId -> Modify (TlsState h g) +flushCipherSuiteWrite = modState $ \st -> st { sKeys = (sKeys st) { + kWCSuite = kCchCSuite (sKeys st), kWMKey = kCchWMKey (sKeys st), + kWKey = kCchWKey (sKeys st) } } + +data Keys = Keys { + kMSec :: BS.ByteString, + kRCSuite :: CipherSuite, kWCSuite :: CipherSuite, + kRMKey :: BS.ByteString, kWMKey :: BS.ByteString, + kRKey :: BS.ByteString, kWKey :: BS.ByteString, + kCchCSuite :: CipherSuite, + kCchRMKey :: BS.ByteString, kCchWMKey :: BS.ByteString, + kCchRKey :: BS.ByteString, kCchWKey :: BS.ByteString } + deriving (Show, Eq) + +nullKeys :: Keys +nullKeys = Keys { + kMSec = "", + kRCSuite = CipherSuite KE_NULL BE_NULL, + kWCSuite = CipherSuite KE_NULL BE_NULL, + kRMKey = "", kWMKey = "", kRKey = "", kWKey = "", + kCchCSuite = CipherSuite KE_NULL BE_NULL, + kCchRMKey = "", kCchWMKey = "", + kCchRKey = "", kCchWKey = "" } + +getKeys :: PartnerId -> TlsState h g -> Keys +getKeys = (sKeys .) . getState + +setKeys :: PartnerId -> Keys -> Modify (TlsState h g) +setKeys = setState $ \k st -> st { sKeys = k } + +type SettingsC = ( + [CipherSuite], [(CertSecretKey, X509.CertificateChain)], + X509.CertificateStore ) + +getSettingsC :: PartnerId -> TlsState h g -> Maybe SettingsC +getSettingsC i s = case settings $ getState i s of + (css, crts, Just cs) -> Just (css, crts, cs) + _ -> Nothing + +setSettingsC :: PartnerId -> SettingsC -> Modify (TlsState h g) +setSettingsC = + setState $ \(css, crts, cs) st -> st { settings = (css, crts, Just cs) } + +type SettingsS = ( + [CipherSuite], + Maybe (RSA.PrivateKey, X509.CertificateChain), + Maybe (ECDSA.PrivateKey, X509.CertificateChain), + Maybe X509.CertificateStore ) + +getSettingsS :: PartnerId -> TlsState h g -> SettingsS +getSettingsS = ((toS . settings) .) . getState + where toS (cs, crts, mcs) = (cs, + first rsaKey <$> find (isRsaKey . fst) crts, + first ecdsaKey <$> find (isEcdsaKey . fst) crts, mcs) + +setSettingsS :: PartnerId -> SettingsS -> Modify (TlsState h g) +setSettingsS = setState $ \is st -> st { settings = fromS is } + where fromS (cs, rcrt, ecrt, mcs) = (cs, + maybeToList (first RsaKey <$> rcrt) ++ + maybeToList (first EcdsaKey <$> ecrt), mcs) 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 @@ -12,7 +12,7 @@ module Network.PeyoTLS.Server ( -- * Basic - PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, names, getNames, + PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, getNames, -- * Renegotiation renegotiate, setCipherSuites, setKeyCerts, setCertificateStore, -- * Cipher Suite @@ -42,7 +42,7 @@ import qualified Crypto.Types.PubKey.DH as DH import qualified Crypto.Types.PubKey.ECC as ECC -import qualified Network.PeyoTLS.Base as BASE (names, getNames) +import qualified Network.PeyoTLS.Base as BASE (getNames) import Network.PeyoTLS.Base ( debug, PeyotlsM, TlsM, run, SettingsS, getSettingsS, setSettingsS, @@ -51,27 +51,27 @@ withRandom, flushAd, AlertLevel(..), AlertDesc(..), throw, debugCipherSuite, ValidateHandle(..), handshakeValidate, validateAlert, - TlsHandleBase, CertSecretKey(..), isRsaKey, isEcdsaKey, - readHandshake, writeHandshake, ChangeCipherSpec(..), + HandleBase, CertSecretKey(..), isRsaKey, isEcdsaKey, + readHandshake, writeHandshake, CCSpec(..), Handshake(HHelloReq), - ClientHello(..), ServerHello(..), SessionId(..), Extension(..), - isRenegoInfo, emptyRenegoInfo, + ClHello(..), SvHello(..), SssnId(..), Extension(..), + isRnInfo, emptyRnInfo, CipherSuite(..), KeyEx(..), BulkEnc(..), - CompMethod(..), HashAlg(..), SignAlg(..), + CmpMtd(..), HashAlg(..), SignAlg(..), getCipherSuite, setCipherSuite, checkClRenego, makeSvRenego, - ServerKeyEx(..), SvSignSecretKey(..), + SvKeyEx(..), SvSignSecretKey(..), certReq, ClCertType(..), - ServerHelloDone(..), - ClientKeyEx(..), Epms(..), makeKeys, - DigitallySigned(..), ClSignPublicKey(..), handshakeHash, + SHDone(..), + ClKeyEx(..), Epms(..), makeKeys, + DigitSigned(..), ClSignPublicKey(..), handshakeHash, RW(..), flushCipherSuite, Side(..), finishedHash, DhParam(..), ecdsaPubKey ) type PeyotlsHandle = TlsHandle Handle SystemRNG -newtype TlsHandle h g = TlsHandleS { tlsHandleS :: TlsHandleBase h g } deriving Show +newtype TlsHandle h g = TlsHandleS { tlsHandleS :: HandleBase h g } deriving Show instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandle h g) where type HandleMonad (TlsHandle h g) = TlsM h g @@ -91,11 +91,6 @@ moduleName :: String moduleName = "Network.PeyoTLS.Server" -{-# DEPRECATED names "Use getNames instead" #-} - -names :: TlsHandle h g -> [String] -names = BASE.names . tlsHandleS - getNames :: HandleLike h => TlsHandle h g -> TlsM h g [String] getNames = BASE.getNames . tlsHandleS @@ -144,7 +139,7 @@ debug "low" ("after flushAd" :: String) when ne (handshake =<< getSettingsS) -rehandshake :: (ValidateHandle h, CPRG g) => TlsHandleBase h g -> TlsM h g () +rehandshake :: (ValidateHandle h, CPRG g) => HandleBase h g -> TlsM h g () rehandshake t = rerunHandshakeM t $ handshake =<< getSettingsS handshake :: (ValidateHandle h, CPRG g) => SettingsS -> HandshakeM h g () @@ -154,26 +149,25 @@ ha <- case be of AES_128_CBC_SHA -> return Sha1 AES_128_CBC_SHA256 -> return Sha256 - _ -> throw ALFatal ADInternalError $ + _ -> throw ALFtl ADInternalErr $ pre ++ "not implemented bulk encryption type" mpk <- ($ mcs) . ($ (cr, sr)) $ case (ke, fst <$> rcrt, fst <$> ecrt) of (RSA, Just rsk, _) -> rsaKeyExchange rsk cv (DHE_RSA, Just rsk, _) -> dhKeyExchange ha dh3072Modp rsk (ECDHE_RSA, Just rsk, _) -> dhKeyExchange ha secp256r1 rsk (ECDHE_ECDSA, _, Just esk) -> dhKeyExchange ha secp256r1 esk - _ -> \_ _ -> throw ALFatal ADInternalError $ + _ -> \_ _ -> throw ALFtl ADInternalErr $ pre ++ "no implemented key exchange type or " ++ "no applicable certificate files" flip (maybe $ return ()) mpk $ \pk -> case pk of X509.PubKeyRSA rpk -> certVerify rpk X509.PubKeyECDSA c xy -> certVerify $ ecdsaPubKey c xy - _ -> throw ALFatal ADUnsupportedCertificate $ - pre ++ "not implement: " ++ show pk - ChangeCipherSpec <- readHandshake + _ -> throw ALFtl ADUnsCert $ pre ++ "not implement: " ++ show pk + CCSpec <- readHandshake flushCipherSuite Read (==) `liftM` finishedHash Client `ap` readHandshake >>= \ok -> unless ok . - throw ALFatal ADDecryptError $ pre ++ "wrong finished hash" - writeHandshake ChangeCipherSpec + throw ALFtl ADDecryptErr $ pre ++ "wrong finished hash" + writeHandshake CCSpec flushCipherSuite Write writeHandshake =<< finishedHash Server where pre = moduleName ++ ".handshake: " @@ -204,29 +198,28 @@ clientHello :: (HandleLike h, CPRG g) => [CipherSuite] -> HandshakeM h g (KeyEx, BulkEnc, BS.ByteString, Version) clientHello cssv = do - ClientHello cv cr _sid cscl cms me <- readHandshake - checkRenegoInfo cscl me - unless (cv >= version) . throw ALFatal ADProtocolVersion $ + ClHello cv cr _sid cscl cms me <- readHandshake + checkRnInfo cscl me + unless (cv >= version) . throw ALFtl ADProtoVer $ pre ++ "only implement TLS 1.2" - unless (CompMethodNull `elem` cms) . throw ALFatal ADDecodeError $ + unless (CmpMtdNull `elem` cms) . throw ALFtl ADDecodeErr $ pre ++ "compression method NULL must be supported" (ke, be) <- case find (`elem` cscl) cssv of Just cs@(CipherSuite k b) -> setCipherSuite cs >> return (k, b) - _ -> throw ALFatal ADHsFailure $ + _ -> throw ALFtl ADHsFailure $ pre ++ "no acceptable set of security parameters: \n\t" ++ "cscl: " ++ show cscl ++ "\n\t" ++ "cssv: " ++ show cssv ++ "\n" return (ke, be, cr, cv) where pre = moduleName ++ ".clientHello: " -checkRenegoInfo :: +checkRnInfo :: HandleLike h => [CipherSuite] -> Maybe [Extension] -> HandshakeM h g () -checkRenegoInfo cscl me = (\n -> maybe n checkClRenego mcf) . throw - ALFatal ADInsufficientSecurity $ - moduleName ++ ".checkRenego: require secure renegotiation" +checkRnInfo cscl me = (\n -> maybe n checkClRenego mcf) . throw + ALFtl ADInsSec $ moduleName ++ ".checkRenego: require secure renegotiation" where mcf = case (EMPTY_RENEGOTIATION_INFO `elem` cscl, me) of - (True, _) -> Just emptyRenegoInfo - (_, Just e) -> find isRenegoInfo e + (True, _) -> Just emptyRnInfo + (_, Just e) -> find isRnInfo e (_, _) -> Nothing serverHello :: (HandleLike h, CPRG g) => @@ -236,16 +229,16 @@ cs <- getCipherSuite ke <- case cs of CipherSuite k _ -> return k - _ -> throw ALFatal ADInternalError $ + _ -> throw ALFtl ADInternalErr $ moduleName ++ ".serverHello: never occur" sr <- withRandom $ cprgGenerate 32 writeHandshake - . ServerHello version sr (SessionId "") cs CompMethodNull + . SvHello version sr (SssnId "") cs CmpMtdNull . Just . (: []) =<< makeSvRenego writeHandshake =<< case (ke, rcc, ecc) of (ECDHE_ECDSA, _, Just c) -> return c (_, Just c, _) -> return c - _ -> throw ALFatal ADInternalError $ + _ -> throw ALFtl ADInternalErr $ moduleName ++ ".serverHello: cert files not match" return sr @@ -259,9 +252,9 @@ where mkpms epms = do pms <- either (E.throwError . strMsg . show) return =<< withRandom (\g -> RSA.decryptSafer g sk epms) - unless (BS.length pms == 48) $ throw ALFatal ADHsFailure "" + unless (BS.length pms == 48) $ throw ALFtl ADHsFailure "" let [pvj, pvn] = BS.unpack $ BS.take 2 pms - unless (pvj == vj && pvn == vn) $ throw ALFatal ADHsFailure "" + unless (pvj == vj && pvn == vn) $ throw ALFtl ADHsFailure "" return pms dhKeyExchange :: (ValidateHandle h, CPRG g, SvSignSecretKey sk, @@ -273,12 +266,12 @@ bl <- withRandom $ generateBlinder sk let pv = B.encode $ calculatePublic dp sv writeHandshake - . ServerKeyEx (B.encode dp) pv ha (sssAlgorithm sk) + . SvKeyEx (B.encode dp) pv ha (sssAlgorithm sk) . ssSign sk ha bl $ BS.concat [cr, sr, B.encode dp, pv] const `liftM` reqAndCert mcs `ap` do - ClientKeyEx cke <- readHandshake + ClKeyEx cke <- readHandshake makeKeys Server rs . calculateShared dp sv =<< - either (throw ALFatal ADInternalError . + either (throw ALFtl ADInternalErr . (moduleName ++) . (".dhKeyExchange: " ++)) return (B.decode cke) @@ -291,7 +284,7 @@ flip (maybe $ return Nothing) mcs $ liftM Just . \cs -> do cc@(X509.CertificateChain (c : _)) <- readHandshake vr <- handshakeValidate cs cc - unless (null vr) . throw ALFatal (validateAlert vr) $ + unless (null vr) . throw ALFtl (validateAlert vr) $ moduleName ++ ".reqAndCert: " ++ show vr return . X509.certPubKey $ X509.getCertificate c @@ -299,10 +292,10 @@ certVerify pk = do debugCipherSuite . show $ cspAlgorithm pk hs0 <- handshakeHash - DigitallySigned a s <- readHandshake + DigitSigned a s <- readHandshake case a of (Sha256, sa) | sa == cspAlgorithm pk -> return () - _ -> throw ALFatal ADDecodeError $ + _ -> throw ALFtl ADDecodeErr $ moduleName ++ ".certVerify: not implement: " ++ show a - unless (csVerify pk s hs0) . throw ALFatal ADDecryptError $ + unless (csVerify pk s hs0) . throw ALFtl ADDecryptErr $ moduleName ++ ".certVerify: client auth failed " diff --git a/src/Network/PeyoTLS/State.hs b/src/Network/PeyoTLS/State.hs deleted file mode 100644 --- a/src/Network/PeyoTLS/State.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports #-} - -module Network.PeyoTLS.State ( - HandshakeState, initState, PartnerId, newPartnerId, Keys(..), nullKeys, - ContentType(..), Alert(..), AlertLevel(..), AlertDesc(..), - CipherSuite(..), KeyEx(..), BulkEnc(..), - randomGen, setRandomGen, - getBuf, setBuf, getWBuf, setWBuf, - getAdBuf, setAdBuf, - getReadSN, getWriteSN, succReadSN, succWriteSN, resetReadSN, resetWriteSN, - getCipherSuite, setCipherSuite, flushCipherSuiteRead, flushCipherSuiteWrite, - getKeys, setKeys, - getSettings, setSettings, - getInitSet, setInitSet, - getClientFinished, setClientFinished, - getServerFinished, setServerFinished, - - SettingsS, Settings, - CertSecretKey(..), isRsaKey, isEcdsaKey, - - getNames, setNames, -) where - -import Control.Applicative ((<$>)) -import Control.Arrow (first) -import "monads-tf" Control.Monad.Error.Class (Error(strMsg)) -import Data.Maybe (fromJust, maybeToList) -import Data.List (find) -import Data.Word (Word8, Word64) -import Data.String (IsString(..)) - -import qualified Data.ByteString as BS -import qualified Codec.Bytable.BigEndian as B - -import Network.PeyoTLS.CertSecretKey (CertSecretKey(..), isRsaKey, isEcdsaKey) -import qualified Data.X509 as X509 -import qualified Data.X509.CertificateStore as X509 - -import Network.PeyoTLS.CipherSuite ( - 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)] } - -initState :: g -> HandshakeState h g -initState g = HandshakeState{ randomGen = g, nextPartnerId = 0, states = [] } - -data PartnerId = PartnerId Int deriving (Show, Eq) - -newPartnerId :: HandshakeState h g -> (PartnerId, HandshakeState h g) -newPartnerId s = (PartnerId i ,) s{ - nextPartnerId = succ i, - states = (PartnerId i, so) : sos } - where - i = nextPartnerId s - so = StateOne { - sKeys = nullKeys, - rBuffer = (CTNull, ""), wBuffer = (CTNull, ""), - radBuffer = "", - readSN = 0, writeSN = 0, - rnClientFinished = "", rnServerFinished = "", - initialSettings = ([], [], Nothing), - sNames = [] - } - sos = states s - -type SettingsS = ( - [CipherSuite], - Maybe (RSA.PrivateKey, X509.CertificateChain), - Maybe (ECDSA.PrivateKey, X509.CertificateChain), - Maybe X509.CertificateStore ) - -type Settings = ( - [CipherSuite], - [(CertSecretKey, X509.CertificateChain)], - Maybe X509.CertificateStore ) - -convertSettings :: Settings -> SettingsS -convertSettings (cs, crts, mcs) = (cs, - first rsaKey <$> find (isRsaKey . fst) crts, - first ecdsaKey <$> find (isEcdsaKey . fst) crts, mcs) - -revertSettings :: SettingsS -> Settings -revertSettings (cs, rcrt, ecrt, mcs) = (cs, - maybeToList (first RsaKey <$> rcrt) ++ - maybeToList (first EcdsaKey <$> ecrt), mcs) - -data StateOne g = StateOne { - sKeys :: Keys, - rBuffer :: (ContentType, BS.ByteString), - wBuffer :: (ContentType, BS.ByteString), - radBuffer :: BS.ByteString, - readSN :: Word64, - writeSN :: Word64, - rnClientFinished :: BS.ByteString, - rnServerFinished :: BS.ByteString, - initialSettings :: Settings, - sNames :: [String] - } - -getState :: PartnerId -> HandshakeState h g -> StateOne g -getState i = fromJust' "getState" . lookup i . states - -setState :: PartnerId -> StateOne g -> Modify (HandshakeState h g) -setState i so s = s { states = (i, so) : states s } - -modifyState :: PartnerId -> Modify (StateOne g) -> Modify (HandshakeState h g) -modifyState i f s = setState i (f $ getState i s) s - -data Keys = Keys { - kCachedCS :: CipherSuite, - kReadCS :: CipherSuite, kWriteCS :: CipherSuite, - kMasterSecret :: BS.ByteString, - kCachedReadMacKey :: BS.ByteString, - kCachedWriteMacKey :: BS.ByteString, - kCachedReadKey :: BS.ByteString, - kCachedWriteKey :: BS.ByteString, - kReadMacKey :: BS.ByteString, kWriteMacKey :: BS.ByteString, - kReadKey :: BS.ByteString, kWriteKey :: BS.ByteString } - deriving (Show, Eq) - -nullKeys :: Keys -nullKeys = Keys { - kCachedCS = CipherSuite KE_NULL BE_NULL, - kReadCS = CipherSuite KE_NULL BE_NULL, - kWriteCS = CipherSuite KE_NULL BE_NULL, - kMasterSecret = "", - kCachedReadMacKey = "", kCachedWriteMacKey = "", - kCachedReadKey = "", kCachedWriteKey = "", - kReadMacKey = "", kWriteMacKey = "", kReadKey = "", kWriteKey = "" } - -data ContentType - = CTCCSpec | CTAlert | CTHandshake | CTAppData | CTNull | CTRaw Word8 - deriving (Show, Eq) - -instance B.Bytable ContentType where - encode CTNull = BS.pack [0] - encode CTCCSpec = BS.pack [20] - encode CTAlert = BS.pack [21] - encode CTHandshake = BS.pack [22] - encode CTAppData = BS.pack [23] - encode (CTRaw ct) = BS.pack [ct] - decode "\0" = Right CTNull - decode "\20" = Right CTCCSpec - decode "\21" = Right CTAlert - decode "\22" = Right CTHandshake - decode "\23" = Right CTAppData - decode bs | [ct] <- BS.unpack bs = Right $ CTRaw ct - decode _ = Left "State.decodeCT" - -data Alert = Alert AlertLevel AlertDesc String | NotDetected String - deriving Show - -data AlertLevel = ALWarning | ALFatal | ALRaw Word8 deriving Show - -data AlertDesc - = ADCloseNotify | ADUnexMsg | ADBadRecordMac - | ADRecordOverflow | ADDecompressionFailure | ADHsFailure - | ADUnsupportedCertificate | ADCertificateExpired | ADCertificateUnknown - | ADIllegalParameter | ADUnknownCa | ADDecodeError - | ADDecryptError | ADProtocolVersion | ADInsufficientSecurity - | ADInternalError | ADUnclasified - | ADRaw Word8 - deriving Show - -instance Error Alert where - strMsg = NotDetected - -instance IsString Alert where - fromString = NotDetected - -setRandomGen :: g -> HandshakeState h g -> HandshakeState h g -setRandomGen rg st = st { randomGen = rg } - -getBuf :: PartnerId -> HandshakeState h g -> (ContentType, BS.ByteString) -getBuf i = rBuffer . fromJust' "getBuf" . lookup i . states - -setBuf :: PartnerId -> (ContentType, BS.ByteString) -> Modify (HandshakeState h g) -setBuf i = modifyState i . \bs st -> st { rBuffer = bs } - -getAdBuf :: PartnerId -> HandshakeState h g -> BS.ByteString -getAdBuf i = radBuffer . fromJust' "getAdBuf" . lookup i . states - -setAdBuf :: PartnerId -> BS.ByteString -> Modify (HandshakeState h g) -setAdBuf i = modifyState i . \bs st -> st { radBuffer = bs } - -getCipherSuite :: PartnerId -> HandshakeState h g -> CipherSuite -getCipherSuite i = - kCachedCS . sKeys . fromJust' "getCipherSuite" . lookup i . states - -setCipherSuite :: PartnerId -> CipherSuite -> Modify (HandshakeState h g) -setCipherSuite i = modifyState i . \cs st -> - st { sKeys = (sKeys st) { kCachedCS = cs } } - -getNames :: PartnerId -> HandshakeState h g -> [String] -getNames i = sNames . fromJust' "getNames" . lookup i . states - -setNames :: PartnerId -> [String] -> Modify (HandshakeState h g) -setNames i = modifyState i . \n st -> st { sNames = n } - -getKeys :: PartnerId -> HandshakeState h g -> Keys -getKeys i = sKeys . fromJust' "getKeys" . lookup i . states - -setKeys :: PartnerId -> Keys -> Modify (HandshakeState h g) -setKeys i = modifyState i . \k st -> st { sKeys = k } - -getSettings :: PartnerId -> HandshakeState h g -> Settings -getSettings i = initialSettings . fromJust' "getSettings" . lookup i . states - -getInitSet :: PartnerId -> HandshakeState h g -> SettingsS -getInitSet i = convertSettings . - initialSettings . fromJust' "getInitSet" . lookup i . states - -setSettings :: PartnerId -> Settings -> Modify (HandshakeState h g) -setSettings i = modifyState i . \is st -> st { initialSettings = is } - -setInitSet :: PartnerId -> SettingsS -> Modify (HandshakeState h g) -setInitSet i = modifyState i . \is st -> st - { initialSettings = revertSettings is } - -getClientFinished, getServerFinished :: - PartnerId -> HandshakeState h g -> BS.ByteString -getClientFinished i = - rnClientFinished . fromJust' "getClientFinished" . lookup i . states -getServerFinished i = - rnServerFinished . fromJust' "getClientFinished" . lookup i . states - -setClientFinished, setServerFinished :: - PartnerId -> BS.ByteString -> Modify (HandshakeState h g) -setClientFinished i = modifyState i . \cf st -> st { rnClientFinished = cf } -setServerFinished i = modifyState i . \sf st -> st { rnServerFinished = sf } - -flushCipherSuiteRead :: PartnerId -> Modify (HandshakeState h g) -flushCipherSuiteRead i = modifyState i $ \st -> - st { sKeys = (sKeys st) { - kReadCS = kCachedCS (sKeys st), - kReadMacKey = kCachedReadMacKey (sKeys st), - kReadKey = kCachedReadKey (sKeys st) - } } - -flushCipherSuiteWrite :: PartnerId -> Modify (HandshakeState h g) -flushCipherSuiteWrite i = modifyState i $ \st -> - st { sKeys = (sKeys st) { - kWriteCS = kCachedCS (sKeys st), - kWriteMacKey = kCachedWriteMacKey (sKeys st), - kWriteKey = kCachedWriteKey (sKeys st) - } } - -getWBuf :: PartnerId -> HandshakeState h g -> (ContentType, BS.ByteString) -getWBuf i = wBuffer . fromJust' "getWriteBuffer" . lookup i . states - -setWBuf :: PartnerId -> (ContentType, BS.ByteString) -> Modify (HandshakeState h g) -setWBuf i = modifyState i . \bs st -> st{ wBuffer = bs } - -getReadSN, getWriteSN :: PartnerId -> HandshakeState h g -> Word64 -getReadSN i = readSN . fromJust . lookup i . states -getWriteSN i = writeSN . fromJust . lookup i . states - -succReadSN, succWriteSN :: PartnerId -> Modify (HandshakeState h g) -succReadSN i = modifyState i $ \s -> s{ readSN = succ $ readSN s } -succWriteSN i = modifyState i $ \s -> s{ writeSN = succ $ writeSN s } - -resetReadSN, resetWriteSN :: PartnerId -> Modify (HandshakeState h g) -resetReadSN i = modifyState i $ \s -> s{ readSN = 0 } -resetWriteSN i = modifyState i $ \s -> s{ writeSN = 0 } - -type Modify s = s -> s - -fromJust' :: String -> Maybe a -> a -fromJust' _ (Just x) = x -fromJust' msg _ = error msg diff --git a/src/Network/PeyoTLS/Types.hs b/src/Network/PeyoTLS/Types.hs deleted file mode 100644 --- a/src/Network/PeyoTLS/Types.hs +++ /dev/null @@ -1,266 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Network.PeyoTLS.Types ( - Handshake(..), HandshakeItem(..), - ClientHello(..), ServerHello(..), SessionId(..), - CipherSuite(..), KeyEx(..), BulkEnc(..), - CompMethod(..), Extension(..), isRenegoInfo, emptyRenegoInfo, - ServerKeyEx(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..), - CertReq(..), certReq, ClCertType(..), - SignAlg(..), HashAlg(..), - ServerHelloDone(..), ClientKeyEx(..), Epms(..), - DigitallySigned(..), Finished(..), - ChangeCipherSpec(..), ) 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 ( - CertReq(..), certReq, ClCertType(..), - ClientKeyEx(..), DigitallySigned(..) ) - -data Handshake - = HHelloReq - | HClientHello ClientHello | HServerHello ServerHello - | HCertificate X509.CertificateChain | HServerKeyEx BS.ByteString - | HCertificateReq CertReq | HServerHelloDone - | HCertVerify DigitallySigned | HClientKeyEx ClientKeyEx - | HFinished BS.ByteString | HRaw Type BS.ByteString - | HCCSpec - 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 -encodeH HCCSpec = B.encode ChangeCipherSpec - -class HandshakeItem hi where - fromHandshake :: Handshake -> Maybe hi; toHandshake :: hi -> Handshake - -instance HandshakeItem Handshake where - fromHandshake = Just; toHandshake = id - -instance HandshakeItem ChangeCipherSpec where - fromHandshake HCCSpec = Just ChangeCipherSpec - fromHandshake _ = Nothing - toHandshake ChangeCipherSpec = HCCSpec - toHandshake (ChangeCipherSpecRaw _) = error "bad" - -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 ServerKeyEx = 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 ServerKeyEx 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 ServerKeyEx 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 CertReq where - fromHandshake (HCertificateReq cr) = Just cr - fromHandshake _ = Nothing - toHandshake = HCertificateReq - -instance HandshakeItem ServerHelloDone where - fromHandshake HServerHelloDone = Just SHDone - fromHandshake _ = Nothing - toHandshake _ = HServerHelloDone - -instance HandshakeItem DigitallySigned where - fromHandshake (HCertVerify ds) = Just ds - fromHandshake _ = Nothing - toHandshake = HCertVerify - -instance HandshakeItem ClientKeyEx 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 :: ClientKeyEx -> Maybe Epms -ckeToEpms (ClientKeyEx cke) = case B.runBytableM (B.take =<< B.take 2) cke of - Right (e, "") -> Just $ Epms e - _ -> Nothing - -epmsToCke :: Epms -> ClientKeyEx -epmsToCke (Epms epms) = ClientKeyEx $ 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 = SHDone 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] - -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] - -isRenegoInfo :: Extension -> Bool -isRenegoInfo (ERenegoInfo _) = True -isRenegoInfo _ = False - -emptyRenegoInfo :: Extension -emptyRenegoInfo = ERenegoInfo ""