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(..),
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.Arrow (first)
import Control.Monad (unless, liftM, ap)
import "monads-tf" Control.Monad.State (gets, lift)
import Data.Bits (shiftR)
import Data.HandleLike (HandleLike(..))
import System.IO (Handle)
import "crypto-random" Crypto.Random (CPRG, SystemRNG, cprgGenerate)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ASN1.Types as ASN1
import qualified Data.ASN1.Encoding as ASN1
import qualified Data.ASN1.BinaryEncoding as ASN1
import qualified Codec.Bytable.BigEndian as B
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Crypto.PubKey.RSA.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
import qualified Crypto.PubKey.ECC.Prim as ECC
import qualified Crypto.Types.PubKey.ECDSA as ECDSA
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.HashDescr as HD
import qualified Crypto.PubKey.RSA.PKCS15 as RSA
import 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(..), 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,
ValidateHandle(..), handshakeValidate, validateAlert,
AlertLevel(..), AlertDesc(..), debugCipherSuite, throwError )
import Network.PeyoTLS.Ecdsa (blindSign, makeKs, makeEcdsaPubKey)
moduleName :: String
moduleName = "Network.PeyoTLS.Base"
type PeyotlsM = TlsM Handle SystemRNG
debug :: (HandleLike h, Show a) => DebugLevel h -> a -> HandshakeM h g ()
debug p x = do
h <- gets $ tlsHandle . fst
lift . lift . lift . hlDebug h p . BSC.pack . (++ "\n") $ show x
readHandshake :: (HandleLike h, CPRG g, HandshakeItem hi) => HandshakeM h g hi
readHandshake = do
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
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) => HandshakeM h g ()
getChangeCipherSpec = do
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) => HandshakeM h g ()
putChangeCipherSpec = ccsPut . (\[w] -> w) . BS.unpack $ B.encode ChangeCipherSpec
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
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"
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
type Public b
generateSecret :: CPRG g => b -> g -> (Secret b, g)
calculatePublic :: b -> Secret b -> Public b
calculateShared :: b -> Secret b -> Public b -> BS.ByteString
instance DhParam DH.Params where
type Secret DH.Params = DH.PrivateNumber
type Public DH.Params = DH.PublicNumber
generateSecret = flip DH.generatePrivate
calculatePublic = DH.calculatePublic
calculateShared =
(((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 = 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
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]
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
sspAlgorithm :: pk -> SignAlg
ssVerify :: HashAlg -> pk -> BS.ByteString -> BS.ByteString -> Bool
instance SvSignPublicKey RSA.PublicKey where
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
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 SvSignSecretKey sk where
type Blinder sk
sssAlgorithm :: sk -> SignAlg
generateBlinder :: CPRG g => sk -> g -> (Blinder sk, g)
ssSign :: sk -> HashAlg -> Blinder sk -> BS.ByteString -> BS.ByteString
instance SvSignSecretKey RSA.PrivateKey where
type Blinder RSA.PrivateKey = RSA.Blinder
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 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 SvSignSecretKey ECDSA.PrivateKey where
type Blinder ECDSA.PrivateKey = Integer
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 $ moduleName ++ ": ECDSA.PrivateKey.ssSign"
q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk
x = ECDSA.private_d sk
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
instance ClSignSecretKey RSA.PrivateKey where
cssAlgorithm _ = (Sha256, Rsa)
csSign sk m = RSA.dp Nothing sk $ padding (RSA.private_pub sk) m
instance ClSignSecretKey ECDSA.PrivateKey where
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
enc (ECDSA.Signature r s) = ASN1.encodeASN1' ASN1.DER [
ASN1.Start ASN1.Sequence,
ASN1.IntVal r, ASN1.IntVal s,
ASN1.End ASN1.Sequence]