peyotls 0.0.0.22 → 0.0.0.23
raw patch · 15 files changed
+769/−629 lines, 15 filesPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
API changes (from Hackage documentation)
+ Network.PeyoTLS.Client: setCertificateStore :: (ValidateHandle h, CPRG g) => TlsHandle h g -> CertificateStore -> TlsM h g ()
+ Network.PeyoTLS.Client: setCipherSuites :: (ValidateHandle h, CPRG g) => TlsHandle h g -> [CipherSuite] -> TlsM h g ()
+ Network.PeyoTLS.Client: setKeyCerts :: (ValidateHandle h, CPRG g) => TlsHandle h g -> [(CertSecretKey, CertificateChain)] -> TlsM h g ()
+ Network.PeyoTLS.Server: setCertificateStore :: (ValidateHandle h, CPRG g) => TlsHandle h g -> Maybe CertificateStore -> TlsM h g ()
+ Network.PeyoTLS.Server: setCipherSuites :: (ValidateHandle h, CPRG g) => TlsHandle h g -> [CipherSuite] -> TlsM h g ()
+ Network.PeyoTLS.Server: setKeyCerts :: (ValidateHandle h, CPRG g) => TlsHandle h g -> [(CertSecretKey, CertificateChain)] -> TlsM h g ()
Files
- data/certs/geotrust_global_ca.pem +20/−0
- examples/secretServer.hs +52/−0
- peyotls.cabal +4/−2
- src/Network/PeyoTLS/Base.hs +189/−414
- src/Network/PeyoTLS/CertSecretKey.hs +10/−1
- src/Network/PeyoTLS/Certificate.hs +12/−12
- src/Network/PeyoTLS/Client.hs +70/−26
- src/Network/PeyoTLS/Ecdsa.hs +16/−2
- src/Network/PeyoTLS/Handle.hs +60/−53
- src/Network/PeyoTLS/Monad.hs +2/−2
- src/Network/PeyoTLS/Run.hs +194/−57
- src/Network/PeyoTLS/Server.hs +101/−32
- src/Network/PeyoTLS/State.hs +2/−10
- src/Network/PeyoTLS/Types.hs +35/−17
- test/testReneg.hs +2/−1
+ data/certs/geotrust_global_ca.pem view
@@ -0,0 +1,20 @@+-----BEGIN CERTIFICATE----- +MIIDVDCCAjygAwIBAgIDAjRWMA0GCSqGSIb3DQEBBQUAMEIxCzAJBgNVBAYTAlVT +MRYwFAYDVQQKEw1HZW9UcnVzdCBJbmMuMRswGQYDVQQDExJHZW9UcnVzdCBHbG9i +YWwgQ0EwHhcNMDIwNTIxMDQwMDAwWhcNMjIwNTIxMDQwMDAwWjBCMQswCQYDVQQG +EwJVUzEWMBQGA1UEChMNR2VvVHJ1c3QgSW5jLjEbMBkGA1UEAxMSR2VvVHJ1c3Qg +R2xvYmFsIENBMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA2swYYzD9 +9BcjGlZ+W988bDjkcbd4kdS8odhM+KhDtgPpTSEHCIjaWC9mOSm9BXiLnTjoBbdq +fnGk5sRgprDvgOSJKA+eJdbtg/OtppHHmMlCGDUUna2YRpIuT8rxh0PBFpVXLVDv +iS2Aelet8u5fa9IAjbkU+BQVNdnARqN7csiRv8lVK83Qlz6cJmTM386DGXHKTubU +1XupGc1V3sjs0l44U+VcT4wt/lAjNvxm5suOpDkZALeVAjmRCw7+OC7RHQWa9k0+ +bw8HHa8sHo9gOeL6NlMTOdReJivbPagUvTLrGAMoUgRx5aszPeE4uwc2hGKceeoW +MPRfwCvocWvk+QIDAQABo1MwUTAPBgNVHRMBAf8EBTADAQH/MB0GA1UdDgQWBBTA +ephojYn7qwVkDBF9qn1luMrMTjAfBgNVHSMEGDAWgBTAephojYn7qwVkDBF9qn1l +uMrMTjANBgkqhkiG9w0BAQUFAAOCAQEANeMpauUvXVSOKVCUn5kaFOSPeCpilKIn +Z57QzxpeR+nBsqTP3UEaBU6bS+5Kb1VSsyShNwrrZHYqLizz/Tt1kL/6cdjHPTfS +tQWVYrmm3ok9Nns4d0iXrKYgjy6myQzCsplFAMfOEVEiIuCl6rYVSAlk6l5PdPcF +PseKUgzbFbS9bZvlxrFUaKnjaZC2mqUPuLk/IH2uSrW4nOQdtqvmlKXBx4Ot2/Un +hw4EbNX/3aBd7YdStysVAq45pmp06drE57xNNB6pXE0zX5IJL4hmXXeXxx12E6nV +5fEWCRE11azbJHFwLJhWC9kXtNHjUStedejV0NxPNO3CBWaAocvmMw== +-----END CERTIFICATE-----
+ examples/secretServer.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import Control.Applicative+import Control.Monad+import "monads-tf" Control.Monad.State+import Control.Concurrent+import Data.HandleLike+import System.Environment+import Network+import Network.PeyoTLS.Server+import Network.PeyoTLS.ReadFile+import "crypto-random" Crypto.Random++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC++main :: IO ()+main = do+ d : _ <- getArgs+ k <- readKey $ d ++ "/localhost.sample_key"+ c <- readCertificateChain [d ++ "/localhost.sample_crt"]+ ca <- readCertificateStore [d ++ "/cacert.pem"]+ g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG+ soc <- listenOn $ PortNumber 443+ void . (`runStateT` g0) . forever $ do+ (h, _, _) <- liftIO $ accept soc+ g <- StateT $ return . cprgFork+ liftIO . forkIO . (`run` g) $ do+ p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(k, c)]+ Nothing+ g <- hlGetLine p+ doUntil BS.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn+ liftIO $ BSC.putStrLn g+ liftIO $ print $ "secret" `BS.isInfixOf` g+ if "secret" `BS.isInfixOf` g+ then do setCertificateStore p $ Just ca+ renegotiate p+ hlPut p $ BS.concat [+ "HTTP/1.1 200 OK\r\n",+ "Transfer-Encoding: chunked\r\n",+ "Content-Type: text/plain\r\n\r\n",+ "6\r\nSecret0\r\n\r\n" ]+ else do hlPut p $ BS.concat [+ "HTTP/1.1 200 OK\r\n",+ "Transfer-Encoding: chunked\r\n",+ "Content-Type: text/plain\r\n\r\n",+ "5\r\nHello0\r\n\r\n" ]+ hlClose p++doUntil :: Monad m => (a -> Bool) -> m a -> m [a]+doUntil p rd = rd >>= \x ->+ (if p x then return . (: []) else (`liftM` doUntil p rd) . (:)) x
peyotls.cabal view
@@ -2,7 +2,7 @@ cabal-version: >= 1.8 name: peyotls-version: 0.0.0.22+version: 0.0.0.23 stability: Experimental author: Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer: Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -260,10 +260,12 @@ examples/eccClient.hs examples/debugServer.hs examples/renegServer.hs+ examples/secretServer.hs data-dir: data data-files: certs/cacert.pem,+ certs/geotrust_global_ca.pem, certs/localhost.sample_key, certs/localhost.sample_crt, certs/localhost_ecdsa.sample_key,@@ -280,7 +282,7 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/peyotls.git- tag: peyotls-0.0.0.22+ tag: peyotls-0.0.0.23 library hs-source-dirs: src
src/Network/PeyoTLS/Base.hs view
@@ -1,62 +1,42 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies, PackageImports,- TupleSections #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, PackageImports #-} -module Network.PeyoTLS.Base ( Extension(..),- makeEcdsaPubKey,- ClSignPublicKey(..), ClSignSecretKey(..),- SvSignPublicKey(..),- PeyotlsM, eRenegoInfo,- debug, generateKs, blindSign, HM.CertSecretKey(..), isEcdsaKey, isRsaKey,- HM.TlsM, HM.run, HM.HandshakeM, HM.execHandshakeM, HM.rerunHandshakeM,- HM.withRandom, HM.randomByteString,- HM.TlsHandle_, HM.names,- readHandshake, getChangeCipherSpec,- writeHandshake, putChangeCipherSpec,- writeHandshakeNH,- HM.ValidateHandle(..), HM.handshakeValidate,- HM.Alert(..), HM.AlertLevel(..), HM.AlertDesc(..),- ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),- ServerHelloDone(..),- ClientHello(..), ServerHello(..), SessionId(..),+module Network.PeyoTLS.Base (+ PeyotlsM, TlsM, run, SettingsS,+ adGet, adGetLine, adGetContent,+ HandshakeM, execHandshakeM, rerunHandshakeM,+ getSettingsC, setSettingsC, getSettingsS, setSettingsS,+ withRandom, randomByteString, flushAppData,+ AlertLevel(..), AlertDesc(..), throwError,+ debugCipherSuite, debug,+ ValidateHandle(..), handshakeValidate, validateAlert,+ TlsHandleBase, names,+ CertSecretKey(..), isRsaKey, isEcdsaKey,+ readHandshake, writeHandshake,+ getChangeCipherSpec, putChangeCipherSpec,+ Handshake(HHelloReq),+ ClientHello(..), ServerHello(..), SessionId(..), Extension(..),+ isRenegoInfo, emptyRenegoInfo, CipherSuite(..), KeyEx(..), BulkEnc(..), CompMethod(..), HashAlg(..), SignAlg(..),- HM.getCipherSuite, HM.setCipherSuite,- CertReq(..), certificateRequest, ClientCertificateType(..), SecretKey(..),- ClientKeyExchange(..), Epms(..),- HM.generateKeys,- HM.encryptRsa, HM.decryptRsa, HM.rsaPadding, HM.debugCipherSuite,- DigitallySigned(..), HM.handshakeHash, HM.flushCipherSuite,- HM.Side(..), HM.RW(..), finishedHash,- DhParam(..), dh3072Modp, secp256r1, HM.throwError,- HM.getClientFinished, HM.getServerFinished,- checkClientRenego, makeClientRenego,- checkServerRenego, makeServerRenego,- Finished(..),- HM.ContentType(CTAlert, CTHandshake, CTAppData),- Handshake(..),- HM.tlsHandle,- hlGetRn, hlGetLineRn_, hlGetLineRn, hlGetContentRn_,- hlGetContentRn,-- HM.getSettings, HM.setSettings, HM.SettingsS,- getSettingsC, setSettingsC,- HM.flushAppData_,- flushAppData,- HM.pushAdBufH,-- validateAlert,- ) where+ getCipherSuite, setCipherSuite,+ checkClRenego, checkSvRenego, makeClRenego, makeSvRenego,+ ServerKeyEx(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),+ SvSignSecretKey(..), SvSignPublicKey(..),+ CertReq(..), certReq, ClCertType(..),+ ServerHelloDone(..),+ ClientKeyEx(..), Epms(..), generateKeys,+ DigitallySigned(..), ClSignPublicKey(..), ClSignSecretKey(..),+ handshakeHash,+ RW(..), flushCipherSuite,+ Side(..), finishedHash,+ DhParam(..), makeEcdsaPubKey ) where -import Control.Applicative-import Control.Arrow (first, second, (***))-import Control.Monad (liftM)+import Control.Arrow (first)+import Control.Monad (unless, liftM, ap) import "monads-tf" Control.Monad.State (gets, lift)-import qualified "monads-tf" Control.Monad.Error as E-import Data.Word (Word8)+import Data.Bits (shiftR) import Data.HandleLike (HandleLike(..)) import System.IO (Handle)-import Numeric (readHex) import "crypto-random" Crypto.Random (CPRG, SystemRNG, cprgGenerate) import qualified Data.ByteString as BS@@ -67,8 +47,8 @@ import qualified Codec.Bytable.BigEndian as B import qualified Crypto.Hash.SHA1 as SHA1 import qualified Crypto.Hash.SHA256 as SHA256-import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.RSA.Prim as RSA+import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.Types.PubKey.DH as DH import qualified Crypto.PubKey.DH as DH import qualified Crypto.Types.PubKey.ECC as ECC@@ -76,125 +56,98 @@ import qualified Crypto.Types.PubKey.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Data.X509 as X509-import qualified Data.X509.Validation as X509-import qualified Data.X509.CertificateStore as X509+import qualified Crypto.PubKey.HashDescr as HD+import qualified Crypto.PubKey.RSA.PKCS15 as RSA -import Network.PeyoTLS.Types ( Extension(..),+import Network.PeyoTLS.Types ( Handshake(..), HandshakeItem(..), ClientHello(..), ServerHello(..), SessionId(..), CipherSuite(..), KeyEx(..), BulkEnc(..),- CompMethod(..),- ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),- CertReq(..), certificateRequest, ClientCertificateType(..),- SignAlg(..), HashAlg(..),- ServerHelloDone(..), ClientKeyExchange(..), Epms(..),- DigitallySigned(..), Finished(..) )-import qualified Network.PeyoTLS.Run as HM (- TlsM, run, HandshakeM, execHandshakeM, rerunHandshakeM,- withRandom, randomByteString,- ValidateHandle(..), handshakeValidate,- TlsHandle_(..), ContentType(..),- names,- getCipherSuite, setCipherSuite, flushCipherSuite, debugCipherSuite,- tlsGetContentType, tlsGet, tlsPut, tlsPutNH,- generateKeys, encryptRsa, decryptRsa, rsaPadding,- Alert(..), AlertLevel(..), AlertDesc(..),- Side(..), RW(..), handshakeHash, finishedHash, throwError,- hlPut_, tGetLine, tGetContent, tlsGet_, tlsPut_,- tGetLine_, tGetContent_, tlsGet__,- hlDebug_, hlClose_,- getClientFinished, setClientFinished,- getServerFinished, setServerFinished,- resetSequenceNumber,-- getSettings, setSettings, SettingsS,- getSettingsC, setSettingsC,- flushAppData_,- getAdBuf,- setAdBuf,- pushAdBufH,-- CertSecretKey(..),- )-import Network.PeyoTLS.Ecdsa (blindSign, generateKs)+ CompMethod(..), Extension(..), isRenegoInfo, emptyRenegoInfo,+ ServerKeyEx(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),+ CertReq(..), certReq, ClCertType(..), SignAlg(..), HashAlg(..),+ ServerHelloDone(..), ClientKeyEx(..), Epms(..),+ DigitallySigned(..), ChangeCipherSpec(..), Finished(..) )+import qualified Network.PeyoTLS.Run as RUN (finishedHash)+import Network.PeyoTLS.Run (+ TlsM, run, TlsHandleBase(..), names,+ hsGet, hsPut, updateHash, ccsGet, ccsPut,+ adGet, adGetLine, adGetContent,+ HandshakeM, execHandshakeM, rerunHandshakeM,+ withRandom, randomByteString, flushAppData,+ SettingsS, getSettingsS, setSettingsS,+ getSettingsC, setSettingsC,+ getCipherSuite, setCipherSuite,+ CertSecretKey(..), isRsaKey, isEcdsaKey,+ getClFinished, getSvFinished, setClFinished, setSvFinished,+ RW(..), flushCipherSuite, generateKeys,+ Side(..), handshakeHash, -- finishedHash,+ ValidateHandle(..), handshakeValidate, validateAlert,+ AlertLevel(..), AlertDesc(..), debugCipherSuite, throwError )+import Network.PeyoTLS.Ecdsa (blindSign, makeKs, makeEcdsaPubKey) --- import Network.PeyoTLS.CertSecretKey+moduleName :: String+moduleName = "Network.PeyoTLS.Base" -type PeyotlsM = HM.TlsM Handle SystemRNG+type PeyotlsM = TlsM Handle SystemRNG -debug :: (HandleLike h, Show a) => DebugLevel h -> a -> HM.HandshakeM h g ()+debug :: (HandleLike h, Show a) => DebugLevel h -> a -> HandshakeM h g () debug p x = do- h <- gets $ HM.tlsHandle . fst+ h <- gets $ tlsHandle . fst lift . lift . lift . hlDebug h p . BSC.pack . (++ "\n") $ show x -readHandshake :: (HandleLike h, CPRG g, HandshakeItem hi) => HM.HandshakeM h g hi+readHandshake :: (HandleLike h, CPRG g, HandshakeItem hi) => HandshakeM h g hi readHandshake = do- cnt <- readContent HM.tlsGet =<< HM.tlsGetContentType- hs <- case cnt of- CHandshake HHelloReq -> readHandshake- CHandshake hs -> return hs- _ -> HM.throwError- HM.ALFatal HM.ADUnexpectedMessage $- "HandshakeBase.readHandshake: not handshake: " ++ show cnt- case fromHandshake hs of- Just i -> return i- _ -> HM.throwError- HM.ALFatal HM.ADUnexpectedMessage $- "HandshakeBase.readHandshake: type mismatch " ++ show hs--writeHandshake, writeHandshakeNH ::- (HandleLike h, CPRG g, HandshakeItem hi) => hi -> HM.HandshakeM h g ()-writeHandshake = uncurry HM.tlsPut . encodeContent . CHandshake . toHandshake-writeHandshakeNH = uncurry HM.tlsPutNH . encodeContent . CHandshake . toHandshake--data ChangeCipherSpec = ChangeCipherSpec | ChangeCipherSpecRaw Word8 deriving Show+ bs <- hsGet+ case B.decode bs of+ Right HHelloReq -> readHandshake+ Right hs -> case fromHandshake hs of+ Just i -> updateHash bs >> return i+ _ -> throwError ALFatal ADUnexpectedMessage $+ moduleName ++ ".readHandshake: " ++ show hs+ Left em -> throwError ALFatal ADInternalError $+ moduleName ++ ".readHandshake: " ++ em -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]+writeHandshake:: (HandleLike h, CPRG g, HandshakeItem hi) => hi -> HandshakeM h g ()+writeHandshake hi =+ hsPut bs >> case hs of HHelloReq -> return (); _ -> updateHash bs+ where hs = toHandshake hi; bs = B.encode hs -getChangeCipherSpec :: (HandleLike h, CPRG g) => HM.HandshakeM h g ()+getChangeCipherSpec :: (HandleLike h, CPRG g) => HandshakeM h g () getChangeCipherSpec = do- cnt <- readContent HM.tlsGet =<< HM.tlsGetContentType- case cnt of- CCCSpec ChangeCipherSpec -> return ()- _ -> HM.throwError- HM.ALFatal HM.ADUnexpectedMessage $- "HandshakeBase.getChangeCipherSpec: " ++- "not change cipher spec: " ++- show cnt- HM.resetSequenceNumber HM.Read+ w <- ccsGet+ case B.decode $ BS.pack [w] of+ Right ChangeCipherSpec -> return ()+ _ -> throwError ALFatal ADUnexpectedMessage $+ moduleName ++ ".getChangeCipherSpec: not change cipher spec" -putChangeCipherSpec :: (HandleLike h, CPRG g) => HM.HandshakeM h g ()-putChangeCipherSpec = do- uncurry HM.tlsPut . encodeContent $ CCCSpec ChangeCipherSpec- HM.resetSequenceNumber HM.Write+putChangeCipherSpec :: (HandleLike h, CPRG g) => HandshakeM h g ()+putChangeCipherSpec = ccsPut . (\[w] -> w) . BS.unpack $ B.encode ChangeCipherSpec -data Content = CCCSpec ChangeCipherSpec | CAlert Word8 Word8 | CHandshake Handshake- deriving Show+finishedHash :: (HandleLike h, CPRG g) => Side -> HandshakeM h g Finished+finishedHash s = Finished `liftM` do+ fh <- RUN.finishedHash s+ case s of Client -> setClFinished fh; Server -> setSvFinished fh+ return fh -readContent :: Monad m => (Bool -> Int -> m BS.ByteString) -> HM.ContentType -> m Content-readContent rd HM.CTCCSpec =- (CCCSpec . either error id . B.decode) `liftM` rd True 1-readContent rd HM.CTAlert =- ((\[al, ad] -> CAlert al ad) . BS.unpack) `liftM` rd True 2-readContent rd HM.CTHandshake = CHandshake `liftM` do- t <- rd True 1- len <- rd (t /= "\0") 3--- (t, len) <- (,) `liftM` rd True 1 `ap` rd True 3- body <- rd True . either error id $ B.decode len- return . either error id . B.decode $ BS.concat [t, len, body]-readContent _ _ = undefined+checkClRenego, checkSvRenego :: HandleLike h => Extension -> HandshakeM h g ()+checkClRenego (ERenegoInfo ri) = do+ ok <- (ri ==) `liftM` getClFinished+ unless ok . throwError ALFatal ADHsFailure $+ moduleName ++ ".checkClRenego: renego info is not match"+checkClRenego _ = throwError ALFatal ADInternalError $+ moduleName ++ ".checkClRenego: not renego info"+checkSvRenego (ERenegoInfo ri) = do+ ok <- (ri ==) `liftM` (BS.append `liftM` getClFinished `ap` getSvFinished)+ unless ok . throwError ALFatal ADHsFailure $+ moduleName ++ ".checkSvRenego: renego info is not match"+checkSvRenego _ = throwError ALFatal ADInternalError $+ moduleName ++ ".checkSvRenego: not renego info" -encodeContent :: Content -> (HM.ContentType, BS.ByteString)-encodeContent (CCCSpec ccs) = (HM.CTCCSpec, B.encode ccs)-encodeContent (CAlert al ad) = (HM.CTAlert, BS.pack [al, ad])-encodeContent (CHandshake hss) = (HM.CTHandshake, B.encode hss)+makeClRenego, makeSvRenego :: HandleLike h => HandshakeM h g Extension+makeClRenego = ERenegoInfo `liftM` getClFinished+makeSvRenego =+ ERenegoInfo `liftM` (BS.append `liftM` getClFinished `ap` getSvFinished) class DhParam b where type Secret b@@ -208,285 +161,123 @@ type Public DH.Params = DH.PublicNumber generateSecret = flip DH.generatePrivate calculatePublic = DH.calculatePublic- calculateShared ps sn pn = B.encode .- (\(DH.SharedKey s) -> s) $ DH.getShared ps sn pn--dh3072Modp :: DH.Params-dh3072Modp = DH.Params p 2- where [(p, "")] = readHex $- "ffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd1" ++- "29024e088a67cc74020bbea63b139b22514a08798e3404dd" ++- "ef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245" ++- "e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7ed" ++- "ee386bfb5a899fa5ae9f24117c4b1fe649286651ece45b3d" ++- "c2007cb8a163bf0598da48361c55d39a69163fa8fd24cf5f" ++- "83655d23dca3ad961c62f356208552bb9ed529077096966d" ++- "670c354e4abc9804f1746c08ca18217c32905e462e36ce3b" ++- "e39e772c180e86039b2783a2ec07a28fb5c55df06f4c52c9" ++- "de2bcbf6955817183995497cea956ae515d2261898fa0510" ++- "15728e5a8aaac42dad33170d04507a33a85521abdf1cba64" ++- "ecfb850458dbef0a8aea71575d060c7db3970f85a6e1e4c7" ++- "abf5ae8cdb0933d71e8c94e04a25619dcee3d2261ad2ee6b" ++- "f12ffa06d98a0864d87602733ec86a64521f2b18177b200c" ++- "bbe117577a615d6c770988c0bad946e208e24fa074e5ab31" ++- "43db5bfce0fd108e4b82d120a93ad2caffffffffffffffff"+ calculateShared =+ (((B.encode . (\(DH.SharedKey s) -> s)) .) .) . DH.getShared instance DhParam ECC.Curve where type Secret ECC.Curve = Integer type Public ECC.Curve = ECC.Point- generateSecret c = getRangedInteger 32 1 (n - 1)- where n = ECC.ecc_n $ ECC.common_curve c- calculatePublic cv sn =- ECC.pointMul cv sn . ECC.ecc_g $ ECC.common_curve cv+ generateSecret c = rec+ where+ rec g = let+ (bs, g') = cprgGenerate bl g+ i = either error id $ B.decode bs in+ if 1 <= i && i <= mx then (i, g') else rec g'+ bl = len mx `div` 8 + signum (len mx `mod` 8)+ mx = ECC.ecc_n (ECC.common_curve c) - 1+ len 0 = 0; len i = succ . len $ i `shiftR` 1+ calculatePublic cv sn = ECC.pointMul cv sn . ECC.ecc_g $ ECC.common_curve cv calculateShared cv sn pp = let ECC.Point x _ = ECC.pointMul cv sn pp in B.encode x -getRangedInteger :: CPRG g => Int -> Integer -> Integer -> g -> (Integer, g)-getRangedInteger b mn mx g = let- (n, g') = first (either error id . B.decode) $ cprgGenerate b g in- if mn <= n && n <= mx then (n, g') else getRangedInteger b mn mx g' -secp256r1 :: ECC.Curve-secp256r1 = ECC.getCurveByName ECC.SEC_p256r1--finishedHash :: (HandleLike h, CPRG g) => HM.Side -> HM.HandshakeM h g Finished-finishedHash s = (Finished `liftM`) $ do- fh <- HM.finishedHash s- case s of- HM.Client -> HM.setClientFinished fh- HM.Server -> HM.setServerFinished fh- return fh--instance (HandleLike h, CPRG g) => HandleLike (HM.TlsHandle_ h g) where- type HandleMonad (HM.TlsHandle_ h g) = HM.TlsM h g- type DebugLevel (HM.TlsHandle_ h g) = DebugLevel h- hlPut = HM.hlPut_- hlGet = (.) <$> checkAppData <*> ((fst `liftM`) .)- . HM.tlsGet__ . (, undefined)- hlGetLine = ($) <$> checkAppData <*> HM.tGetLine- hlGetContent = ($) <$> checkAppData <*> HM.tGetContent- hlDebug = HM.hlDebug_- hlClose = HM.hlClose_--checkAppData :: (HandleLike h, CPRG g) => HM.TlsHandle_ h g ->- HM.TlsM h g (HM.ContentType, BS.ByteString) -> HM.TlsM h g BS.ByteString-checkAppData t m = m >>= \cp -> case cp of- (HM.CTAppData, ad) -> return ad- (HM.CTAlert, "\SOH\NUL") -> do- _ <- HM.tlsPut_ (t, undefined) HM.CTAlert "\SOH\NUL"- E.throwError "TlsHandle_.checkAppData: EOF"- (HM.CTHandshake, hs) -> do- lift . lift $ hlDebug (HM.tlsHandle t) "critical" "renegotiation?\n"- lift . lift . hlDebug (HM.tlsHandle t) "critical" . BSC.pack- . (++ "\n") $ show hs- lift . lift . hlDebug (HM.tlsHandle t) "critical" . BSC.pack- . (++ "\n") $ show (B.decode hs :: Either String Handshake)- return ""- _ -> do _ <- HM.tlsPut_ (t, undefined) HM.CTAlert "\2\10"- E.throwError "TlsHandle_.checkAppData: not application data"--hlGetRn_ :: (HM.ValidateHandle h, CPRG g) => (HM.TlsHandle_ h g -> HM.TlsM h g ()) ->- HM.TlsHandle_ h g -> Int -> HM.TlsM h g BS.ByteString-hlGetRn_ rh = (.) <$> checkAppData <*> ((fst `liftM`) .) . HM.tlsGet_ rh- . (, undefined)--hlGetLineRn_, hlGetContentRn_ :: (HM.ValidateHandle h, CPRG g) =>- (HM.TlsHandle_ h g -> HM.TlsM h g ()) -> HM.TlsHandle_ h g -> HM.TlsM h g BS.ByteString-hlGetLineRn_ rh = ($) <$> checkAppData <*> HM.tGetLine_ rh-hlGetContentRn_ rh = ($) <$> checkAppData <*> HM.tGetContent_ rh--hlGetRn :: (HM.ValidateHandle h, CPRG g) => (HM.TlsHandle_ h g -> HM.TlsM h g ()) ->- HM.TlsHandle_ h g -> Int -> HM.TlsM h g BS.ByteString-hlGetRn rn t n = do- bf <- HM.getAdBuf t- if BS.length bf >= n- then do let (ret, rest) = BS.splitAt n bf- HM.setAdBuf t rest- return ret- else (bf `BS.append`) `liftM` hlGetRn_ rn t (n - BS.length bf)--hlGetLineRn :: (HM.ValidateHandle h, CPRG g) =>- (HM.TlsHandle_ h g -> HM.TlsM h g ()) -> HM.TlsHandle_ h g ->- HM.TlsM h g BS.ByteString-hlGetLineRn rn t = do- bf <- HM.getAdBuf t- if '\n' `BSC.elem` bf || '\r' `BSC.elem` bf- then do let (ret, rest) = splitOneLine bf- HM.setAdBuf t $ BS.tail rest- return ret- else (bf `BS.append`) `liftM` hlGetLineRn_ rn t--splitOneLine :: BS.ByteString -> (BS.ByteString, BS.ByteString)-splitOneLine bs = case BSC.span (/= '\r') bs of- (_, "") -> second BS.tail $ BSC.span (/= '\n') bs- (l, ls) -> (l, dropRet ls)--dropRet :: BS.ByteString -> BS.ByteString-dropRet bs = case BSC.uncons bs of- Just ('\r', bs') -> case BSC.uncons bs' of- Just ('\n', bs'') -> bs''- _ -> bs'- _ -> bs--hlGetContentRn :: (HM.ValidateHandle h, CPRG g) =>- (HM.TlsHandle_ h g -> HM.TlsM h g ()) ->- HM.TlsHandle_ h g -> HM.TlsM h g BS.ByteString-hlGetContentRn rn t = do- bf <- HM.getAdBuf t- if BS.null bf- then hlGetContentRn_ rn t- else do HM.setAdBuf t ""- return bf--flushAppData :: (HandleLike h, CPRG g) => HM.HandshakeM h g Bool-flushAppData = uncurry (>>) . (HM.pushAdBufH *** return) =<< HM.flushAppData_--isEcdsaKey :: HM.CertSecretKey -> Bool-isEcdsaKey (HM.EcdsaKey _) = True-isEcdsaKey _ = False--isRsaKey :: HM.CertSecretKey -> Bool-isRsaKey (HM.RsaKey _) = True-isRsaKey _ = False--eRenegoInfo :: Extension -> Maybe BS.ByteString-eRenegoInfo (ERenegoInfo ri) = Just ri-eRenegoInfo _ = Nothing--checkClientRenego, checkServerRenego ::- HandleLike h => BS.ByteString -> HM.HandshakeM h g ()-checkClientRenego cf = (cf ==) `liftM` HM.getClientFinished >>= \ok ->- E.unless ok . HM.throwError HM.ALFatal HM.ADHsFailure $- "Network.PeyoTLS.Base.checkClientRenego: bad renegotiation"-checkServerRenego ri = do- cf <- HM.getClientFinished- sf <- HM.getServerFinished- E.unless (ri == cf `BS.append` sf) $ HM.throwError- HM.ALFatal HM.ADHsFailure- "Network.PeyoTLS.Base.checkServerRenego: bad renegotiation"--makeClientRenego, makeServerRenego :: HandleLike h => HM.HandshakeM h g Extension-makeClientRenego = ERenegoInfo `liftM` HM.getClientFinished-makeServerRenego = ERenegoInfo `liftM`- (BS.append `liftM` HM.getClientFinished `E.ap` HM.getServerFinished)--validateAlert :: [X509.FailedReason] -> HM.AlertDesc-validateAlert vr- | X509.UnknownCA `elem` vr = HM.ADUnknownCa- | X509.Expired `elem` vr = HM.ADCertificateExpired- | X509.InFuture `elem` vr = HM.ADCertificateExpired- | otherwise = HM.ADCertificateUnknown--type SettingsC = (- [CipherSuite],- [(HM.CertSecretKey, X509.CertificateChain)],- X509.CertificateStore )--getSettingsC :: HandleLike h => HM.HandshakeM h g SettingsC-getSettingsC = do- (css, crts, mcs) <- HM.getSettingsC- case mcs of- Just cs -> return (css, crts, cs)- _ -> HM.throwError HM.ALFatal HM.ADInternalError- "Network.PeyoTLS.Base.getSettingsC"--setSettingsC :: HandleLike h => SettingsC -> HM.HandshakeM h g ()-setSettingsC (css, crts, cs) = HM.setSettingsC (css, crts, Just cs)--moduleName :: String-moduleName = "Network.PeyoTLS.Base"+sha1, sha256 :: ASN1.ASN1+sha1 = ASN1.OID [1, 3, 14, 3, 2, 26]+sha256 = ASN1.OID [2, 16, 840, 1, 101, 3, 4, 2, 1] -decodePoint :: BS.ByteString -> ECC.Point-decodePoint s = case BS.uncons s of- Just (4, p) -> let (x, y) = BS.splitAt 32 p in ECC.Point- (either error id $ B.decode x)- (either error id $ B.decode y)- _ -> error $ moduleName ++ ".decodePoint: not implemented point"+padding :: RSA.PublicKey -> BS.ByteString -> BS.ByteString+padding pk bs = case RSA.padSignature (RSA.public_size pk) $+ HD.digestToASN1 HD.hashDescrSHA256 bs of+ Left m -> error $ show m; Right pd -> pd class SvSignPublicKey pk where- svpAlgorithm :: pk -> SignAlg- verify :: HashAlg -> pk -> BS.ByteString -> BS.ByteString -> Bool+ sspAlgorithm :: pk -> SignAlg+ ssVerify :: HashAlg -> pk -> BS.ByteString -> BS.ByteString -> Bool instance SvSignPublicKey RSA.PublicKey where- svpAlgorithm _ = Rsa- verify = rsaVerify--rsaVerify :: HashAlg -> RSA.PublicKey -> BS.ByteString -> BS.ByteString -> Bool-rsaVerify ha pk sn m = let- (hs, oid0) = case ha of- Sha1 -> (SHA1.hash, ASN1.OID [1, 3, 14, 3, 2, 26])- Sha256 -> (SHA256.hash, ASN1.OID [2, 16, 840, 1, 101, 3, 4, 2, 1])- _ -> error "not implemented"- (o, oid) = case ASN1.decodeASN1' ASN1.DER . BS.tail- . BS.dropWhile (== 255) . BS.drop 2 $ RSA.ep pk sn of- Right [ASN1.Start ASN1.Sequence,- ASN1.Start ASN1.Sequence, oid_, ASN1.Null, ASN1.End ASN1.Sequence,- ASN1.OctetString o_, ASN1.End ASN1.Sequence ] -> (o_, oid_)- e -> error $ show e in- oid == oid0 && o == hs m+ sspAlgorithm _ = Rsa+ ssVerify ha pk sn m = oid == oid0 && e == hs m+ where+ (hs, oid0) = case ha of+ Sha1 -> (SHA1.hash, sha1); Sha256 -> (SHA256.hash, sha256)+ _ -> error $ moduleName ++ ": RSA.PublicKey.ssVerify"+ (e, oid) = case ASN1.decodeASN1' ASN1.DER . BS.tail+ . BS.dropWhile (== 255) . BS.drop 2 $ RSA.ep pk sn of+ Right [ASN1.Start ASN1.Sequence,+ ASN1.Start ASN1.Sequence,+ i, ASN1.Null, ASN1.End ASN1.Sequence,+ ASN1.OctetString o,+ ASN1.End ASN1.Sequence ] -> (o, i)+ em -> error $+ moduleName ++ ": RSA.PublicKey.ssVerify" ++ show em instance SvSignPublicKey ECDSA.PublicKey where- svpAlgorithm _ = Ecdsa- verify Sha1 pk = ECDSA.verify SHA1.hash pk . either error id . B.decode- verify Sha256 pk = ECDSA.verify SHA256.hash pk . either error id . B.decode- verify _ _ = error "TlsClient: ECDSA.PublicKey.verify: not implemented"+ sspAlgorithm _ = Ecdsa+ ssVerify Sha1 pk = ECDSA.verify SHA1.hash pk . either error id . B.decode+ ssVerify Sha256 pk =+ ECDSA.verify SHA256.hash pk . either error id . B.decode+ ssVerify _ _ = error $ moduleName ++ ": ECDSA.PublicKey.verify" -class SecretKey sk where+class SvSignSecretKey sk where type Blinder sk+ sssAlgorithm :: sk -> SignAlg generateBlinder :: CPRG g => sk -> g -> (Blinder sk, g)- sign :: HashAlg -> Blinder sk -> sk -> BS.ByteString -> BS.ByteString- signatureAlgorithm :: sk -> SignAlg+ ssSign :: sk -> HashAlg -> Blinder sk -> BS.ByteString -> BS.ByteString -instance SecretKey RSA.PrivateKey where+instance SvSignSecretKey RSA.PrivateKey where type Blinder RSA.PrivateKey = RSA.Blinder- generateBlinder sk rng =- RSA.generateBlinder rng . RSA.public_n $ RSA.private_pub sk- sign hs bl sk bs = let- (h, oid) = first ($ bs) $ case hs of- Sha1 -> (SHA1.hash,- ASN1.OID [1, 3, 14, 3, 2, 26])- Sha256 -> (SHA256.hash,- ASN1.OID [2, 16, 840, 1, 101, 3, 4, 2, 1])- _ -> error $ "HandshakeBase: " ++- "not implemented bulk encryption type"- a = [ASN1.Start ASN1.Sequence,+ sssAlgorithm _ = Rsa+ generateBlinder sk g =+ RSA.generateBlinder g . RSA.public_n $ RSA.private_pub sk+ ssSign sk ha bl m = RSA.dp (Just bl) sk e+ where+ (hs, oid) = first ($ m) $ case ha of+ Sha1 -> (SHA1.hash, sha1); Sha256 -> (SHA256.hash, sha256)+ _ -> error $ moduleName ++ ": RSA.PrivateKey.ssSign"+ b = ASN1.encodeASN1' ASN1.DER [ASN1.Start ASN1.Sequence, ASN1.Start ASN1.Sequence, oid, ASN1.Null, ASN1.End ASN1.Sequence,- ASN1.OctetString h, ASN1.End ASN1.Sequence]- b = ASN1.encodeASN1' ASN1.DER a- pd = BS.concat [ "\x00\x01",- BS.replicate (ps - 3 - BS.length b) 0xff, "\NUL", b ]- ps = RSA.public_size $ RSA.private_pub sk in- RSA.dp (Just bl) sk pd- signatureAlgorithm _ = Rsa+ ASN1.OctetString hs, ASN1.End ASN1.Sequence]+ e = BS.concat ["\0\1", BS.replicate (s - BS.length b) 255, "\0", b]+ s = RSA.public_size (RSA.private_pub sk) - 3 -instance SecretKey ECDSA.PrivateKey where+instance SvSignSecretKey ECDSA.PrivateKey where type Blinder ECDSA.PrivateKey = Integer- generateBlinder _ rng = let- (Right bl, rng') = first B.decode $ cprgGenerate 32 rng in- (bl, rng')- sign ha bl sk = B.encode .- (($) <$> blindSign bl hs sk . generateKs (hs, bls) q x <*> id)+ sssAlgorithm _ = Ecdsa+ generateBlinder _ g = (bl, g') where+ bl = either error id $ B.decode bs; (bs, g') = cprgGenerate 32 g+ ssSign sk ha bl m = B.encode $ blindSign bl hs sk (makeKs (hs, bls) q x m) m+ where (hs, bls) = case ha of- Sha1 -> (SHA1.hash, 64)- Sha256 -> (SHA256.hash, 64)- _ -> error $ "HandshakeBase: " ++- "not implemented bulk encryption type"+ Sha1 -> (SHA1.hash, 64); Sha256 -> (SHA256.hash, 64)+ _ -> error $ moduleName ++ ": ECDSA.PrivateKey.ssSign" q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk x = ECDSA.private_d sk- signatureAlgorithm _ = Ecdsa +class ClSignPublicKey pk where+ cspAlgorithm :: pk -> SignAlg+ csVerify :: pk -> BS.ByteString -> BS.ByteString -> Bool++instance ClSignPublicKey RSA.PublicKey where+ cspAlgorithm _ = Rsa+ csVerify pk s h = RSA.ep pk s == padding pk h++instance ClSignPublicKey ECDSA.PublicKey where+ cspAlgorithm _ = Ecdsa+ csVerify pk = ECDSA.verify id pk . either error id . B.decode+ class ClSignSecretKey sk where+ cssAlgorithm :: sk -> (HashAlg, SignAlg) csSign :: sk -> BS.ByteString -> BS.ByteString- csAlgorithm :: sk -> (HashAlg, SignAlg) instance ClSignSecretKey RSA.PrivateKey where- csSign sk m = let pd = HM.rsaPadding (RSA.private_pub sk) m in RSA.dp Nothing sk pd- csAlgorithm _ = (Sha256, Rsa)+ cssAlgorithm _ = (Sha256, Rsa)+ csSign sk m = RSA.dp Nothing sk $ padding (RSA.private_pub sk) m instance ClSignSecretKey ECDSA.PrivateKey where- csSign sk m = enc $ blindSign 0 id sk (generateKs (SHA256.hash, 64) q x m) m+ cssAlgorithm _ = (Sha256, Ecdsa)+ csSign sk m = enc $ blindSign 0 id sk (makeKs (SHA256.hash, 64) q x m) m where q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk x = ECDSA.private_d sk@@ -494,19 +285,3 @@ ASN1.Start ASN1.Sequence, ASN1.IntVal r, ASN1.IntVal s, ASN1.End ASN1.Sequence]- csAlgorithm _ = (Sha256, Ecdsa)--class ClSignPublicKey pk where- cspAlgorithm :: pk -> SignAlg- csVerify :: pk -> BS.ByteString -> BS.ByteString -> Bool--instance ClSignPublicKey RSA.PublicKey where- cspAlgorithm _ = Rsa- csVerify k s h = RSA.ep k s == HM.rsaPadding k h--instance ClSignPublicKey ECDSA.PublicKey where- cspAlgorithm _ = Ecdsa- csVerify k = ECDSA.verify id k . either error id . B.decode--makeEcdsaPubKey :: ECC.CurveName -> BS.ByteString -> ECDSA.PublicKey-makeEcdsaPubKey c xy = ECDSA.PublicKey (ECC.getCurveByName c) $ decodePoint xy
src/Network/PeyoTLS/CertSecretKey.hs view
@@ -1,4 +1,5 @@-module Network.PeyoTLS.CertSecretKey (CertSecretKey(..)) where+module Network.PeyoTLS.CertSecretKey (+ CertSecretKey(..), isRsaKey, isEcdsaKey ) where import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA@@ -7,3 +8,11 @@ = RsaKey { rsaKey :: RSA.PrivateKey } | EcdsaKey { ecdsaKey :: ECDSA.PrivateKey } deriving Show++isEcdsaKey :: CertSecretKey -> Bool+isEcdsaKey (EcdsaKey _) = True+isEcdsaKey _ = False++isRsaKey :: CertSecretKey -> Bool+isRsaKey (RsaKey _) = True+isRsaKey _ = False
src/Network/PeyoTLS/Certificate.hs view
@@ -2,8 +2,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Network.PeyoTLS.Certificate (- CertReq(..), certificateRequest, ClientCertificateType(..),- ClientKeyExchange(..), DigitallySigned(..)) where+ CertReq(..), certReq, ClCertType(..),+ ClientKeyEx(..), DigitallySigned(..)) where import Control.Applicative ((<$>), (<*>)) import Data.Word (Word8, Word16)@@ -36,12 +36,12 @@ return . X509.CertificateChain $ cs Left (n, err) -> fail $ show n ++ " " ++ err -data CertReq = CertReq [ClientCertificateType] [(HashAlg, SignAlg)] [X509.DistinguishedName]+data CertReq = CertReq [ClCertType] [(HashAlg, SignAlg)] [X509.DistinguishedName] deriving Show -certificateRequest :: [ClientCertificateType] -> [(HashAlg, SignAlg)] ->+certReq :: [ClCertType] -> [(HashAlg, SignAlg)] -> X509.CertificateStore -> CertReq-certificateRequest t a = CertReq t a+certReq t a = CertReq t a . map (X509.certIssuerDN . X509.signedObject . X509.getSigned) . X509.listCertificates @@ -63,23 +63,23 @@ either (fail . show) (return . fst) $ ASN1.fromASN1 a1 return $ CertReq t a n -data ClientCertificateType = CTRsaSign | CTEcdsaSign | CTRaw Word8+data ClCertType = CTRsaSign | CTEcdsaSign | CTRaw Word8 deriving (Show, Eq) -instance B.Bytable ClientCertificateType where+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: ClientCertificateType.decode"+ _ -> Left "Certificate: ClCertType.decode" -data ClientKeyExchange = ClientKeyExchange BS.ByteString deriving Show+data ClientKeyEx = ClientKeyEx BS.ByteString deriving Show -instance B.Bytable ClientKeyExchange where- decode = Right . ClientKeyExchange- encode (ClientKeyExchange epms) = epms+instance B.Bytable ClientKeyEx where+ decode = Right . ClientKeyEx+ encode (ClientKeyEx epms) = epms data DigitallySigned = DigitallySigned (HashAlg, SignAlg) BS.ByteString
src/Network/PeyoTLS/Client.hs view
@@ -1,13 +1,29 @@+{-|++Module : Network.PeyoTLS.Server+Copyright : (c) Yoshikuni Jujo, 2014+License : BSD3+Maintainer : PAF01143@nifty.ne.jp+Stability : Experimental++-}+ {-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-} module Network.PeyoTLS.Client (- PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, renegotiate, names,+ -- * Basic+ PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, names,+ -- * Renegotiation+ renegotiate, setCipherSuites, setKeyCerts, setCertificateStore,+ -- * Cipher Suite CipherSuite(..), KeyEx(..), BulkEnc(..),+ -- * Others ValidateHandle(..), CertSecretKey(..) ) where import Control.Applicative ((<$>), (<*>)) import Control.Monad (when, unless, liftM, ap)-import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import "monads-tf" Control.Monad.Error.Class (strMsg)+import Data.Maybe (fromMaybe) import Data.List (find, intersect) import Data.HandleLike (HandleLike(..)) import System.IO (Handle)@@ -20,42 +36,46 @@ import qualified Crypto.PubKey.DH as DH import qualified Crypto.Types.PubKey.ECC as ECC +import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.RSA.PKCS15 as RSA+import qualified "monads-tf" Control.Monad.Error as E+ import qualified Network.PeyoTLS.Base as BASE (names) import Network.PeyoTLS.Base ( debug, PeyotlsM, TlsM, run, getSettingsC, setSettingsC,- hlGetRn, hlGetLineRn, hlGetContentRn,+ adGet, adGetLine, adGetContent, HandshakeM, execHandshakeM, rerunHandshakeM, withRandom, randomByteString, flushAppData, AlertLevel(..), AlertDesc(..), throwError, ValidateHandle(..), handshakeValidate, validateAlert,- TlsHandle_, CertSecretKey(..),+ TlsHandleBase, CertSecretKey(..), readHandshake, writeHandshake, getChangeCipherSpec, putChangeCipherSpec,- ClientHello(..), ServerHello(..), SessionId(..), eRenegoInfo,+ ClientHello(..), ServerHello(..), SessionId(..), isRenegoInfo, CipherSuite(..), KeyEx(..), BulkEnc(..), CompMethod(..), HashAlg(..), SignAlg(..), setCipherSuite,- checkServerRenego, makeClientRenego,+ checkSvRenego, makeClRenego, ServerKeyExEcdhe(..), ServerKeyExDhe(..), SvSignPublicKey(..),- CertReq(..), ClientCertificateType(..),+ CertReq(..), ClCertType(..), ServerHelloDone(..),- ClientKeyExchange(..), Epms(..), generateKeys, encryptRsa,+ ClientKeyEx(..), Epms(..), generateKeys, -- encryptRsa, DigitallySigned(..), ClSignSecretKey(..), handshakeHash, Side(..), RW(..), finishedHash, flushCipherSuite, DhParam(..), makeEcdsaPubKey ) type PeyotlsHandle = TlsHandle Handle SystemRNG -newtype TlsHandle h g = TlsHandleC { tlsHandleC :: TlsHandle_ h g } deriving Show+newtype TlsHandle h g = TlsHandleC { tlsHandleC :: TlsHandleBase h g } deriving Show instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandle h g) where type HandleMonad (TlsHandle h g) = TlsM h g type DebugLevel (TlsHandle h g) = DebugLevel h hlPut (TlsHandleC t) = hlPut t- hlGet = hlGetRn rehandshake . tlsHandleC- hlGetLine = hlGetLineRn rehandshake . tlsHandleC- hlGetContent = hlGetContentRn rehandshake . tlsHandleC+ hlGet = adGet rehandshake . tlsHandleC+ hlGetLine = adGetLine rehandshake . tlsHandleC+ hlGetContent = adGetContent rehandshake . tlsHandleC hlDebug (TlsHandleC t) = hlDebug t hlClose (TlsHandleC t) = hlClose t @@ -78,7 +98,25 @@ clientHello cscl >>= \cr -> flushAppData >>= flip when (handshake crts ca cr) -rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle_ h g -> TlsM h g ()+setCipherSuites :: (ValidateHandle h, CPRG g) => TlsHandle h g ->+ [CipherSuite] -> TlsM h g ()+setCipherSuites (TlsHandleC t) cscl = rerunHandshakeM t $ do+ (_, crts, cs) <- getSettingsC+ setSettingsC (cscl, crts, cs)++setKeyCerts :: (ValidateHandle h, CPRG g) => TlsHandle h g ->+ [(CertSecretKey, X509.CertificateChain)] -> TlsM h g ()+setKeyCerts (TlsHandleC t) crts = rerunHandshakeM t $ do+ (cscl, _, cs) <- getSettingsC+ setSettingsC (cscl, crts, cs)++setCertificateStore :: (ValidateHandle h, CPRG g) => TlsHandle h g ->+ X509.CertificateStore -> TlsM h g ()+setCertificateStore (TlsHandleC t) cs = rerunHandshakeM t $ do+ (cscl, crts, _) <- getSettingsC+ setSettingsC (cscl, crts, cs)++rehandshake :: (ValidateHandle h, CPRG g) => TlsHandleBase h g -> TlsM h g () rehandshake t = rerunHandshakeM t $ do (cscl, crts, ca) <- getSettingsC handshake crts ca =<< clientHello cscl@@ -89,7 +127,7 @@ cr <- randomByteString 32 ((>>) <$> writeHandshake <*> debug "low") . ClientHello (3, 3) cr (SessionId "") cscl [CompMethodNull]- . Just . (: []) =<< makeClientRenego+ . Just . (: []) =<< makeClRenego return cr handshake :: (ValidateHandle h, CPRG g) =>@@ -116,8 +154,8 @@ CompMethodNull -> return () _ -> throwError ALFatal ADHsFailure $ moduleName ++ ".serverHello: only compression method null"- case listToMaybe . mapMaybe eRenegoInfo $ fromMaybe [] e of- Just ri -> checkServerRenego ri+ case find isRenegoInfo $ fromMaybe [] e of+ Just ri -> checkSvRenego ri _ -> throwError ALFatal ADInsufficientSecurity $ moduleName ++ ".serverHello: require secure renegotiation" setCipherSuite cs@@ -141,17 +179,22 @@ writeHandshake . Epms =<< encryptRsa pk pms finishHandshake crt +encryptRsa :: (HandleLike h, CPRG g) =>+ RSA.PublicKey -> BS.ByteString -> HandshakeM h g BS.ByteString+encryptRsa pk p = either (E.throwError . strMsg . show) return =<<+ withRandom (\g -> RSA.encrypt g pk p)+ dheHandshake :: (ValidateHandle h, CPRG g, KeyExchangeClass ke, Show (Secret ke), Show (Public ke)) => ke -> (BS.ByteString, BS.ByteString) -> [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore -> HandshakeM h g () dheHandshake t rs crts ca = do- cc@(X509.CertificateChain cs) <- readHandshake+ cc@(X509.CertificateChain (c : _)) <- readHandshake vr <- handshakeValidate ca cc unless (null vr) . throwError ALFatal (validateAlert vr) $ moduleName ++ ".succeed: validate failure"- case X509.certPubKey . X509.signedObject . X509.getSigned $ head cs of+ case X509.certPubKey . X509.signedObject $ X509.getSigned c of X509.PubKeyRSA pk -> succeed t pk rs crts X509.PubKeyECDSA cv pt -> succeed t (makeEcdsaPubKey cv pt) rs crts _ -> throwError ALFatal ADHsFailure $@@ -164,14 +207,14 @@ succeed t pk rs@(cr, sr) crts = do (ps, pv, ha, sa, sn) <- serverKeyExchange let _ = ps `asTypeOf` t- unless (sa == svpAlgorithm pk) . throwError ALFatal ADHsFailure $+ unless (sa == sspAlgorithm pk) . throwError ALFatal ADHsFailure $ pre ++ "sign algorithm unmatch"- unless (verify ha pk sn $ BS.concat [cr, sr, B.encode ps, B.encode pv]) .+ unless (ssVerify ha pk sn $ BS.concat [cr, sr, B.encode ps, B.encode pv]) . throwError ALFatal ADDecryptError $ pre ++ "verify failure" crt <- clientCertificate crts sv <- withRandom $ generateSecret ps generateKeys Client rs $ calculateShared ps sv pv- writeHandshake . ClientKeyExchange . B.encode $ calculatePublic ps sv+ writeHandshake . ClientKeyEx . B.encode $ calculatePublic ps sv finishHandshake crt where pre = moduleName ++ ".succeed: " @@ -202,7 +245,7 @@ _ -> throwError ALFatal ADUnknownCa $ moduleName ++ ".clientCertificate: no certificate" -isMatchedCert :: [ClientCertificateType] -> [(HashAlg, SignAlg)] ->+isMatchedCert :: [ClCertType] -> [(HashAlg, SignAlg)] -> [X509.DistinguishedName] -> (CertSecretKey, X509.CertificateChain) -> Bool isMatchedCert ct hsa dn = (&&) <$> csk . fst <*> ccrt . snd where@@ -210,9 +253,10 @@ rsa = CTRsaSign `elem` ct || Rsa `elem` map snd hsa ecdsa = CTEcdsaSign `elem` ct || Ecdsa `elem` map snd hsa csk (RsaKey _) = rsa; csk (EcdsaKey _) = ecdsa- ccrt (X509.CertificateChain cs) =- cpk (X509.certPubKey . obj $ head cs) &&+ 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" cpk X509.PubKeyRSA{} = rsa; cpk X509.PubKeyECDSA{} = ecdsa; cpk _ = False finishHandshake :: (HandleLike h, CPRG g) =>@@ -221,9 +265,9 @@ hs <- handshakeHash case fst <$> crt of Just (RsaKey sk) -> writeHandshake $- DigitallySigned (csAlgorithm sk) $ csSign sk hs+ DigitallySigned (cssAlgorithm sk) $ csSign sk hs Just (EcdsaKey sk) -> writeHandshake $- DigitallySigned (csAlgorithm sk) $ csSign sk hs+ DigitallySigned (cssAlgorithm sk) $ csSign sk hs _ -> return () putChangeCipherSpec >> flushCipherSuite Write writeHandshake =<< finishedHash Client
src/Network/PeyoTLS/Ecdsa.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.PeyoTLS.Ecdsa (blindSign, generateKs) where+module Network.PeyoTLS.Ecdsa (blindSign, makeKs, makeEcdsaPubKey) where import Control.Applicative ((<$>), (<*>)) import Data.Maybe (mapMaybe)@@ -18,6 +18,9 @@ import qualified Data.ASN1.Encoding as ASN1 import qualified Data.ASN1.BinaryEncoding as ASN1 +moduleName :: String+moduleName = "Newtork.PeyoTLS.Ecdsa"+ instance B.Bytable ECDSA.Signature where encode (ECDSA.Signature r s) = ASN1.encodeASN1' ASN1.DER [ ASN1.Start ASN1.Sequence,@@ -55,7 +58,8 @@ -- RFC 6979 -generateKs :: (Hash, Int) -> Integer -> Integer -> BS.ByteString -> [Integer]+makeKs, generateKs :: (Hash, Int) -> Integer -> Integer -> BS.ByteString -> [Integer]+makeKs = generateKs generateKs hsbl@(hs, _) q x m = filter ((&&) <$> (> 0) <*> (< q)) . uncurry (createKs hsbl q) . initializeKV hsbl q x $ hs m @@ -128,3 +132,13 @@ bits2octets :: Integer -> BS.ByteString -> BS.ByteString bits2octets q bs = int2octets q $ bits2int q bs `mod` q++makeEcdsaPubKey :: ECC.CurveName -> BS.ByteString -> ECDSA.PublicKey+makeEcdsaPubKey c xy = ECDSA.PublicKey (ECC.getCurveByName c) $ decodePoint xy++decodePoint :: BS.ByteString -> ECC.Point+decodePoint s = case BS.uncons s of+ Just (4, p) -> let (x, y) = BS.splitAt 32 p in ECC.Point+ (either error id $ B.decode x)+ (either error id $ B.decode y)+ _ -> error $ moduleName ++ ".decodePoint: not implemented point"
src/Network/PeyoTLS/Handle.hs view
@@ -3,7 +3,7 @@ module Network.PeyoTLS.Handle ( TlsM, Alert(..), AlertLevel(..), AlertDesc(..), run, withRandom, randomByteString,- TlsHandle_(..), RW(..), Side(..), ContentType(..), CipherSuite(..),+ TlsHandleBase(..), RW(..), Side(..), ContentType(..), CipherSuite(..), newHandle, getContentType, tlsGet, tlsPut, generateKeys, debugCipherSuite, getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt,@@ -23,7 +23,9 @@ flushAppData, getAdBufT, setAdBufT,- CertSecretKey(..),+ CertSecretKey(..), isRsaKey, isEcdsaKey,++ updateHash, ) where import Prelude hiding (read)@@ -59,18 +61,18 @@ Settings, getSettings, setSettings, SettingsS, getInitSet, setInitSet,- CertSecretKey(..),+ CertSecretKey(..), isRsaKey, isEcdsaKey, ) import qualified Network.PeyoTLS.Crypto as CT ( makeKeys, encrypt, decrypt, hashSha1, hashSha256, finishedHash ) -data TlsHandle_ h g = TlsHandle_ {+data TlsHandleBase h g = TlsHandleBase { clientId :: PartnerId, tlsHandle :: h, names :: [String] } deriving Show -type HandleHash h g = (TlsHandle_ h g, SHA256.Ctx)+type HandleHash h g = (TlsHandleBase h g, SHA256.Ctx) data Side = Server | Client deriving (Show, Eq) @@ -81,15 +83,15 @@ Right r -> return r Left a -> error $ show a -newHandle :: HandleLike h => h -> TlsM h g (TlsHandle_ h g)+newHandle :: HandleLike h => h -> TlsM h g (TlsHandleBase h g) newHandle h = do s <- get let (i, s') = newPartnerId s put s'- return TlsHandle_ {+ return TlsHandleBase { clientId = i, tlsHandle = h, names = [] } -getContentType :: (HandleLike h, CPRG g) => TlsHandle_ h g -> TlsM h g ContentType+getContentType :: (HandleLike h, CPRG g) => TlsHandleBase h g -> TlsM h g ContentType getContentType t = do ct <- fst `liftM` getBuf (clientId t) (\gt -> case ct of CTNull -> gt; _ -> return ct) $ do@@ -98,41 +100,47 @@ return ct' flushAppData :: (HandleLike h, CPRG g) =>- TlsHandle_ h g -> TlsM h g (BS.ByteString, Bool)+ TlsHandleBase h g -> TlsM h g (BS.ByteString, Bool) flushAppData t = do+ lift . lift $ hlDebug (tlsHandle t) "low" "begin flushAppData\n" ct <- getContentType t+ lift . lift $ hlDebug (tlsHandle t) "low" "after getContentType\n" case ct of CTAppData -> do- (_, ad) <- tGetContent t+ 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) <- flushAppData t+ lift . lift . hlDebug (tlsHandle t) "low" .+ BSC.pack $ show bs return (ad `BS.append` bs, b) -- liftM (BS.append . snd) (tGetContent t) `ap` flushAppData t CTAlert -> do ((_, a), _) <- tlsGet True (t, undefined) 2+ lift . lift $ hlDebug (tlsHandle t) "low" .+ BSC.pack $ show a case a of "\1\0" -> return ("", False) _ -> throwError "flushAppData"- _ -> return ("", True)+ _ -> do lift . lift $ hlDebug (tlsHandle t) "low" .+ BSC.pack $ show ct+ return ("", True) tlsGet :: (HandleLike h, CPRG g) => Bool -> HandleHash h g -> Int -> TlsM h g ((ContentType, BS.ByteString), HandleHash h g) tlsGet b hh@(t, _) n = do r@(ct, bs) <- buffered t n (r ,) `liftM` case (ct, b, bs) of- (CTHandshake, _, "\0") -> return hh- (CTHandshake, True, _)- | "\0\0\0\0" `BS.isPrefixOf` bs ->- updateHash hh $ BS.drop 4 bs- | otherwise -> updateHash hh bs _ -> return hh -tlsGet_ :: (HandleLike h, CPRG g) => (TlsHandle_ h g -> TlsM h g ()) ->+tlsGet_ :: (HandleLike h, CPRG g) => (TlsHandleBase h g -> TlsM h g ()) -> HandleHash h g -> Int -> TlsM h g ((ContentType, BS.ByteString), HandleHash h g) tlsGet_ rn hh@(t, _) n = (, hh) `liftM` buffered_ rn t n buffered :: (HandleLike h, CPRG g) =>- TlsHandle_ h g -> Int -> TlsM h g (ContentType, BS.ByteString)+ TlsHandleBase h g -> Int -> TlsM h g (ContentType, BS.ByteString) buffered t n = do (ct, b) <- getBuf $ clientId t; let rl = n - BS.length b if rl <= 0@@ -147,8 +155,8 @@ setBuf (clientId t) (ct', b') second (b `BS.append`) `liftM` buffered t rl -buffered_ :: (HandleLike h, CPRG g) => (TlsHandle_ h g -> TlsM h g ()) ->- TlsHandle_ h g -> Int -> TlsM h g (ContentType, BS.ByteString)+buffered_ :: (HandleLike h, CPRG g) => (TlsHandleBase h g -> TlsM h g ()) ->+ TlsHandleBase h g -> Int -> TlsM h g (ContentType, BS.ByteString) buffered_ rn t n = do ct0 <- getContentType t case ct0 of@@ -164,7 +172,7 @@ second (b `BS.append`) `liftM` buffered_ rn t rl splitRetBuf :: HandleLike h =>- TlsHandle_ h g -> Int -> ContentType -> BS.ByteString ->+ TlsHandleBase h g -> Int -> ContentType -> BS.ByteString -> TlsM h g (ContentType, BS.ByteString) splitRetBuf t n ct b = do let (ret, b') = BS.splitAt n b@@ -172,33 +180,33 @@ return (ct, ret) getWholeWithCt :: (HandleLike h, CPRG g) =>- TlsHandle_ h g -> TlsM h g (ContentType, BS.ByteString)+ TlsHandleBase h g -> TlsM h g (ContentType, BS.ByteString) getWholeWithCt t = do flush t ct <- (either (throwError . strMsg) return . B.decode) =<< read t 1 [_vmj, _vmn] <- BS.unpack `liftM` read t 2 e <- read t =<< either (throwError . strMsg) return . B.decode =<< read t 2- when (BS.null e) $ throwError "TlsHandle_.getWholeWithCt: e is null"+ when (BS.null e) $ throwError "TlsHandleBase.getWholeWithCt: e is null" p <- decrypt t ct e thlDebug (tlsHandle t) "medium" . BSC.pack . (++ ": ") $ show ct thlDebug (tlsHandle t) "medium" . BSC.pack . (++ "\n") . show $ BS.head p thlDebug (tlsHandle t) "low" . BSC.pack . (++ "\n") $ show p return (ct, p) -read :: (HandleLike h, CPRG g) => TlsHandle_ h g -> Int -> TlsM h g BS.ByteString+read :: (HandleLike h, CPRG g) => TlsHandleBase h g -> Int -> TlsM h g BS.ByteString read t n = do r <- thlGet (tlsHandle t) n unless (BS.length r == n) . throwError . strMsg $- "TlsHandle_.read: can't read " ++ show (BS.length r) ++ " " ++ show n+ "TlsHandleBase.read: can't read " ++ show (BS.length r) ++ " " ++ show n return r decrypt :: HandleLike h =>- TlsHandle_ h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString+ TlsHandleBase h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString decrypt t ct e = do ks <- getKeys $ clientId t decrypt_ t ks ct e -decrypt_ :: HandleLike h => TlsHandle_ h g ->+decrypt_ :: HandleLike h => TlsHandleBase h g -> Keys -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString decrypt_ _ Keys{ kReadCS = CipherSuite _ BE_NULL } _ e = return e decrypt_ t ks ct e = do@@ -209,7 +217,7 @@ hs <- case be of AES_128_CBC_SHA -> return CT.hashSha1 AES_128_CBC_SHA256 -> return CT.hashSha256- _ -> throwError "TlsHandle_.decrypt: not implement bulk encryption"+ _ -> throwError "TlsHandleBase.decrypt: not implement bulk encryption" either (throwError . strMsg) return $ CT.decrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") e @@ -223,10 +231,9 @@ flush t >> setWBuf (clientId t) (ct, p) | otherwise -> setWBuf (clientId t) (ct, bp `BS.append` p) case (ct, b) of- (CTHandshake, True) -> updateHash hh p _ -> return hh -flush :: (HandleLike h, CPRG g) => TlsHandle_ h g -> TlsM h g ()+flush :: (HandleLike h, CPRG g) => TlsHandleBase h g -> TlsM h g () flush t = do (bct, bp) <- getWBuf $ clientId t setWBuf (clientId t) (CTNull, "")@@ -236,12 +243,12 @@ B.encode bct, "\x03\x03", B.addLen (undefined :: Word16) e ] encrypt :: (HandleLike h, CPRG g) =>- TlsHandle_ h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString+ TlsHandleBase h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString encrypt t ct p = do ks <- getKeys $ clientId t encrypt_ t ks ct p -encrypt_ :: (HandleLike h, CPRG g) => TlsHandle_ h g ->+encrypt_ :: (HandleLike h, CPRG g) => TlsHandleBase h g -> Keys -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString encrypt_ _ Keys{ kWriteCS = CipherSuite _ BE_NULL } _ p = return p encrypt_ t ks ct p = do@@ -252,14 +259,14 @@ hs <- case be of AES_128_CBC_SHA -> return CT.hashSha1 AES_128_CBC_SHA256 -> return CT.hashSha256- _ -> throwError "TlsHandle_.encrypt: not implemented bulk encryption"+ _ -> throwError "TlsHandleBase.encrypt: not implemented bulk encryption" withRandom $ CT.encrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") p updateHash :: HandleLike h => HandleHash h g -> BS.ByteString -> TlsM h g (HandleHash h g) updateHash (th, ctx') bs = return (th, SHA256.update ctx' bs) -updateSequenceNumber :: HandleLike h => TlsHandle_ h g -> RW -> TlsM h g Word64+updateSequenceNumber :: HandleLike h => TlsHandleBase h g -> RW -> TlsM h g Word64 updateSequenceNumber t rw = do ks <- getKeys $ clientId t (sn, cs) <- case rw of@@ -272,12 +279,12 @@ Write -> succWriteSn $ clientId t return sn -resetSequenceNumber :: HandleLike h => TlsHandle_ h g -> RW -> TlsM h g ()+resetSequenceNumber :: HandleLike h => TlsHandleBase h g -> RW -> TlsM h g () resetSequenceNumber t rw = case rw of Read -> resetReadSn $ clientId t Write -> resetWriteSn $ clientId t -generateKeys :: HandleLike h => TlsHandle_ h g -> Side -> CipherSuite ->+generateKeys :: HandleLike h => TlsHandleBase h g -> Side -> CipherSuite -> BS.ByteString -> BS.ByteString -> BS.ByteString -> TlsM h g Keys generateKeys t p cs cr sr pms = do let CipherSuite _ be = cs@@ -307,7 +314,7 @@ Read -> flushCipherSuiteRead Write -> flushCipherSuiteWrite -debugCipherSuite :: HandleLike h => TlsHandle_ h g -> String -> TlsM h g ()+debugCipherSuite :: HandleLike h => TlsHandleBase h g -> String -> TlsM h g () debugCipherSuite t a = do k <- getKeys $ clientId t thlDebug (tlsHandle t) "high" . BSC.pack@@ -324,19 +331,19 @@ sha256 <- handshakeHash (t, ctx) return $ CT.finishedHash (partner == Client) ms sha256 -hlPut_ :: (HandleLike h, CPRG g) => TlsHandle_ h g -> BS.ByteString -> TlsM h g ()+hlPut_ :: (HandleLike h, CPRG g) => TlsHandleBase h g -> BS.ByteString -> TlsM h g () hlPut_ = ((>> return ()) .) . flip (tlsPut True) CTAppData . (, undefined) hlDebug_ :: HandleLike h =>- TlsHandle_ h g -> DebugLevel h -> BS.ByteString -> TlsM h g ()+ TlsHandleBase h g -> DebugLevel h -> BS.ByteString -> TlsM h g () hlDebug_ t l = lift . lift . hlDebug (tlsHandle t) l -hlClose_ :: (HandleLike h, CPRG g) => TlsHandle_ h g -> TlsM h g ()+hlClose_ :: (HandleLike h, CPRG g) => TlsHandleBase h g -> TlsM h g () hlClose_ t = tlsPut True (t, undefined) CTAlert "\SOH\NUL" >> flush t >> thlClose (tlsHandle t) tGetLine :: (HandleLike h, CPRG g) =>- TlsHandle_ h g -> TlsM h g (ContentType, BS.ByteString)+ TlsHandleBase h g -> TlsM h g (ContentType, BS.ByteString) tGetLine t = do (bct, bp) <- getBuf $ clientId t case splitLine bp of@@ -345,8 +352,8 @@ setBuf (clientId t) cp second (bp `BS.append`) `liftM` tGetLine t -tGetLine_ :: (HandleLike h, CPRG g) => (TlsHandle_ h g -> TlsM h g ()) ->- TlsHandle_ h g -> TlsM h g (ContentType, BS.ByteString)+tGetLine_ :: (HandleLike h, CPRG g) => (TlsHandleBase h g -> TlsM h g ()) ->+ TlsHandleBase h g -> TlsM h g (ContentType, BS.ByteString) tGetLine_ rn t = do ct <- getContentType t case ct of@@ -354,7 +361,7 @@ _ -> do (bct, bp) <- getBuf $ clientId t case splitLine bp of Just (l, ls) -> do- setBuf (clientId t) (bct, ls)+ setBuf (clientId t) (if BS.null ls then CTNull else bct, ls) return (bct, l) _ -> do cp <- getWholeWithCt t setBuf (clientId t) cp@@ -375,36 +382,36 @@ _ -> Nothing tGetContent :: (HandleLike h, CPRG g) =>- TlsHandle_ h g -> TlsM h g (ContentType, BS.ByteString)+ TlsHandleBase h g -> TlsM h g (ContentType, BS.ByteString) tGetContent t = do bcp@(_, bp) <- getBuf $ clientId t if BS.null bp then getWholeWithCt t else setBuf (clientId t) (CTNull, BS.empty) >> return bcp getClientFinishedT, getServerFinishedT ::- HandleLike h => TlsHandle_ h g -> TlsM h g BS.ByteString+ HandleLike h => TlsHandleBase h g -> TlsM h g BS.ByteString getClientFinishedT = getClientFinished . clientId getServerFinishedT = getServerFinished . clientId setClientFinishedT, setServerFinishedT ::- HandleLike h => TlsHandle_ h g -> BS.ByteString -> TlsM h g ()+ HandleLike h => TlsHandleBase h g -> BS.ByteString -> TlsM h g () setClientFinishedT = setClientFinished . clientId setServerFinishedT = setServerFinished . clientId -getSettingsT :: HandleLike h => TlsHandle_ h g -> TlsM h g Settings+getSettingsT :: HandleLike h => TlsHandleBase h g -> TlsM h g Settings getSettingsT = getSettings . clientId -getInitSetT :: HandleLike h => TlsHandle_ h g -> TlsM h g SettingsS+getInitSetT :: HandleLike h => TlsHandleBase h g -> TlsM h g SettingsS getInitSetT = getInitSet . clientId -setSettingsT :: HandleLike h => TlsHandle_ h g -> Settings -> TlsM h g ()+setSettingsT :: HandleLike h => TlsHandleBase h g -> Settings -> TlsM h g () setSettingsT = setSettings . clientId -setInitSetT :: HandleLike h => TlsHandle_ h g -> SettingsS -> TlsM h g ()+setInitSetT :: HandleLike h => TlsHandleBase h g -> SettingsS -> TlsM h g () setInitSetT = setInitSet . clientId -getAdBufT :: HandleLike h => TlsHandle_ h g -> TlsM h g BS.ByteString+getAdBufT :: HandleLike h => TlsHandleBase h g -> TlsM h g BS.ByteString getAdBufT = getAdBuf . clientId -setAdBufT :: HandleLike h => TlsHandle_ h g -> BS.ByteString -> TlsM h g ()+setAdBufT :: HandleLike h => TlsHandleBase h g -> BS.ByteString -> TlsM h g () setAdBufT = setAdBuf . clientId
src/Network/PeyoTLS/Monad.hs view
@@ -19,7 +19,7 @@ getClientFinished, setClientFinished, getServerFinished, setServerFinished,- S.CertSecretKey(..),+ S.CertSecretKey(..), S.isRsaKey, S.isEcdsaKey, ) where import Control.Monad (liftM)@@ -48,7 +48,7 @@ getServerFinished, setServerFinished, SettingsS, Settings,- CertSecretKey(..),+ CertSecretKey(..), isRsaKey, isEcdsaKey, ) type TlsM h g = ErrorT S.Alert (StateT (S.HandshakeState h g) (HandleMonad h))
src/Network/PeyoTLS/Run.hs view
@@ -1,38 +1,44 @@ {-# LANGUAGE OverloadedStrings, TupleSections, PackageImports, TypeFamilies #-} module Network.PeyoTLS.Run (+ updateHash,+ hsGet, hsPut,+ ccsGet, ccsPut,+ adGet, adGetLine, adGetContent,+ TH.isRsaKey, TH.isEcdsaKey,+ checkAppData, TH.TlsM, TH.run, HandshakeM, execHandshakeM, rerunHandshakeM, withRandom, randomByteString,- ValidateHandle(..), handshakeValidate,- TH.TlsHandle_(..), TH.ContentType(..),+ ValidateHandle(..), handshakeValidate, validateAlert,+ TH.TlsHandleBase(..), TH.ContentType(..), getCipherSuite, setCipherSuite, flushCipherSuite, debugCipherSuite, tlsGetContentType, tlsGet, tlsPut, tlsPutNH,- generateKeys, encryptRsa, decryptRsa, rsaPadding,+ generateKeys, TH.Alert(..), TH.AlertLevel(..), TH.AlertDesc(..), TH.Side(..), TH.RW(..), handshakeHash, finishedHash, throwError, TH.hlPut_, TH.hlDebug_, TH.hlClose_, TH.tGetLine, TH.tGetContent, tlsGet_, tlsPut_, tlsGet__, tGetLine_, tGetContent_,- getClientFinished, setClientFinished,- getServerFinished, setServerFinished,+ getClFinished, getSvFinished, setClFinished, setSvFinished, resetSequenceNumber, - getSettings, setSettings, TH.SettingsS,+ getSettingsS, setSettingsS, TH.SettingsS, getSettingsC, setSettingsC, TH.Settings,- flushAppData_,+ flushAppData, getAdBuf, setAdBuf,- pushAdBufH,+ pushAdBuf, TH.CertSecretKey(..) ) where import Prelude hiding (read) +import Data.Word import Control.Applicative import qualified Data.ASN1.Types as ASN1-import Control.Arrow (first)+import Control.Arrow (first, second, (***)) import Control.Monad (liftM) import "monads-tf" Control.Monad.Trans (lift) import "monads-tf" Control.Monad.State (@@ -44,18 +50,17 @@ 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 Crypto.Hash.SHA256 as SHA256-import qualified Crypto.PubKey.HashDescr as HD-import qualified Crypto.PubKey.RSA as RSA-import qualified Crypto.PubKey.RSA.PKCS15 as RSA import qualified Network.PeyoTLS.Handle as TH (+ updateHash, TlsM, Alert(..), AlertLevel(..), AlertDesc(..), run, withRandom, randomByteString,- TlsHandle_(..), ContentType(..),+ TlsHandleBase(..), ContentType(..), newHandle, getContentType, tlsGet, tlsPut, generateKeys, debugCipherSuite, getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt, setKeys,@@ -73,24 +78,53 @@ getAdBufT, setAdBufT, - CertSecretKey(..),+ CertSecretKey(..), isRsaKey, isEcdsaKey, ) +import qualified Codec.Bytable.BigEndian as B++moduleName :: String+moduleName = "Network.PeyoTLS.Run"++instance (HandleLike h, CPRG g) => HandleLike (TH.TlsHandleBase h g) where+ type HandleMonad (TH.TlsHandleBase h g) = TH.TlsM h g+ type DebugLevel (TH.TlsHandleBase h g) = DebugLevel h+ hlPut = TH.hlPut_+ hlGet = (.) <$> checkAppData <*> ((fst `liftM`) .)+ . tlsGet__ . (, undefined)+ hlGetLine = ($) <$> checkAppData <*> TH.tGetLine+ hlGetContent = ($) <$> checkAppData <*> TH.tGetContent+ hlDebug = TH.hlDebug_+ hlClose = TH.hlClose_++checkAppData :: (HandleLike h, CPRG g) => TH.TlsHandleBase h g ->+ TH.TlsM h g (TH.ContentType, BS.ByteString) -> TH.TlsM h g BS.ByteString+checkAppData t m = m >>= \cp -> case cp of+ (TH.CTAppData, ad) -> return ad+ (TH.CTAlert, "\SOH\NUL") -> do+ _ <- tlsPut_ (t, undefined) TH.CTAlert "\SOH\NUL"+ E.throwError . strMsg $+ moduleName ++ ".checkAppData: EOF"+ (TH.CTHandshake, _) -> E.throwError "bad"+ _ -> do _ <- tlsPut_ (t, undefined) TH.CTAlert "\2\10"+ E.throwError . strMsg $+ moduleName ++ ".checkAppData: not application data"+ resetSequenceNumber :: HandleLike h => TH.RW -> HandshakeM h g () resetSequenceNumber rw = gets fst >>= lift . flip TH.resetSequenceNumber rw tlsGet_ :: (HandleLike h, CPRG g) =>- (TH.TlsHandle_ h g -> TH.TlsM h g ()) ->- (TH.TlsHandle_ h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle_ h g, SHA256.Ctx))+ (TH.TlsHandleBase h g -> TH.TlsM h g ()) ->+ (TH.TlsHandleBase h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandleBase h g, SHA256.Ctx)) tlsGet_ = TH.tlsGet_ tlsGet__ :: (HandleLike h, CPRG g) =>- (TH.TlsHandle_ h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle_ h g, SHA256.Ctx))+ (TH.TlsHandleBase h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandleBase h g, SHA256.Ctx)) tlsGet__ = TH.tlsGet True tGetLine_, tGetContent_ :: (HandleLike h, CPRG g) =>- (TH.TlsHandle_ h g -> TH.TlsM h g ()) ->- TH.TlsHandle_ h g -> TH.TlsM h g (TH.ContentType, BS.ByteString)+ (TH.TlsHandleBase h g -> TH.TlsM h g ()) ->+ TH.TlsHandleBase h g -> TH.TlsM h g (TH.ContentType, BS.ByteString) tGetLine_ = TH.tGetLine_ flushAppData_ :: (HandleLike h, CPRG g) => HandshakeM h g (BS.ByteString, Bool)@@ -103,22 +137,22 @@ _ -> TH.tGetContent t tlsPut_ :: (HandleLike h, CPRG g) =>- (TH.TlsHandle_ h g, SHA256.Ctx) -> TH.ContentType -> BS.ByteString -> TH.TlsM h g (TH.TlsHandle_ h g, SHA256.Ctx)+ (TH.TlsHandleBase h g, SHA256.Ctx) -> TH.ContentType -> BS.ByteString -> TH.TlsM h g (TH.TlsHandleBase h g, SHA256.Ctx) tlsPut_ = TH.tlsPut True throwError :: HandleLike h => TH.AlertLevel -> TH.AlertDesc -> String -> HandshakeM h g a throwError al ad m = E.throwError $ TH.Alert al ad m -type HandshakeM h g = StateT (TH.TlsHandle_ h g, SHA256.Ctx) (TH.TlsM h g)+type HandshakeM h g = StateT (TH.TlsHandleBase h g, SHA256.Ctx) (TH.TlsM h g) execHandshakeM :: HandleLike h =>- h -> HandshakeM h g () -> TH.TlsM h g (TH.TlsHandle_ h g)+ h -> HandshakeM h g () -> TH.TlsM h g (TH.TlsHandleBase h g) execHandshakeM h = liftM fst . ((, SHA256.init) `liftM` TH.newHandle h >>=) . execStateT rerunHandshakeM ::- HandleLike h => TH.TlsHandle_ h g -> HandshakeM h g a -> TH.TlsM h g a+ HandleLike h => TH.TlsHandleBase h g -> HandshakeM h g a -> TH.TlsM h g a rerunHandshakeM t hm = evalStateT hm (t, SHA256.init) withRandom :: HandleLike h => (g -> (a, g)) -> HandshakeM h g a@@ -131,6 +165,13 @@ validate :: h -> X509.CertificateStore -> X509.CertificateChain -> HandleMonad h [X509.FailedReason] +validateAlert :: [X509.FailedReason] -> TH.AlertDesc+validateAlert vr+ | X509.UnknownCA `elem` vr = TH.ADUnknownCa+ | X509.Expired `elem` vr = TH.ADCertificateExpired+ | X509.InFuture `elem` vr = TH.ADCertificateExpired+ | otherwise = TH.ADCertificateUnknown+ instance ValidateHandle Handle where validate _ cs (X509.CertificateChain cc) = X509.validate X509.HashSHA256 X509.defaultHooks@@ -196,53 +237,53 @@ k <- lift $ TH.generateKeys t p cs cr sr pms lift $ TH.setKeys (TH.clientId t) k -encryptRsa :: (HandleLike h, CPRG g) =>- RSA.PublicKey -> BS.ByteString -> HandshakeM h g BS.ByteString-encryptRsa pk p = either (E.throwError . strMsg . show) return =<<- withRandom (\g -> RSA.encrypt g pk p)--decryptRsa :: (HandleLike h, CPRG g) =>- RSA.PrivateKey -> BS.ByteString -> HandshakeM h g BS.ByteString-decryptRsa sk e = either (E.throwError . strMsg . show) return =<<- withRandom (\g -> RSA.decryptSafer g sk e)--rsaPadding :: RSA.PublicKey -> BS.ByteString -> BS.ByteString-rsaPadding pk bs = case RSA.padSignature (RSA.public_size pk) $- HD.digestToASN1 HD.hashDescrSHA256 bs of- Right pd -> pd; Left m -> error $ show m- handshakeHash :: HandleLike h => HandshakeM h g BS.ByteString handshakeHash = get >>= lift . TH.handshakeHash finishedHash :: (HandleLike h, CPRG g) => TH.Side -> HandshakeM h g BS.ByteString finishedHash p = get >>= lift . flip TH.finishedHash p -getClientFinished, getServerFinished :: HandleLike h => HandshakeM h g BS.ByteString-getClientFinished = gets fst >>= lift . TH.getClientFinishedT-getServerFinished = gets fst >>= lift . TH.getServerFinishedT+getClFinished, getSvFinished :: HandleLike h => HandshakeM h g BS.ByteString+getClFinished = gets fst >>= lift . TH.getClientFinishedT+getSvFinished = gets fst >>= lift . TH.getServerFinishedT -setClientFinished, setServerFinished ::- HandleLike h => BS.ByteString -> HandshakeM h g ()-setClientFinished cf = gets fst >>= lift . flip TH.setClientFinishedT cf-setServerFinished cf = gets fst >>= lift . flip TH.setServerFinishedT cf+setClFinished, setSvFinished :: HandleLike h => BS.ByteString -> HandshakeM h g ()+setClFinished cf = gets fst >>= lift . flip TH.setClientFinishedT cf+setSvFinished cf = gets fst >>= lift . flip TH.setServerFinishedT cf -getSettings :: HandleLike h => HandshakeM h g TH.SettingsS-getSettings = gets fst >>= lift . TH.getInitSetT+getSettingsS :: HandleLike h => HandshakeM h g TH.SettingsS+getSettingsS = gets fst >>= lift . TH.getInitSetT -getSettingsC :: HandleLike h => HandshakeM h g TH.Settings-getSettingsC = gets fst >>= lift . TH.getSettingsT+getSettingsC_ :: HandleLike h => HandshakeM h g TH.Settings+getSettingsC_ = gets fst >>= lift . TH.getSettingsT -setSettings :: HandleLike h => TH.SettingsS -> HandshakeM h g ()-setSettings is = gets fst >>= lift . flip TH.setInitSetT is+setSettingsS :: HandleLike h => TH.SettingsS -> HandshakeM h g ()+setSettingsS is = gets fst >>= lift . flip TH.setInitSetT is -setSettingsC :: HandleLike h => TH.Settings -> HandshakeM h g ()-setSettingsC is = gets fst >>= lift . flip TH.setSettingsT is+setSettingsC_ :: HandleLike h => TH.Settings -> HandshakeM h g ()+setSettingsC_ is = gets fst >>= lift . flip TH.setSettingsT is -getAdBuf :: HandleLike h => TH.TlsHandle_ h g -> TH.TlsM h g BS.ByteString+type SettingsC = (+ [TH.CipherSuite],+ [(TH.CertSecretKey, X509.CertificateChain)],+ X509.CertificateStore )++getSettingsC :: HandleLike h => HandshakeM h g SettingsC+getSettingsC = do+ (css, crts, mcs) <- getSettingsC_+ case mcs of+ Just cs -> return (css, crts, cs)+ _ -> throwError TH.ALFatal TH.ADInternalError+ "Network.PeyoTLS.Base.getSettingsC"++setSettingsC :: HandleLike h => SettingsC -> HandshakeM h g ()+setSettingsC (css, crts, cs) = setSettingsC_ (css, crts, Just cs)++getAdBuf :: HandleLike h => TH.TlsHandleBase h g -> TH.TlsM h g BS.ByteString getAdBuf = TH.getAdBufT setAdBuf :: HandleLike h =>- TH.TlsHandle_ h g -> BS.ByteString -> TH.TlsM h g ()+ TH.TlsHandleBase h g -> BS.ByteString -> TH.TlsM h g () setAdBuf = TH.setAdBufT getAdBufH :: HandleLike h => HandshakeM h g BS.ByteString@@ -251,7 +292,103 @@ setAdBufH :: HandleLike h => BS.ByteString -> HandshakeM h g () setAdBufH bs = gets fst >>= lift . flip TH.setAdBufT bs -pushAdBufH :: HandleLike h => BS.ByteString -> HandshakeM h g ()-pushAdBufH bs = do+pushAdBuf :: HandleLike h => BS.ByteString -> HandshakeM h g ()+pushAdBuf bs = do bf <- getAdBufH setAdBufH $ bf `BS.append` bs++adGet, hlGetRn_ :: (ValidateHandle h, CPRG g) =>+ (TH.TlsHandleBase h g -> TH.TlsM h g ()) -> TH.TlsHandleBase h g -> Int ->+ TH.TlsM h g BS.ByteString+adGet = hlGetRn+hlGetRn_ rh = (.) <$> checkAppData <*> ((fst `liftM`) .) . TH.tlsGet_ rh+ . (, undefined)++hlGetLineRn_, hlGetContentRn_, adGetLine, adGetContent ::+ (ValidateHandle h, CPRG g) =>+ (TH.TlsHandleBase h g -> TH.TlsM h g ()) -> TH.TlsHandleBase h g -> TH.TlsM h g BS.ByteString+adGetLine = hlGetLineRn+hlGetLineRn_ rh = ($) <$> checkAppData <*> tGetLine_ rh+adGetContent = hlGetContentRn+hlGetContentRn_ rh = ($) <$> checkAppData <*> tGetContent_ rh++hsGet :: (HandleLike h, CPRG g) => HandshakeM h g BS.ByteString+hsGet = do+ ct <- tlsGetContentType+ case ct of+ TH.CTHandshake -> do+ t <- tlsGet True 1+ len <- tlsGet (t /= "\0") 3+ body <- tlsGet True . either error id $ B.decode len+ return $ BS.concat [t, len, body]+ _ -> throwError+ TH.ALFatal TH.ADUnexpectedMessage $+ "HandshakeBase.readHandshake: not handshake: " ++ show ct++ccsGet :: (HandleLike h, CPRG g) => HandshakeM h g Word8+ccsGet = do+ ct <- tlsGetContentType+ bs <- case ct of+ TH.CTCCSpec -> tlsGet True 1+ _ -> throwError TH.ALFatal TH.ADUnexpectedMessage $+ "HandshakeBase.getChangeCipherSpec: " +++ "not change cipher spec: " ++ show ct+ resetSequenceNumber TH.Read+ return $ let [w] = BS.unpack bs in w++hsPut :: (HandleLike h, CPRG g) => BS.ByteString -> HandshakeM h g ()+hsPut = tlsPut TH.CTHandshake++ccsPut :: (HandleLike h, CPRG g) => Word8 -> HandshakeM h g ()+ccsPut w = do+ tlsPut TH.CTCCSpec $ BS.pack [w]+ resetSequenceNumber TH.Write++updateHash :: HandleLike h => BS.ByteString -> HandshakeM h g ()+updateHash bs = get >>= lift . flip TH.updateHash bs >>= put++flushAppData :: (HandleLike h, CPRG g) => HandshakeM h g Bool+flushAppData = uncurry (>>) . (pushAdBuf *** return) =<< flushAppData_++hlGetRn :: (ValidateHandle h, CPRG g) => (TH.TlsHandleBase h g -> TH.TlsM h g ()) ->+ TH.TlsHandleBase h g -> Int -> TH.TlsM h g BS.ByteString+hlGetRn rn t n = do+ bf <- getAdBuf t+ if BS.length bf >= n+ then do let (ret, rest) = BS.splitAt n bf+ setAdBuf t rest+ return ret+ else (bf `BS.append`) `liftM` hlGetRn_ rn t (n - BS.length bf)++hlGetLineRn :: (ValidateHandle h, CPRG g) =>+ (TH.TlsHandleBase h g -> TH.TlsM h g ()) -> TH.TlsHandleBase h g ->+ TH.TlsM h g BS.ByteString+hlGetLineRn rn t = do+ bf <- getAdBuf t+ if '\n' `BSC.elem` bf || '\r' `BSC.elem` bf+ then do let (ret, rest) = splitOneLine bf+ setAdBuf t $ BS.tail rest+ return ret+ else (bf `BS.append`) `liftM` hlGetLineRn_ rn t++splitOneLine :: BS.ByteString -> (BS.ByteString, BS.ByteString)+splitOneLine bs = case BSC.span (/= '\r') bs of+ (_, "") -> second BS.tail $ BSC.span (/= '\n') bs+ (l, ls) -> (l, dropRet ls)++dropRet :: BS.ByteString -> BS.ByteString+dropRet bs = case BSC.uncons bs of+ Just ('\r', bs') -> case BSC.uncons bs' of+ Just ('\n', bs'') -> bs''+ _ -> bs'+ _ -> bs++hlGetContentRn :: (ValidateHandle h, CPRG g) =>+ (TH.TlsHandleBase h g -> TH.TlsM h g ()) ->+ TH.TlsHandleBase h g -> TH.TlsM h g BS.ByteString+hlGetContentRn rn t = do+ bf <- getAdBuf t+ if BS.null bf+ then hlGetContentRn_ rn t+ else do setAdBuf t ""+ return bf
src/Network/PeyoTLS/Server.hs view
@@ -1,65 +1,86 @@+{-|++Module : Network.PeyoTLS.Server+Copyright : (c) Yoshikuni Jujo, 2014+License : BSD3+Maintainer : PAF01143@nifty.ne.jp+Stability : Experimental++-}+ {-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-} module Network.PeyoTLS.Server (- PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, renegotiate, names,+ -- * Basic+ PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, names,+ -- * Renegotiation+ renegotiate, setCipherSuites, setKeyCerts, setCertificateStore,+ -- * Cipher Suite CipherSuite(..), KeyEx(..), BulkEnc(..),+ -- * Others ValidateHandle(..), CertSecretKey(..) ) where import Control.Applicative ((<$>), (<*>)) import Control.Arrow (first) import Control.Monad (when, unless, liftM, ap) import "monads-tf" Control.Monad.Error (catchError)-import Data.Maybe (listToMaybe, mapMaybe)+import "monads-tf" Control.Monad.Error.Class (strMsg) import Data.List (find) import Data.Word (Word8) import Data.HandleLike (HandleLike(..)) import System.IO (Handle)+import Numeric (readHex) import "crypto-random" Crypto.Random (CPRG, SystemRNG) +import qualified "monads-tf" Control.Monad.Error as E import qualified Data.ByteString as BS import qualified Data.X509 as X509 import qualified Data.X509.CertificateStore as X509 import qualified Codec.Bytable.BigEndian as B import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.RSA.PKCS15 as RSA+import qualified Crypto.Types.PubKey.DH as DH+import qualified Crypto.Types.PubKey.ECC as ECC import qualified Network.PeyoTLS.Base as BASE (names)-import Network.PeyoTLS.Base (+import Network.PeyoTLS.Base ( debug, PeyotlsM, TlsM, run,- SettingsS, getSettings, setSettings,- hlGetRn, hlGetLineRn, hlGetContentRn,+ SettingsS, getSettingsS, setSettingsS,+ adGet, adGetLine, adGetContent, HandshakeM, execHandshakeM, rerunHandshakeM, withRandom, randomByteString, flushAppData, AlertLevel(..), AlertDesc(..), throwError, debugCipherSuite, ValidateHandle(..), handshakeValidate, validateAlert,- TlsHandle_, CertSecretKey(..), isRsaKey, isEcdsaKey,- readHandshake, writeHandshake, writeHandshakeNH,+ TlsHandleBase, CertSecretKey(..), isRsaKey, isEcdsaKey,+ readHandshake, writeHandshake, getChangeCipherSpec, putChangeCipherSpec, Handshake(HHelloReq),- ClientHello(..), ServerHello(..), SessionId(..), Extension(..), eRenegoInfo,+ ClientHello(..), ServerHello(..), SessionId(..), Extension(..),+ isRenegoInfo, emptyRenegoInfo, CipherSuite(..), KeyEx(..), BulkEnc(..), CompMethod(..), HashAlg(..), SignAlg(..), getCipherSuite, setCipherSuite,- checkClientRenego, makeServerRenego,- ServerKeyExchange(..), SecretKey(..),- certificateRequest, ClientCertificateType(..),+ checkClRenego, makeSvRenego,+ ServerKeyEx(..), SvSignSecretKey(..),+ certReq, ClCertType(..), ServerHelloDone(..),- ClientKeyExchange(..), Epms(..), generateKeys, decryptRsa,+ ClientKeyEx(..), Epms(..), generateKeys, DigitallySigned(..), ClSignPublicKey(..), handshakeHash, RW(..), flushCipherSuite, Side(..), finishedHash,- DhParam(..), makeEcdsaPubKey, dh3072Modp, secp256r1 )+ DhParam(..), makeEcdsaPubKey ) type PeyotlsHandle = TlsHandle Handle SystemRNG -newtype TlsHandle h g = TlsHandleS { tlsHandleS :: TlsHandle_ h g } deriving Show+newtype TlsHandle h g = TlsHandleS { tlsHandleS :: TlsHandleBase h g } deriving Show instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandle h g) where type HandleMonad (TlsHandle h g) = TlsM h g type DebugLevel (TlsHandle h g) = DebugLevel h hlPut (TlsHandleS t) = hlPut t- hlGet = hlGetRn rehandshake . tlsHandleS- hlGetLine = hlGetLineRn rehandshake . tlsHandleS- hlGetContent = hlGetContentRn rehandshake . tlsHandleS+ hlGet = adGet rehandshake . tlsHandleS+ hlGetLine = adGetLine rehandshake . tlsHandleS+ hlGetContent = adGetContent rehandshake . tlsHandleS hlDebug (TlsHandleS t) = hlDebug t hlClose (TlsHandleS t) = hlClose t @@ -78,7 +99,7 @@ [(CertSecretKey, X509.CertificateChain)] -> Maybe X509.CertificateStore -> TlsM h g (TlsHandle h g) open h cssv crts mcs = liftM TlsHandleS . execHandshakeM h $- ((>>) <$> setSettings <*> handshake) (cssv',+ ((>>) <$> setSettingsS <*> handshake) (cssv', first rsaKey <$> find (isRsaKey . fst) crts, first ecdsaKey <$> find (isEcdsaKey . fst) crts, mcs ) where@@ -91,12 +112,36 @@ iscs EMPTY_RENEGOTIATION_INFO = False iscs _ = True +setCipherSuites :: (ValidateHandle h, CPRG g) => TlsHandle h g ->+ [CipherSuite] -> TlsM h g ()+setCipherSuites (TlsHandleS t) cssv = rerunHandshakeM t $ do+ (_, rcrt, ecrt, mcs) <- getSettingsS+ setSettingsS (cssv, rcrt, ecrt, mcs)++setKeyCerts :: (ValidateHandle h, CPRG g) => TlsHandle h g ->+ [(CertSecretKey, X509.CertificateChain)] -> TlsM h g ()+setKeyCerts (TlsHandleS t) crts = rerunHandshakeM t $ do+ (cssv, _, _, mcs) <- getSettingsS+ setSettingsS (cssv,+ first rsaKey <$> find (isRsaKey . fst) crts,+ first ecdsaKey <$> find (isEcdsaKey . fst) crts, mcs)++setCertificateStore :: (ValidateHandle h, CPRG g) => TlsHandle h g ->+ Maybe X509.CertificateStore -> TlsM h g ()+setCertificateStore (TlsHandleS t) mcs = rerunHandshakeM t $ do+ (cssv, rcrt, ecrt, _) <- getSettingsS+ setSettingsS (cssv, rcrt, ecrt, mcs)+ renegotiate :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g ()-renegotiate (TlsHandleS t) = rerunHandshakeM t $ writeHandshakeNH HHelloReq >>- flushAppData >>= flip when (handshake =<< getSettings)+renegotiate (TlsHandleS t) = rerunHandshakeM t $ do+ writeHandshake HHelloReq+ debug "low" ("before flushAppData" :: String)+ ne <- flushAppData+ debug "low" ("after flushAppData" :: String)+ when ne (handshake =<< getSettingsS) -rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle_ h g -> TlsM h g ()-rehandshake t = rerunHandshakeM t $ handshake =<< getSettings+rehandshake :: (ValidateHandle h, CPRG g) => TlsHandleBase h g -> TlsM h g ()+rehandshake t = rerunHandshakeM t $ handshake =<< getSettingsS handshake :: (ValidateHandle h, CPRG g) => SettingsS -> HandshakeM h g () handshake (cssv, rcrt, ecrt, mcs) = do@@ -127,6 +172,29 @@ writeHandshake =<< finishedHash Server where pre = moduleName ++ ".handshake: " +secp256r1 :: ECC.Curve+secp256r1 = ECC.getCurveByName ECC.SEC_p256r1++dh3072Modp :: DH.Params+dh3072Modp = DH.Params p 2+ where [(p, "")] = readHex $+ "ffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd1" +++ "29024e088a67cc74020bbea63b139b22514a08798e3404dd" +++ "ef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245" +++ "e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7ed" +++ "ee386bfb5a899fa5ae9f24117c4b1fe649286651ece45b3d" +++ "c2007cb8a163bf0598da48361c55d39a69163fa8fd24cf5f" +++ "83655d23dca3ad961c62f356208552bb9ed529077096966d" +++ "670c354e4abc9804f1746c08ca18217c32905e462e36ce3b" +++ "e39e772c180e86039b2783a2ec07a28fb5c55df06f4c52c9" +++ "de2bcbf6955817183995497cea956ae515d2261898fa0510" +++ "15728e5a8aaac42dad33170d04507a33a85521abdf1cba64" +++ "ecfb850458dbef0a8aea71575d060c7db3970f85a6e1e4c7" +++ "abf5ae8cdb0933d71e8c94e04a25619dcee3d2261ad2ee6b" +++ "f12ffa06d98a0864d87602733ec86a64521f2b18177b200c" +++ "bbe117577a615d6c770988c0bad946e208e24fa074e5ab31" +++ "43db5bfce0fd108e4b82d120a93ad2caffffffffffffffff"+ clientHello :: (HandleLike h, CPRG g) => [CipherSuite] -> HandshakeM h g (KeyEx, BulkEnc, BS.ByteString, Version) clientHello cssv = do@@ -147,12 +215,12 @@ checkRenegoInfo :: HandleLike h => [CipherSuite] -> Maybe [Extension] -> HandshakeM h g ()-checkRenegoInfo cscl me = (\n -> maybe n checkClientRenego mcf) . throwError+checkRenegoInfo cscl me = (\n -> maybe n checkClRenego mcf) . throwError ALFatal ADInsufficientSecurity $ moduleName ++ ".checkRenego: require secure renegotiation" where mcf = case (EMPTY_RENEGOTIATION_INFO `elem` cscl, me) of- (True, _) -> Just ""- (_, Just e) -> listToMaybe $ mapMaybe eRenegoInfo e+ (True, _) -> Just emptyRenegoInfo+ (_, Just e) -> find isRenegoInfo e (_, _) -> Nothing serverHello :: (HandleLike h, CPRG g) =>@@ -167,7 +235,7 @@ sr <- randomByteString 32 writeHandshake . ServerHello version sr (SessionId "") cs CompMethodNull- . Just . (: []) =<< makeServerRenego+ . Just . (: []) =<< makeSvRenego writeHandshake =<< case (ke, rcc, ecc) of (ECDHE_ECDSA, _, Just c) -> return c (_, Just c, _) -> return c@@ -183,13 +251,14 @@ generateKeys Server rs =<< mkpms epms `catchError` const ((BS.cons vj . BS.cons vn) `liftM` randomByteString 46) where mkpms epms = do- pms <- decryptRsa sk epms+ pms <- either (E.throwError . strMsg . show) return =<<+ withRandom (\g -> RSA.decryptSafer g sk epms) unless (BS.length pms == 48) $ throwError ALFatal ADHsFailure "" let [pvj, pvn] = BS.unpack $ BS.take 2 pms unless (pvj == vj && pvn == vn) $ throwError ALFatal ADHsFailure "" return pms -dhKeyExchange :: (ValidateHandle h, CPRG g, SecretKey sk,+dhKeyExchange :: (ValidateHandle h, CPRG g, SvSignSecretKey sk, DhParam dp, B.Bytable dp, B.Bytable (Public dp)) => HashAlg -> dp -> sk -> (BS.ByteString, BS.ByteString) -> Maybe X509.CertificateStore -> HandshakeM h g (Maybe X509.PubKey)@@ -198,10 +267,10 @@ bl <- withRandom $ generateBlinder sk let pv = B.encode $ calculatePublic dp sv writeHandshake- . ServerKeyEx (B.encode dp) pv ha (signatureAlgorithm sk)- . sign ha bl sk $ BS.concat [cr, sr, B.encode dp, pv]+ . ServerKeyEx (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- ClientKeyExchange cke <- readHandshake+ ClientKeyEx cke <- readHandshake generateKeys Server rs . calculateShared dp sv =<< either (throwError ALFatal ADInternalError . (moduleName ++) . (".dhKeyExchange: " ++))@@ -210,7 +279,7 @@ reqAndCert :: (ValidateHandle h, CPRG g) => Maybe X509.CertificateStore -> HandshakeM h g (Maybe X509.PubKey) reqAndCert mcs = do- flip (maybe $ return ()) mcs $ writeHandshake . certificateRequest+ flip (maybe $ return ()) mcs $ writeHandshake . certReq [CTRsaSign, CTEcdsaSign] [(Sha256, Rsa), (Sha256, Ecdsa)] writeHandshake SHDone flip (maybe $ return Nothing) mcs $ liftM Just . \cs -> do
src/Network/PeyoTLS/State.hs view
@@ -16,7 +16,7 @@ getServerFinished, setServerFinished, SettingsS, Settings,- CertSecretKey(..),+ CertSecretKey(..), isRsaKey, isEcdsaKey, ) where import Control.Applicative ((<$>))@@ -30,7 +30,7 @@ import qualified Data.ByteString as BS import qualified Codec.Bytable.BigEndian as B -import Network.PeyoTLS.CertSecretKey (CertSecretKey(..))+import Network.PeyoTLS.CertSecretKey (CertSecretKey(..), isRsaKey, isEcdsaKey) import qualified Data.X509 as X509 import qualified Data.X509.CertificateStore as X509 @@ -85,14 +85,6 @@ revertSettings (cs, rcrt, ecrt, mcs) = (cs, maybeToList (first RsaKey <$> rcrt) ++ maybeToList (first EcdsaKey <$> ecrt), mcs)--isEcdsaKey :: CertSecretKey -> Bool-isEcdsaKey (EcdsaKey _) = True-isEcdsaKey _ = False--isRsaKey :: CertSecretKey -> Bool-isRsaKey (RsaKey _) = True-isRsaKey _ = False data StateOne g = StateOne { sKeys :: Keys,
src/Network/PeyoTLS/Types.hs view
@@ -1,16 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.PeyoTLS.Types ( Extension(..),+module Network.PeyoTLS.Types ( Handshake(..), HandshakeItem(..), ClientHello(..), ServerHello(..), SessionId(..), CipherSuite(..), KeyEx(..), BulkEnc(..),- CompMethod(..),- ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),- CertReq(..), certificateRequest, ClientCertificateType(..),+ CompMethod(..), Extension(..), isRenegoInfo, emptyRenegoInfo,+ ServerKeyEx(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),+ CertReq(..), certReq, ClCertType(..), SignAlg(..), HashAlg(..),- ServerHelloDone(..), ClientKeyExchange(..), Epms(..),- DigitallySigned(..), Finished(..) ) where+ ServerHelloDone(..), ClientKeyEx(..), Epms(..),+ DigitallySigned(..), Finished(..),+ ChangeCipherSpec(..), ) where import Control.Applicative ((<$>), (<*>)) import Control.Monad (unless)@@ -28,15 +29,15 @@ CipherSuite(..), KeyEx(..), BulkEnc(..), CompMethod(..), HashAlg(..), SignAlg(..) ) import Network.PeyoTLS.Certificate (- CertReq(..), certificateRequest, ClientCertificateType(..),- ClientKeyExchange(..), DigitallySigned(..) )+ CertReq(..), certReq, ClCertType(..),+ ClientKeyEx(..), DigitallySigned(..) ) data Handshake = HHelloReq | HClientHello ClientHello | HServerHello ServerHello | HCertificate X509.CertificateChain | HServerKeyEx BS.ByteString | HCertificateReq CertReq | HServerHelloDone- | HCertVerify DigitallySigned | HClientKeyEx ClientKeyExchange+ | HCertVerify DigitallySigned | HClientKeyEx ClientKeyEx | HFinished BS.ByteString | HRaw Type BS.ByteString deriving Show @@ -103,7 +104,7 @@ fromHandshake _ = Nothing toHandshake = HCertificate -data ServerKeyExchange = ServerKeyEx BS.ByteString BS.ByteString+data ServerKeyEx = ServerKeyEx BS.ByteString BS.ByteString HashAlg SignAlg BS.ByteString deriving Show data ServerKeyExDhe = ServerKeyExDhe DH.Params DH.PublicNumber@@ -112,7 +113,7 @@ data ServerKeyExEcdhe = ServerKeyExEcdhe ECC.Curve ECC.Point HashAlg SignAlg BS.ByteString deriving Show -instance HandshakeItem ServerKeyExchange where+instance HandshakeItem ServerKeyEx where fromHandshake = undefined toHandshake = HServerKeyEx . B.encode @@ -128,7 +129,7 @@ either (const Nothing) Just $ B.decode ske fromHandshake _ = Nothing -instance B.Bytable ServerKeyExchange where+instance B.Bytable ServerKeyEx where decode = undefined encode (ServerKeyEx ps pv ha sa sn) = BS.concat [ ps, pv, B.encode ha, B.encode sa,@@ -178,7 +179,7 @@ fromHandshake _ = Nothing toHandshake = HCertVerify -instance HandshakeItem ClientKeyExchange where+instance HandshakeItem ClientKeyEx where fromHandshake (HClientKeyEx cke) = Just cke fromHandshake _ = Nothing toHandshake = HClientKeyEx@@ -190,13 +191,13 @@ fromHandshake _ = Nothing toHandshake = HClientKeyEx . epmsToCke -ckeToEpms :: ClientKeyExchange -> Maybe Epms-ckeToEpms (ClientKeyExchange cke) = case B.runBytableM (B.take =<< B.take 2) cke of+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 -> ClientKeyExchange-epmsToCke (Epms epms) = ClientKeyExchange $ B.addLen (undefined :: Word16) epms+epmsToCke :: Epms -> ClientKeyEx+epmsToCke (Epms epms) = ClientKeyEx $ B.addLen (undefined :: Word16) epms data Finished = Finished BS.ByteString deriving (Show, Eq) @@ -238,3 +239,20 @@ 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 ""
test/testReneg.hs view
@@ -32,7 +32,8 @@ ] randomFrom :: [a] -> IO [a]-randomFrom [] = return []+randomFrom [] = error "bad"+randomFrom [x] = return [x] randomFrom (x : xs) = do b <- randomIO (if b then (x :) else id) <$> randomFrom xs