module Network.PeyoTLS.Server (
run, open, names,
CipherSuite(..), KeyExchange(..), BulkEncryption(..),
PeyotlsM, PeyotlsHandle,
TlsM, TlsHandle,
ValidateHandle(..), CertSecretKey ) where
import Control.Monad (unless, liftM, ap)
import "monads-tf" Control.Monad.Error (catchError, lift)
import qualified "monads-tf" Control.Monad.Error as E (throwError)
import "monads-tf" Control.Monad.Error.Class (strMsg)
import Data.List (find)
import Data.Word (Word8)
import Data.HandleLike (HandleLike(..))
import "crypto-random" Crypto.Random (CPRG)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.X509 as X509
import qualified Data.X509.Validation as X509
import qualified Data.X509.CertificateStore as X509
import qualified Codec.Bytable.BigEndian as B
import qualified Crypto.PubKey.RSA as RSA
import qualified Crypto.PubKey.RSA.Prim as RSA
import qualified Crypto.Types.PubKey.ECC as ECC
import qualified Crypto.Types.PubKey.ECDSA as ECDSA
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import Network.PeyoTLS.HandshakeBase ( debug, Extension(..),
PeyotlsM, PeyotlsHandle,
TlsM, run, HandshakeM, execHandshakeM, withRandom, randomByteString,
TlsHandle, names,
readHandshake, getChangeCipherSpec,
writeHandshake, putChangeCipherSpec,
ValidateHandle(..), handshakeValidate,
AlertLevel(..), AlertDesc(..),
ServerKeyExchange(..), ServerHelloDone(..),
ClientHello(..), ServerHello(..), SessionId(..),
CipherSuite(..), KeyExchange(..), BulkEncryption(..),
CompressionMethod(..), HashAlg(..), SignAlg(..),
setCipherSuite,
certificateRequest, ClientCertificateType(..), SecretKey(..),
ClientKeyExchange(..), Epms(..),
generateKeys, decryptRsa, rsaPadding, debugCipherSuite,
DigitallySigned(..), handshakeHash, flushCipherSuite,
Side(..), RW(..), finishedHash,
DhParam(..), dh3072Modp, secp256r1, throwError,
CertSecretKey(..) )
type Version = (Word8, Word8)
version :: Version
version = (3, 3)
filterCS :: [(CertSecretKey, X509.CertificateChain)] ->
[CipherSuite] -> [CipherSuite]
filterCS crts cs = case find isEcdsa crts of
Just _ -> cs
_ -> filter (not . isEcdsaCS) cs
isEcdsa :: (CertSecretKey, X509.CertificateChain) -> Bool
isEcdsa (EcdsaKey _, _) = True
isEcdsa _ = False
isRsa :: (CertSecretKey, X509.CertificateChain) -> Bool
isRsa (RsaKey _, _) = True
isRsa _ = False
isEcdsaCS :: CipherSuite -> Bool
isEcdsaCS (CipherSuite ECDHE_ECDSA _) = True
isEcdsaCS _ = False
open :: (ValidateHandle h, CPRG g) => h ->
[CipherSuite] ->
[(CertSecretKey, X509.CertificateChain)] ->
Maybe X509.CertificateStore -> TlsM h g (TlsHandle h g)
open h cssv crts mcs = execHandshakeM h $ do
(cs@(CipherSuite ke be), cr, cv, rn) <- clientHello $ filterCS crts cssv
sr <- serverHello cs rcc ecc rn
setCipherSuite cs
ha <- case be of
AES_128_CBC_SHA -> return Sha1
AES_128_CBC_SHA256 -> return Sha256
_ -> E.throwError
"TlsServer.open: not implemented bulk encryption type"
lift . lift . lift . hlDebug h "critical" . BSC.pack . (++ "\n") . show .
RSA.public_size $ RSA.private_pub rsk
mpk <- (\kep -> kep (cr, sr) mcs) $ case ke of
RSA -> rsaKeyExchange rsk cv
DHE_RSA -> dhKeyExchange ha dh3072Modp rsk
ECDHE_RSA -> dhKeyExchange ha secp256r1 rsk
ECDHE_ECDSA -> dhKeyExchange ha secp256r1 esk
_ -> \_ _ -> E.throwError
"TlsServer.open: not implemented key exchange type"
maybe (return ()) certificateVerify mpk
getChangeCipherSpec >> flushCipherSuite Read
fok <- (==) `liftM` finishedHash Client `ap` readHandshake
unless fok $ throwError ALFatal ADDecryptError
"TlsServer.open: wrong finished hash"
putChangeCipherSpec >> flushCipherSuite Write
writeHandshake =<< finishedHash Server
where
Just (RsaKey rsk, rcc) = find isRsa crts
Just (EcdsaKey esk, ecc) = find isEcdsa crts
rsaKeyExchange :: (ValidateHandle h, CPRG g) => RSA.PrivateKey -> Version ->
(BS.ByteString, BS.ByteString) -> Maybe X509.CertificateStore ->
HandshakeM h g (Maybe X509.PubKey)
rsaKeyExchange rsk cv rs mcs = return const
`ap` requestAndCertificate mcs
`ap` rsaClientKeyExchange rsk cv rs
dhKeyExchange :: (ValidateHandle h, CPRG g, SecretKey sk, Show (Secret dp),
Show (Public dp),
DhParam dp, B.Bytable dp, B.Bytable (Public dp)) =>
HashAlg -> dp -> sk ->
(BS.ByteString, BS.ByteString) -> Maybe X509.CertificateStore ->
HandshakeM h g (Maybe X509.PubKey)
dhKeyExchange ha dp ssk rs mcs = do
sv <- withRandom $ generateSecret dp
serverKeyExchange ha dp sv ssk rs
return const
`ap` requestAndCertificate mcs
`ap` dhClientKeyExchange dp sv rs
clientHello :: (HandleLike h, CPRG g) =>
[CipherSuite] -> HandshakeM h g (CipherSuite, BS.ByteString, Version, Bool)
clientHello cssv = do
ClientHello cv cr _sid cscl cms e <- readHandshake
debug e
let rn = maybe False (ERenegoInfo "" `elem`) e
debug rn
chk cv cscl cms >> return (merge cssv cscl, cr, cv, rn)
where
merge sv cl = case find (`elem` cl) sv of
Just cs -> cs; _ -> CipherSuite RSA AES_128_CBC_SHA
chk cv css cms
| cv < version = throwError ALFatal ADProtocolVersion $
pmsg ++ "client version should 3.3 or more"
| CompressionMethodNull `notElem` cms =
throwError ALFatal ADDecodeError $
pmsg ++ "compression method NULL must be supported"
| otherwise = return ()
where pmsg = "TlsServer.clientHello: "
serverHello :: (HandleLike h, CPRG g) => CipherSuite ->
X509.CertificateChain -> X509.CertificateChain -> Bool ->
HandshakeM h g BS.ByteString
serverHello cs@(CipherSuite ke _) rcc ecc rn = do
sr <- randomByteString 32
writeHandshake . ServerHello
version sr (SessionId "") cs CompressionMethodNull $ if rn
then Just [ERenegoInfo ""]
else Nothing
writeHandshake $ case ke of ECDHE_ECDSA -> ecc; _ -> rcc
return sr
serverHello _ _ _ _ = E.throwError "TlsServer.serverHello: never occur"
serverKeyExchange :: (HandleLike h, CPRG g, SecretKey sk,
DhParam dp, B.Bytable dp, B.Bytable (Public dp)) =>
HashAlg -> dp -> Secret dp -> sk ->
(BS.ByteString, BS.ByteString) -> HandshakeM h g ()
serverKeyExchange ha dp sv ssk (cr, sr) = do
bl <- withRandom $ generateBlinder ssk
writeHandshake
. ServerKeyEx edp pv ha (signatureAlgorithm ssk)
. sign ha bl ssk $ BS.concat [cr, sr, edp, pv]
where
edp = B.encode dp
pv = B.encode $ calculatePublic dp sv
requestAndCertificate :: (ValidateHandle h, CPRG g) =>
Maybe X509.CertificateStore -> HandshakeM h g (Maybe X509.PubKey)
requestAndCertificate mcs = do
flip (maybe $ return ()) mcs $ writeHandshake . certificateRequest
[CTRsaSign, CTEcdsaSign] [(Sha256, Rsa), (Sha256, Ecdsa)]
writeHandshake ServerHelloDone
maybe (return Nothing) (liftM Just . clientCertificate) mcs
clientCertificate :: (ValidateHandle h, CPRG g) =>
X509.CertificateStore -> HandshakeM h g X509.PubKey
clientCertificate cs = do
cc@(X509.CertificateChain (c : _)) <- readHandshake
chk cc
return . X509.certPubKey $ X509.getCertificate c
where
chk cc = do
rs <- handshakeValidate cs cc
unless (null rs) . throwError ALFatal (selectAlert rs) $
"TlsServer.clientCertificate: " ++ show rs
selectAlert rs
| X509.UnknownCA `elem` rs = ADUnknownCa
| X509.Expired `elem` rs = ADCertificateExpired
| X509.InFuture `elem` rs = ADCertificateExpired
| otherwise = ADCertificateUnknown
rsaClientKeyExchange :: (HandleLike h, CPRG g) => RSA.PrivateKey ->
Version -> (BS.ByteString, BS.ByteString) -> HandshakeM h g ()
rsaClientKeyExchange sk (cvj, cvn) rs = do
Epms epms <- readHandshake
generateKeys Server rs =<< mkpms epms `catchError` const
((BS.cons cvj . BS.cons cvn) `liftM` randomByteString 46)
where
mkpms epms = do
pms <- decryptRsa sk epms
unless (BS.length pms == 48) $ E.throwError "mkpms: length"
case BS.unpack $ BS.take 2 pms of
[pvj, pvn] -> unless (pvj == cvj && pvn == cvn) $
E.throwError "mkpms: version"
_ -> E.throwError "mkpms: never occur"
return pms
dhClientKeyExchange :: (HandleLike h, CPRG g, DhParam dp, B.Bytable (Public dp),
Show (Public dp)) =>
dp -> Secret dp -> (BS.ByteString, BS.ByteString) -> HandshakeM h g ()
dhClientKeyExchange dp sv rs = do
ClientKeyExchange cke <- readHandshake
let Right pv = B.decode cke
generateKeys Server rs =<< case Right $ calculateShared dp sv pv of
Left em -> E.throwError . strMsg $
"TlsServer.dhClientKeyExchange: " ++ em
Right sh -> return sh
certificateVerify :: (HandleLike h, CPRG g) => X509.PubKey -> HandshakeM h g ()
certificateVerify (X509.PubKeyRSA pk) = do
debugCipherSuite "RSA"
hs0 <- rsaPadding pk `liftM` handshakeHash
DigitallySigned a s <- readHandshake
case a of
(Sha256, Rsa) -> return ()
_ -> throwError ALFatal ADDecodeError $
"TlsServer.certificateVEerify: not implement: " ++ show a
unless (RSA.ep pk s == hs0) $ throwError ALFatal ADDecryptError
"TlsServer.certificateVerify: client auth failed "
certificateVerify (X509.PubKeyECDSA ECC.SEC_p256r1 xy) = do
debugCipherSuite "ECDSA"
hs0 <- handshakeHash
DigitallySigned a s <- readHandshake
case a of
(Sha256, Ecdsa) -> return ()
_ -> throwError ALFatal ADDecodeError $
"TlsServer.certificateverify: not implement: " ++ show a
unless (ECDSA.verify id
(ECDSA.PublicKey secp256r1 $ pnt xy)
(either error id $ B.decode s) hs0) $ throwError
ALFatal ADDecryptError
"TlsServer.certificateverify: client auth failed"
where
pnt s = let (x, y) = BS.splitAt 32 $ BS.drop 1 s in ECC.Point
(either error id $ B.decode x)
(either error id $ B.decode y)
certificateVerify p = throwError ALFatal ADUnsupportedCertificate $
"TlsServer.certificateVerify: not implement: " ++ show p