diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2010 Vincent Hanquez + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Network/TLS/Cipher.hs b/Network/TLS/Cipher.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Cipher.hs @@ -0,0 +1,268 @@ +-- | +-- Module : Network.TLS.Cipher +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.TLS.Cipher + ( CipherTypeFunctions(..) + , CipherKeyExchangeType(..) + , Cipher(..) + , cipherExchangeNeedMoreData + + -- * builtin ciphers for ease of use, might move later to a tls-ciphers library + , cipher_null_null + , cipher_RC4_128_MD5 + , cipher_RC4_128_SHA1 + , cipher_AES128_SHA1 + , cipher_AES256_SHA1 + , cipher_AES128_SHA256 + , cipher_AES256_SHA256 + ) where + +import Data.Word +import Network.TLS.Struct (Version(..)) +import Network.TLS.MAC +import qualified Data.Vector.Unboxed as Vector (fromList, toList) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as B + +import qualified Codec.Crypto.AES as AES +import qualified Crypto.Cipher.RC4 as RC4 + +-- FIXME convert to newtype +type Key = B.ByteString +type IV = B.ByteString + +data CipherTypeFunctions = + CipherNoneF -- special value for 0 + | CipherBlockF (Key -> IV -> L.ByteString -> L.ByteString) + (Key -> IV -> L.ByteString -> L.ByteString) + | CipherStreamF (Key -> IV) + (IV -> L.ByteString -> (L.ByteString, IV)) + (IV -> L.ByteString -> (L.ByteString, IV)) + +data CipherKeyExchangeType = + CipherKeyExchangeRSA + | CipherKeyExchangeDHE_RSA + | CipherKeyExchangeECDHE_RSA + | CipherKeyExchangeDHE_DSS + | CipherKeyExchangeDH_DSS + | CipherKeyExchangeDH_RSA + | CipherKeyExchangeECDH_ECDSA + | CipherKeyExchangeECDH_RSA + | CipherKeyExchangeECDHE_ECDSA + +data Cipher = Cipher + { cipherID :: Word16 + , cipherName :: String + , cipherDigestSize :: Word8 + , cipherKeySize :: Word8 + , cipherIVSize :: Word8 + , cipherKeyBlockSize :: Word8 + , cipherPaddingSize :: Word8 + , cipherKeyExchange :: CipherKeyExchangeType + , cipherHMAC :: L.ByteString -> L.ByteString -> L.ByteString + , cipherF :: CipherTypeFunctions + , cipherMinVer :: Maybe Version + } + +instance Show Cipher where + show c = cipherName c + +cipherExchangeNeedMoreData :: CipherKeyExchangeType -> Bool +cipherExchangeNeedMoreData CipherKeyExchangeRSA = False +cipherExchangeNeedMoreData CipherKeyExchangeDHE_RSA = True +cipherExchangeNeedMoreData CipherKeyExchangeECDHE_RSA = True +cipherExchangeNeedMoreData CipherKeyExchangeDHE_DSS = True +cipherExchangeNeedMoreData CipherKeyExchangeDH_DSS = False +cipherExchangeNeedMoreData CipherKeyExchangeDH_RSA = False +cipherExchangeNeedMoreData CipherKeyExchangeECDH_ECDSA = True +cipherExchangeNeedMoreData CipherKeyExchangeECDH_RSA = True +cipherExchangeNeedMoreData CipherKeyExchangeECDHE_ECDSA = True + +repack :: Int -> L.ByteString -> [B.ByteString] +repack bs x = + if L.length x > fromIntegral bs + then + let (c1, c2) = L.splitAt (fromIntegral bs) x in + B.pack (L.unpack c1) : repack 16 c2 + else + [ B.pack (L.unpack x) ] + +aes128_cbc_encrypt :: Key -> IV -> L.ByteString -> L.ByteString +aes128_cbc_encrypt key iv d = AES.crypt AES.CBC key iv AES.Encrypt d16 + where d16 = L.fromChunks $ repack 16 d + +aes128_cbc_decrypt :: Key -> IV -> L.ByteString -> L.ByteString +aes128_cbc_decrypt key iv d = AES.crypt AES.CBC key iv AES.Decrypt d16 + where d16 = L.fromChunks $ repack 16 d + +aes256_cbc_encrypt :: Key -> IV -> L.ByteString -> L.ByteString +aes256_cbc_encrypt key iv d = AES.crypt AES.CBC key iv AES.Encrypt d16 + where d16 = L.fromChunks $ repack 16 d + +aes256_cbc_decrypt :: Key -> IV -> L.ByteString -> L.ByteString +aes256_cbc_decrypt key iv d = AES.crypt AES.CBC key iv AES.Decrypt d16 + where d16 = L.fromChunks $ repack 32 d + +toIV :: RC4.Ctx -> IV +toIV (v, x, y) = B.pack (x : y : Vector.toList v) + +toCtx :: IV -> RC4.Ctx +toCtx iv = + case B.unpack iv of + x:y:l -> (Vector.fromList l, x, y) + _ -> (Vector.fromList [], 0, 0) + +initF_rc4 :: Key -> IV +initF_rc4 key = toIV $ RC4.initCtx (B.unpack key) + +encryptF_rc4 :: IV -> L.ByteString -> (L.ByteString, IV) +encryptF_rc4 iv d = (\(ctx, e) -> (e, toIV ctx)) $ RC4.encryptlazy (toCtx iv) d + +decryptF_rc4 :: IV -> L.ByteString -> (L.ByteString, IV) +decryptF_rc4 iv e = (\(ctx, d) -> (d, toIV ctx)) $ RC4.decryptlazy (toCtx iv) e + +{- +TLS 1.0 ciphers definition + +CipherSuite TLS_NULL_WITH_NULL_NULL = { 0x00,0x00 }; +CipherSuite TLS_RSA_WITH_NULL_MD5 = { 0x00,0x01 }; +CipherSuite TLS_RSA_WITH_NULL_SHA = { 0x00,0x02 }; +CipherSuite TLS_RSA_EXPORT_WITH_RC4_40_MD5 = { 0x00,0x03 }; +CipherSuite TLS_RSA_WITH_RC4_128_MD5 = { 0x00,0x04 }; +CipherSuite TLS_RSA_WITH_RC4_128_SHA = { 0x00,0x05 }; +CipherSuite TLS_RSA_EXPORT_WITH_RC2_CBC_40_MD5 = { 0x00,0x06 }; +CipherSuite TLS_RSA_WITH_IDEA_CBC_SHA = { 0x00,0x07 }; +CipherSuite TLS_RSA_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x08 }; +CipherSuite TLS_RSA_WITH_DES_CBC_SHA = { 0x00,0x09 }; +CipherSuite TLS_RSA_WITH_3DES_EDE_CBC_SHA = { 0x00,0x0A }; +CipherSuite TLS_DH_DSS_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x0B }; +CipherSuite TLS_DH_DSS_WITH_DES_CBC_SHA = { 0x00,0x0C }; +CipherSuite TLS_DH_DSS_WITH_3DES_EDE_CBC_SHA = { 0x00,0x0D }; +CipherSuite TLS_DH_RSA_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x0E }; +CipherSuite TLS_DH_RSA_WITH_DES_CBC_SHA = { 0x00,0x0F }; +CipherSuite TLS_DH_RSA_WITH_3DES_EDE_CBC_SHA = { 0x00,0x10 }; +CipherSuite TLS_DHE_DSS_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x11 }; +CipherSuite TLS_DHE_DSS_WITH_DES_CBC_SHA = { 0x00,0x12 }; +CipherSuite TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA = { 0x00,0x13 }; +CipherSuite TLS_DHE_RSA_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x14 }; +CipherSuite TLS_DHE_RSA_WITH_DES_CBC_SHA = { 0x00,0x15 }; +CipherSuite TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA = { 0x00,0x16 }; +CipherSuite TLS_DH_anon_EXPORT_WITH_RC4_40_MD5 = { 0x00,0x17 }; +CipherSuite TLS_DH_anon_WITH_RC4_128_MD5 = { 0x00,0x18 }; +CipherSuite TLS_DH_anon_EXPORT_WITH_DES40_CBC_SHA = { 0x00,0x19 }; +CipherSuite TLS_DH_anon_WITH_DES_CBC_SHA = { 0x00,0x1A }; +CipherSuite TLS_DH_anon_WITH_3DES_EDE_CBC_SHA = { 0x00,0x1B }; +-} + +{- + - some builtin ciphers description + -} + +cipher_null_null :: Cipher +cipher_null_null = Cipher + { cipherID = 0x0 + , cipherName = "null-null" + , cipherDigestSize = 0 + , cipherKeySize = 0 + , cipherIVSize = 0 + , cipherKeyBlockSize = 0 + , cipherPaddingSize = 0 + , cipherHMAC = (\_ _ -> L.empty) + , cipherKeyExchange = CipherKeyExchangeRSA + , cipherF = CipherNoneF + , cipherMinVer = Nothing + } + +cipher_RC4_128_MD5 :: Cipher +cipher_RC4_128_MD5 = Cipher + { cipherID = 0x04 + , cipherName = "RSA-rc4-128-md5" + , cipherDigestSize = 16 + , cipherKeySize = 16 + , cipherIVSize = 0 + , cipherKeyBlockSize = 2 * (16 + 16 + 0) + , cipherPaddingSize = 0 + , cipherHMAC = hmacMD5 + , cipherKeyExchange = CipherKeyExchangeRSA + , cipherF = CipherStreamF initF_rc4 encryptF_rc4 decryptF_rc4 + , cipherMinVer = Nothing + } + +cipher_RC4_128_SHA1 :: Cipher +cipher_RC4_128_SHA1 = Cipher + { cipherID = 0x05 + , cipherName = "RSA-rc4-128-sha1" + , cipherDigestSize = 20 + , cipherKeySize = 16 + , cipherIVSize = 0 + , cipherKeyBlockSize = 2 * (20 + 16 + 0) + , cipherPaddingSize = 0 + , cipherHMAC = hmacSHA1 + , cipherKeyExchange = CipherKeyExchangeRSA + , cipherF = CipherStreamF initF_rc4 encryptF_rc4 decryptF_rc4 + , cipherMinVer = Nothing + } + +cipher_AES128_SHA1 :: Cipher +cipher_AES128_SHA1 = Cipher + { cipherID = 0x2f + , cipherName = "RSA-aes128-sha1" + , cipherDigestSize = 20 + , cipherKeySize = 16 + , cipherIVSize = 16 + , cipherKeyBlockSize = 2 * (20 + 16 + 16) + , cipherPaddingSize = 16 + , cipherHMAC = hmacSHA1 + , cipherKeyExchange = CipherKeyExchangeRSA + , cipherF = CipherBlockF aes128_cbc_encrypt aes128_cbc_decrypt + , cipherMinVer = Just SSL3 + } + +cipher_AES256_SHA1 :: Cipher +cipher_AES256_SHA1 = Cipher + { cipherID = 0x35 + , cipherName = "RSA-aes256-sha1" + , cipherDigestSize = 20 + , cipherKeySize = 32 + , cipherIVSize = 16 + , cipherKeyBlockSize = 2 * (20 + 32 + 16) + , cipherPaddingSize = 16 + , cipherHMAC = hmacSHA1 + , cipherKeyExchange = CipherKeyExchangeRSA + , cipherF = CipherBlockF aes256_cbc_encrypt aes256_cbc_decrypt + , cipherMinVer = Just SSL3 + } + +cipher_AES128_SHA256 :: Cipher +cipher_AES128_SHA256 = Cipher + { cipherID = 0x3c + , cipherName = "RSA-aes128-sha256" + , cipherDigestSize = 32 + , cipherKeySize = 16 + , cipherIVSize = 16 + , cipherKeyBlockSize = 2 * (32 + 16 + 16) + , cipherPaddingSize = 16 + , cipherHMAC = hmacSHA256 + , cipherKeyExchange = CipherKeyExchangeRSA + , cipherF = CipherBlockF aes128_cbc_encrypt aes128_cbc_decrypt + , cipherMinVer = Just TLS12 + } + +cipher_AES256_SHA256 :: Cipher +cipher_AES256_SHA256 = Cipher + { cipherID = 0x3d + , cipherName = "RSA-aes256-sha256" + , cipherDigestSize = 32 + , cipherKeySize = 32 + , cipherIVSize = 16 + , cipherKeyBlockSize = 2 * (32 + 32 + 16) + , cipherPaddingSize = 16 + , cipherHMAC = hmacSHA256 + , cipherKeyExchange = CipherKeyExchangeRSA + , cipherF = CipherBlockF aes256_cbc_encrypt aes256_cbc_decrypt + , cipherMinVer = Just TLS12 + } diff --git a/Network/TLS/Client.hs b/Network/TLS/Client.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Client.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} + +-- | +-- Module : Network.TLS.Client +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- the Client module contains the necessary calls to create a connecting TLS socket +-- aka. a client socket. +-- +module Network.TLS.Client + ( TLSClientParams(..) + , TLSStateClient + , runTLSClient + -- * low level packet sending receiving. + , recvPacket + , sendPacket + -- * API, warning probably subject to change + , connect + , sendData + , recvData + , close + ) where + +import Data.Maybe +import Data.Word +import Control.Monad.Trans +import Control.Monad.State +import Data.Certificate.X509 +import Network.TLS.Cipher +import Network.TLS.Struct +import Network.TLS.Packet +import Network.TLS.State +import Network.TLS.Sending +import Network.TLS.Receiving +import Network.TLS.SRandom +import qualified Data.ByteString.Lazy as L +import System.IO (Handle, hFlush) +import Data.List (find) + +data TLSClientParams = TLSClientParams + { cpConnectVersion :: Version -- ^ client version we're sending by default + , cpAllowedVersions :: [Version] -- ^ allowed versions from the server + , cpSession :: Maybe [Word8] -- ^ session for this connection + , cpCiphers :: [Cipher] -- ^ all ciphers for this connection + , cpCertificate :: Maybe Certificate -- ^ an optional client certificate + } deriving (Show) + +data TLSStateClient = TLSStateClient + { scParams :: TLSClientParams -- ^ client params and config for this connection + , scTLSState :: TLSState -- ^ client TLS State for this connection + , scCertRequested :: Bool -- ^ mark that the server requested a certificate + } deriving (Show) + +newtype TLSClient m a = TLSClient { runTLSC :: StateT TLSStateClient m a } + deriving (Monad, MonadState TLSStateClient) + +instance Monad m => MonadTLSState (TLSClient m) where + getTLSState = TLSClient (get >>= return . scTLSState) + putTLSState s = TLSClient (get >>= put . (\st -> st { scTLSState = s })) + +instance MonadTrans TLSClient where + lift = TLSClient . lift + +instance Monad m => Functor (TLSClient m) where + fmap f = TLSClient . fmap f . runTLSC + +runTLSClientST :: TLSClient m a -> TLSStateClient -> m (a, TLSStateClient) +runTLSClientST f s = runStateT (runTLSC f) s + +runTLSClient :: TLSClient m a -> TLSClientParams -> SRandomGen -> m (a, TLSStateClient) +runTLSClient f params rng = runTLSClientST f (TLSStateClient { scParams = params, scTLSState = state, scCertRequested = False }) + where state = (newTLSState rng) { stVersion = TLS10, stClientContext = True } + +{- | receive a single TLS packet or on error a TLSError -} +recvPacket :: Handle -> TLSClient IO (Either TLSError Packet) +recvPacket handle = do + hdr <- lift $ L.hGet handle 5 >>= return . decodeHeader + case hdr of + Left err -> return $ Left err + Right header@(Header _ _ readlen) -> do + content <- lift $ L.hGet handle (fromIntegral readlen) + readPacket header (EncryptedData content) + +{- | send a single TLS packet -} +sendPacket :: Handle -> Packet -> TLSClient IO () +sendPacket handle pkt = do + dataToSend <- writePacket pkt + lift $ L.hPut handle dataToSend + +recvServerHello :: Handle -> TLSClient IO () +recvServerHello handle = do + ciphers <- fmap (cpCiphers . scParams) get + allowedvers <- fmap (cpAllowedVersions . scParams) get + pkt <- recvPacket handle + let hs = case pkt of + Right (Handshake h) -> h + Left err -> error ("error received: " ++ show err) + Right x -> error ("unexpected packet received, expecting handshake " ++ show x) + case hs of + ServerHello ver _ _ cipher _ _ -> do + case find ((==) ver) allowedvers of + Nothing -> error ("received version which is not allowed: " ++ show ver) + Just _ -> setVersion ver + + case find ((==) cipher . cipherID) ciphers of + Nothing -> error "no cipher in common with the server" + Just c -> setCipher c + recvServerHello handle + CertRequest _ _ _ -> modify (\sc -> sc { scCertRequested = True }) >> recvServerHello handle + Certificates _ -> recvServerHello handle + ServerHelloDone -> return () + _ -> error "unexpected handshake message received in server hello messages" + +connectSendClientHello :: Handle -> ClientRandom -> TLSClient IO () +connectSendClientHello handle crand = do + ver <- fmap (cpConnectVersion . scParams) get + ciphers <- fmap (cpCiphers . scParams) get + sendPacket handle $ Handshake (ClientHello ver crand (Session Nothing) (map cipherID ciphers) [ 0 ] Nothing) + +connectSendClientCertificate :: Handle -> TLSClient IO () +connectSendClientCertificate handle = do + certRequested <- fmap scCertRequested get + when certRequested $ do + clientCert <- fmap (cpCertificate . scParams) get + sendPacket handle $ Handshake (Certificates $ maybe [] (:[]) clientCert) + +connectSendClientKeyXchg :: Handle -> [Word8] -> TLSClient IO () +connectSendClientKeyXchg handle prerand = do + ver <- fmap (cpConnectVersion . scParams) get + sendPacket handle $ Handshake (ClientKeyXchg ver prerand) + +connectSendFinish :: Handle -> TLSClient IO () +connectSendFinish handle = do + cf <- getHandshakeDigest True + sendPacket handle (Handshake $ Finished $ L.unpack cf) + +{- | connect through a handle as a new TLS connection. -} +connect :: Handle -> ClientRandom -> [Word8] -> TLSClient IO () +connect handle crand premasterRandom = do + connectSendClientHello handle crand + recvServerHello handle + connectSendClientCertificate handle + + connectSendClientKeyXchg handle premasterRandom + + {- maybe send certificateVerify -} + {- FIXME not implemented yet -} + + sendPacket handle (ChangeCipherSpec) + lift $ hFlush handle + + {- send Finished -} + connectSendFinish handle + + {- receive changeCipherSpec -} + pktCCS <- recvPacket handle + case pktCCS of + Right ChangeCipherSpec -> return () + x -> error ("unexpected reply. expecting change cipher spec " ++ show x) + + {- receive Finished -} + pktFin <- recvPacket handle + case pktFin of + Right (Handshake (Finished _)) -> return () + x -> error ("unexpected reply. expecting finished " ++ show x) + + return () + +{- | sendData sends a bunch of data -} +sendData :: Handle -> L.ByteString -> TLSClient IO () +sendData handle d = do + if L.length d > 16384 + then do + let (sending, remain) = L.splitAt 16384 d + sendPacket handle $ AppData sending + sendData handle remain + else + sendPacket handle $ AppData d + +{- | recvData get data out of Data packet, and automatically try to renegociate if + - a Handshake HelloRequest is received -} +recvData :: Handle -> TLSClient IO L.ByteString +recvData handle = do + pkt <- recvPacket handle + case pkt of + Right (AppData x) -> return x + Right (Handshake HelloRequest) -> do + -- SECURITY FIXME audit the rng here.. + st <- getTLSState + let (bytes, rng') = getRandomBytes (stRandomGen st) 32 + let (premaster, rng'') = getRandomBytes rng' 46 + putTLSState $ st { stRandomGen = rng'' } + let crand = fromJust $ clientRandom bytes + connect handle crand premaster + recvData handle + Left err -> error ("error received: " ++ show err) + _ -> error "unexpected item" + +{- | close a TLS connection. + - note that it doesn't close the handle, but just signal we're going to close + - the connection to the other side -} +close :: Handle -> TLSClient IO () +close handle = do + sendPacket handle $ Alert (AlertLevel_Warning, CloseNotify) diff --git a/Network/TLS/Compression.hs b/Network/TLS/Compression.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Compression.hs @@ -0,0 +1,18 @@ +-- | +-- Module : Network.TLS.Compression +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.TLS.Compression + ( Compression(..) + ) where + +import Data.Word +import Data.ByteString (ByteString) + +data Compression = Compression + { compressionID :: Word8 + , compressionFct :: (ByteString -> ByteString) + } diff --git a/Network/TLS/Crypto.hs b/Network/TLS/Crypto.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Crypto.hs @@ -0,0 +1,101 @@ +module Network.TLS.Crypto + ( HashType(..) + , HashCtx + + -- * incremental interface with algorithm type wrapping for genericity + , initHash + , updateHash + , finalizeHash + + -- * single pass lazy bytestring interface for each algorithm + , hashMD5 + , hashSHA1 + -- * incremental interface for each algorithm + , initMD5 + , updateMD5 + , finalizeMD5 + , initSHA1 + , updateSHA1 + , finalizeSHA1 + + -- * RSA stuff + , PublicKey(..) + , PrivateKey(..) + , rsaEncrypt + , rsaDecrypt + ) where + +import qualified Data.CryptoHash.SHA1 as SHA1 +import qualified Data.CryptoHash.MD5 as MD5 +import qualified Data.ByteString as B +import Data.ByteString.Lazy (ByteString) +import Codec.Crypto.RSA (PublicKey(..), PrivateKey(..)) +import qualified Codec.Crypto.RSA as RSA +import Control.Spoon +import Random + +data HashCtx = + SHA1 !SHA1.Ctx + | MD5 !MD5.Ctx + +instance Show HashCtx where + show (SHA1 _) = "sha1" + show (MD5 _) = "md5" + +data HashType = HashTypeSHA1 | HashTypeMD5 + +{- MD5 -} + +initMD5 :: MD5.Ctx +initMD5 = MD5.init + +updateMD5 :: MD5.Ctx -> B.ByteString -> MD5.Ctx +updateMD5 = MD5.update + +finalizeMD5 :: MD5.Ctx -> B.ByteString +finalizeMD5 = MD5.finalize + +hashMD5 :: ByteString -> B.ByteString +hashMD5 = MD5.hashlazy + +{- SHA1 -} + +initSHA1 :: SHA1.Ctx +initSHA1 = SHA1.init + +updateSHA1 :: SHA1.Ctx -> B.ByteString -> SHA1.Ctx +updateSHA1 = SHA1.update + +finalizeSHA1 :: SHA1.Ctx -> B.ByteString +finalizeSHA1 = SHA1.finalize + +hashSHA1 :: ByteString -> B.ByteString +hashSHA1 = SHA1.hashlazy + +{- generic Hashing -} + +initHash :: HashType -> HashCtx +initHash HashTypeSHA1 = SHA1 (initSHA1) +initHash HashTypeMD5 = MD5 (initMD5) + +updateHash :: HashCtx -> B.ByteString -> HashCtx +updateHash (SHA1 ctx) = SHA1 . updateSHA1 ctx +updateHash (MD5 ctx) = MD5 . updateMD5 ctx + +finalizeHash :: HashCtx -> B.ByteString +finalizeHash (SHA1 ctx) = finalizeSHA1 ctx +finalizeHash (MD5 ctx) = finalizeMD5 ctx + +{- RSA reexport and maybification -} + +{- on using spoon: + because we use rsa Encrypt/Decrypt in a pure context, catching the exception + when the key is not correctly set or the data isn't correct. + need to fix the RSA package to return "Either String X". +-} + +rsaEncrypt :: RandomGen g => g -> PublicKey -> ByteString -> Maybe (ByteString, g) +rsaEncrypt g pk b = teaspoon (RSA.rsaes_pkcs1_v1_5_encrypt g pk b) + +rsaDecrypt :: PrivateKey -> ByteString -> Maybe ByteString +rsaDecrypt pk b = teaspoon (RSA.rsaes_pkcs1_v1_5_decrypt pk b) diff --git a/Network/TLS/MAC.hs b/Network/TLS/MAC.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/MAC.hs @@ -0,0 +1,63 @@ +module Network.TLS.MAC + ( hmacMD5 + , hmacSHA1 + , hmacSHA256 + , prf_MD5 + , prf_SHA1 + , prf_MD5SHA1 + ) where + +import qualified Data.CryptoHash.MD5 as MD5 +import qualified Data.CryptoHash.SHA1 as SHA1 +import qualified Data.CryptoHash.SHA256 as SHA256 +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as B +import Data.ByteString.Lazy (ByteString) +import Data.Bits (xor) + +lazyOfStrict :: B.ByteString -> ByteString +lazyOfStrict b = L.fromChunks [ b ] + +hmac :: (ByteString -> ByteString) -> Int -> ByteString -> ByteString -> ByteString +hmac f bl secret msg = + f $! L.append opad (f $! L.append ipad msg) + where + opad = L.map (xor 0x5c) k' + ipad = L.map (xor 0x36) k' + + k' = L.append kt pad + where + kt = if L.length secret > fromIntegral bl then f secret else secret + pad = L.replicate (fromIntegral bl - L.length kt) 0 + +hmacMD5 :: ByteString -> ByteString -> ByteString +hmacMD5 secret msg = hmac (lazyOfStrict . MD5.hashlazy) 64 secret msg + +hmacSHA1 :: ByteString -> ByteString -> ByteString +hmacSHA1 secret msg = hmac (lazyOfStrict . SHA1.hashlazy) 64 secret msg + +hmacSHA256 :: ByteString -> ByteString -> ByteString +hmacSHA256 secret msg = hmac (lazyOfStrict . SHA256.hashlazy) 64 secret msg + +hmacIter :: (ByteString -> ByteString -> ByteString) -> ByteString -> ByteString -> ByteString -> Int -> [ByteString] +hmacIter f secret seed aprev len = + let an = f secret aprev in + let out = f secret (L.concat [an, seed]) in + let digestsize = fromIntegral $ L.length out in + if digestsize >= len + then [ L.take (fromIntegral len) out ] + else out : hmacIter f secret seed an (len - digestsize) + +prf_SHA1 :: ByteString -> ByteString -> Int -> ByteString +prf_SHA1 secret seed len = L.concat $ hmacIter hmacSHA1 secret seed seed len + +prf_MD5 :: ByteString -> ByteString -> Int -> ByteString +prf_MD5 secret seed len = L.concat $ hmacIter hmacMD5 secret seed seed len + +prf_MD5SHA1 :: ByteString -> ByteString -> Int -> ByteString +prf_MD5SHA1 secret seed len = + L.pack $ L.zipWith xor (prf_MD5 s1 seed len) (prf_SHA1 s2 seed len) + where + slen = L.length secret + s1 = L.take (slen `div` 2 + slen `mod` 2) secret + s2 = L.drop (slen `div` 2) secret diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Packet.hs @@ -0,0 +1,408 @@ +-- | +-- Module : Network.TLS.Packet +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- the Packet module contains everything necessary to serialize and deserialize things +-- with only explicit parameters, no TLS state is involved here. +-- +module Network.TLS.Packet + ( + -- * marshall functions for header messages + decodeHeader + , encodeHeader + + -- * marshall functions for alert messages + , decodeAlert + , encodeAlert + + -- * marshall functions for handshake messages + , decodeHandshakeHeader + , decodeHandshake + , encodeHandshake + , encodeHandshakeHeader + , encodeHandshakeContent + + -- * marshall functions for change cipher spec message + , decodeChangeCipherSpec + , encodeChangeCipherSpec + + -- * generate things for packet content + , generateMasterSecret + , generateKeyBlock + , generateClientFinished + , generateServerFinished + ) where + +import Data.Word +import Network.TLS.Wire +import Data.Either (partitionEithers) +import Data.Maybe (fromJust, isNothing) +import Control.Monad +import Control.Monad.Error +import Network.TLS.Struct +import Data.Certificate.X509 +import Network.TLS.Crypto +import Network.TLS.MAC +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as L (pack, length, concat, fromChunks) +import qualified Data.ByteString as B + +{- + - decode and encode headers + -} +decodeHeader :: ByteString -> Either TLSError Header +decodeHeader = runGet $ do + ty <- getWord8 + major <- getWord8 + minor <- getWord8 + len <- getWord16 + case (valToType ty, verOfNum (major, minor)) of + (Just y, Just v) -> return $ Header y v len + (Nothing, _) -> throwError (Error_Packet "invalid type") + (_, Nothing) -> throwError (Error_Packet "invalid version") + +encodeHeader :: Header -> ByteString +encodeHeader (Header pt ver len) = + {- FIXME check len <= 2^14 -} + runPut (putWord8 (valOfType pt) >> putWord8 major >> putWord8 minor >> putWord16 len) + where (major, minor) = numericalVer ver + +{- + - decode and encode ALERT + -} + +decodeAlert :: ByteString -> Either TLSError (AlertLevel, AlertDescription) +decodeAlert = runGet $ do + al <- getWord8 + ad <- getWord8 + case (valToType al, valToType ad) of + (Just a, Just d) -> return (a, d) + (Nothing, _) -> throwError (Error_Packet "missing alert level") + (_, Nothing) -> throwError (Error_Packet "missing alert description") + +encodeAlert :: (AlertLevel, AlertDescription) -> ByteString +encodeAlert (al, ad) = runPut (putWord8 (valOfType al) >> putWord8 (valOfType ad)) + +{- decode and encode HANDSHAKE -} + +decodeHandshakeHeader :: ByteString -> Either TLSError (HandshakeType, ByteString) +decodeHandshakeHeader = runGet $ do + tyopt <- getWord8 >>= return . valToType + ty <- if isNothing tyopt + then throwError (Error_Unknown_Type "handshake type") + else return $ fromJust tyopt + len <- getWord24 + content <- getBytes len + empty <- isEmpty + unless empty (throwError (Error_Internal_Packet_Remaining 1)) + return (ty, L.fromChunks [content]) + +decodeHandshake :: Version -> HandshakeType -> ByteString -> Either TLSError Handshake +decodeHandshake ver ty = runGet $ case ty of + HandshakeType_HelloRequest -> decodeHelloRequest + HandshakeType_ClientHello -> decodeClientHello + HandshakeType_ServerHello -> decodeServerHello + HandshakeType_Certificate -> decodeCertificates + HandshakeType_ServerKeyXchg -> decodeServerKeyXchg ver + HandshakeType_CertRequest -> decodeCertRequest ver + HandshakeType_ServerHelloDone -> decodeServerHelloDone + HandshakeType_CertVerify -> decodeCertVerify + HandshakeType_ClientKeyXchg -> decodeClientKeyXchg + HandshakeType_Finished -> decodeFinished ver + +decodeHelloRequest :: Get Handshake +decodeHelloRequest = return HelloRequest + +decodeClientHello :: Get Handshake +decodeClientHello = do + ver <- getVersion + random <- getClientRandom32 + session <- getSession + ciphers <- getWords16 + compressions <- getWords8 + r <- remaining + exts <- if ver >= TLS12 && r > 0 + then fmap fromIntegral getWord16 >>= getExtensions >>= return . Just + else return Nothing + return $ ClientHello ver random session ciphers compressions exts + +decodeServerHello :: Get Handshake +decodeServerHello = do + ver <- getVersion + random <- getServerRandom32 + session <- getSession + cipherid <- getWord16 + compressionid <- getWord8 + r <- remaining + exts <- if ver >= TLS12 && r > 0 + then fmap fromIntegral getWord16 >>= getExtensions >>= return . Just + else return Nothing + return $ ServerHello ver random session cipherid compressionid exts + +decodeServerHelloDone :: Get Handshake +decodeServerHelloDone = return ServerHelloDone + +decodeCertificates :: Get Handshake +decodeCertificates = do + certslen <- getWord24 + certs <- getCerts certslen >>= return . map (decodeCertificate . L.fromChunks . (:[])) + let (l, r) = partitionEithers certs + if length l > 0 + then throwError $ Error_Certificate $ show l + else return $ Certificates r + +decodeFinished :: Version -> Get Handshake +decodeFinished ver = do + -- unfortunately passing the verify_data_size here would be tedious for >=TLS12, + -- so just return the remaining string. + len <- if ver >= TLS12 + then remaining + else return 12 + opaque <- getBytes (fromIntegral len) + return $ Finished $ B.unpack opaque + +getSignatureHashAlgorithm :: Int -> Get [ (HashAlgorithm, SignatureAlgorithm) ] +getSignatureHashAlgorithm 0 = return [] +getSignatureHashAlgorithm len = do + h <- fmap (fromJust . valToType) getWord8 + s <- fmap (fromJust . valToType) getWord8 + xs <- getSignatureHashAlgorithm (len - 2) + return ((h, s) : xs) + +decodeCertRequest :: Version -> Get Handshake +decodeCertRequest ver = do + certTypes <- fmap (map (fromJust . valToType . fromIntegral)) getWords8 + + sigHashAlgs <- if ver >= TLS12 + then do + sighashlen <- getWord16 + fmap Just $ getSignatureHashAlgorithm $ fromIntegral sighashlen + else return Nothing + dNameLen <- getWord16 + when (ver < TLS12 && dNameLen < 3) $ throwError (Error_Misc "certrequest distinguishname not of the correct size") + dName <- getBytes $ fromIntegral dNameLen + return $ CertRequest certTypes sigHashAlgs (B.unpack dName) + +decodeCertVerify :: Get Handshake +decodeCertVerify = + {- FIXME -} + return $ CertVerify [] + +decodeClientKeyXchg :: Get Handshake +decodeClientKeyXchg = do + ver <- getVersion + ran <- getRandom46 + return $ ClientKeyXchg ver ran + +-- FIXME need to work out how we marshall an opaque number +--numberise :: ByteString -> Integer +numberise _ = 0 + +decodeServerKeyXchg_DH :: Get ServerDHParams +decodeServerKeyXchg_DH = do + p <- getWord16 >>= getBytes . fromIntegral + g <- getWord16 >>= getBytes . fromIntegral + y <- getWord16 >>= getBytes . fromIntegral + return $ ServerDHParams { dh_p = numberise p, dh_g = numberise g, dh_Ys = numberise y } + +decodeServerKeyXchg_RSA :: Get ServerRSAParams +decodeServerKeyXchg_RSA = do + modulus <- getWord16 >>= getBytes . fromIntegral + expo <- getWord16 >>= getBytes . fromIntegral + return $ ServerRSAParams { rsa_modulus = numberise modulus, rsa_exponent = numberise expo } + +decodeServerKeyXchg :: Version -> Get Handshake +decodeServerKeyXchg ver = do + -- mostly unimplemented + skxAlg <- case ver of + TLS12 -> return $ SKX_RSA Nothing + TLS10 -> do + rsaparams <- decodeServerKeyXchg_RSA + return $ SKX_RSA $ Just rsaparams + _ -> do + return $ SKX_RSA Nothing + return (ServerKeyXchg skxAlg) + +encodeHandshake :: Handshake -> ByteString +encodeHandshake o = + let content = runPut $ encodeHandshakeContent o in + let len = fromIntegral $ L.length content in + let header = runPut $ encodeHandshakeHeader (typeOfHandshake o) len in + L.concat [ header, content ] + +encodeHandshakeHeader :: HandshakeType -> Int -> Put +encodeHandshakeHeader ty len = putWord8 (valOfType ty) >> putWord24 len + +encodeHandshakeContent :: Handshake -> Put + +encodeHandshakeContent (ClientHello version random session cipherIDs compressionIDs exts) = do + putVersion version + putClientRandom32 random + putSession session + putWords16 cipherIDs + putWords8 compressionIDs + putExtensions exts + return () + +encodeHandshakeContent (ServerHello version random session cipherID compressionID exts) = + putVersion version >> putServerRandom32 random >> putSession session + >> putWord16 cipherID >> putWord8 compressionID + >> putExtensions exts >> return () + +encodeHandshakeContent (Certificates certs) = + putWord24 len >> putLazyByteString certbs + where + certbs = runPut $ mapM_ putCert certs + len = fromIntegral $ L.length certbs + +encodeHandshakeContent (ClientKeyXchg version random) = do + putVersion version + putRandom46 random + +encodeHandshakeContent (ServerKeyXchg _) = do + -- FIXME + return () + +encodeHandshakeContent (HelloRequest) = return () +encodeHandshakeContent (ServerHelloDone) = return () + +encodeHandshakeContent (CertRequest certTypes sigAlgs certAuthorities) = do + putWords8 (map valOfType certTypes) + case sigAlgs of + Nothing -> return () + Just l -> putWords16 $ map (\(x,y) -> (fromIntegral $ valOfType x) * 256 + (fromIntegral $ valOfType y)) l + putByteString $ B.pack certAuthorities + +encodeHandshakeContent (CertVerify _) = undefined + +encodeHandshakeContent (Finished opaque) = mapM_ putWord8 opaque + +{- marshall helpers -} +getVersion :: Get Version +getVersion = do + major <- getWord8 + minor <- getWord8 + case verOfNum (major, minor) of + Just v -> return v + Nothing -> throwError (Error_Unknown_Version major minor) + +putVersion :: Version -> Put +putVersion ver = putWord8 major >> putWord8 minor + where (major, minor) = numericalVer ver + +{- FIXME make sure it return error if not 32 available -} +getRandom32 :: Get [Word8] +getRandom32 = fmap B.unpack $ getBytes 32 + +getServerRandom32 :: Get ServerRandom +getServerRandom32 = fmap ServerRandom getRandom32 + +getClientRandom32 :: Get ClientRandom +getClientRandom32 = fmap ClientRandom getRandom32 + +putRandom32 :: [Word8] -> Put +putRandom32 = mapM_ putWord8 + +putClientRandom32 :: ClientRandom -> Put +putClientRandom32 (ClientRandom r) = putRandom32 r + +putServerRandom32 :: ServerRandom -> Put +putServerRandom32 (ServerRandom r) = putRandom32 r + +getRandom46 :: Get [Word8] +getRandom46 = fmap B.unpack $ getBytes 46 + +putRandom46 :: [Word8] -> Put +putRandom46 = mapM_ putWord8 + +getSession :: Get Session +getSession = do + len8 <- getWord8 + case fromIntegral len8 of + 0 -> return $ Session Nothing + len -> fmap (Session . Just . B.unpack) $ getBytes len + +putSession :: Session -> Put +putSession (Session session) = + case session of + Nothing -> putWord8 0 + Just s -> putWord8 (fromIntegral $ length s) >> mapM_ putWord8 s + +getCerts :: Int -> Get [B.ByteString] +getCerts 0 = return [] +getCerts len = do + certlen <- getWord24 + cert <- getBytes certlen + certxs <- getCerts (len - certlen - 3) + return (cert : certxs) + +putCert :: Certificate -> Put +putCert cert = putWord24 (fromIntegral $ L.length content) >> putLazyByteString content + where content = encodeCertificate cert + +getExtensions :: Int -> Get [Extension] +getExtensions 0 = return [] +getExtensions len = do + extty <- getWord16 + extdatalen <- getWord16 + extdata <- getBytes $ fromIntegral extdatalen + extxs <- getExtensions (len - fromIntegral extdatalen - 4) + return $ (extty, B.unpack extdata) : extxs + +putExtension :: Extension -> Put +putExtension (ty, l) = do + putWord16 ty + putWord16 (fromIntegral $ length l) + putByteString (B.pack l) + +putExtensions :: Maybe [Extension] -> Put +putExtensions Nothing = return () +putExtensions (Just es) = + putWord16 (fromIntegral $ L.length extbs) >> putLazyByteString extbs + where + extbs = runPut $ mapM_ putExtension es + +{- + - decode and encode ALERT + -} + +decodeChangeCipherSpec :: ByteString -> Either TLSError () +decodeChangeCipherSpec b = do + x <- runGet getWord8 b + if x == 1 then Right () else Left $ Error_Misc "unknown change cipher spec content" + +encodeChangeCipherSpec :: ByteString +encodeChangeCipherSpec = runPut (putWord8 1) + +{- + - generate things for packet content + -} +generateMasterSecret :: ByteString -> ClientRandom -> ServerRandom -> ByteString +generateMasterSecret premasterSecret (ClientRandom c) (ServerRandom s) = + prf_MD5SHA1 premasterSecret seed 48 + where + label = map (toEnum . fromEnum) "master secret" + seed = L.concat $ map L.pack [ label, c, s] + +generateKeyBlock :: ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString +generateKeyBlock (ClientRandom c) (ServerRandom s) mastersecret kbsize = + prf_MD5SHA1 mastersecret seed kbsize + where + label = map (toEnum . fromEnum) "key expansion" + seed = L.concat $ map L.pack [ label, s, c ] + +generateFinished :: String -> ByteString -> HashCtx -> HashCtx -> ByteString +generateFinished label mastersecret md5ctx sha1ctx = + prf_MD5SHA1 mastersecret seed 12 + where + plabel = B.pack $ map (toEnum . fromEnum) label + seed = L.fromChunks [ plabel, finalizeHash md5ctx, finalizeHash sha1ctx ] + +generateClientFinished :: ByteString -> HashCtx -> HashCtx -> ByteString +generateClientFinished = generateFinished "client finished" + +generateServerFinished :: ByteString -> HashCtx -> HashCtx -> ByteString +generateServerFinished = generateFinished "server finished" diff --git a/Network/TLS/Receiving.hs b/Network/TLS/Receiving.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Receiving.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-} + +-- | +-- Module : Network.TLS.Receiving +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- the Receiving module contains calls related to unmarshalling packets according +-- to the TLS state +-- +module Network.TLS.Receiving ( + readPacket + ) where + +import Control.Monad.State +import Control.Monad.Error +import Data.Maybe + +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as B + +import Network.TLS.Struct +import Network.TLS.Packet +import Network.TLS.State +import Network.TLS.Cipher +import Network.TLS.Crypto +import Network.TLS.SRandom +import Data.Certificate.X509 + +newtype TLSRead a = TLSR { runTLSR :: ErrorT TLSError (State TLSState) a } + deriving (Monad, MonadError TLSError) + +instance Functor TLSRead where + fmap f = TLSR . fmap f . runTLSR + +instance MonadTLSState TLSRead where + putTLSState x = TLSR (lift $ put x) + getTLSState = TLSR (lift get) + +runTLSRead :: MonadTLSState m => TLSRead a -> m (Either TLSError a) +runTLSRead f = do + st <- getTLSState + let (a, newst) = runState (runErrorT (runTLSR f)) st + putTLSState newst + return a + +returnEither :: Either TLSError a -> TLSRead a +returnEither (Left err) = throwError err +returnEither (Right a) = return a + +readPacket :: MonadTLSState m => Header -> EncryptedData -> m (Either TLSError Packet) +readPacket hdr@(Header ProtocolType_AppData _ _) content = + runTLSRead (fmap AppData $ decryptContent hdr content) + +readPacket hdr@(Header ProtocolType_Alert _ _) content = + runTLSRead (decryptContent hdr content >>= returnEither . decodeAlert >>= return . Alert) + +readPacket hdr@(Header ProtocolType_ChangeCipherSpec _ _) content = runTLSRead $ do + dcontent <- decryptContent hdr content + returnEither $ decodeChangeCipherSpec dcontent + switchRxEncryption + isClientContext >>= \cc -> when (not cc) setKeyBlock + return ChangeCipherSpec + +readPacket hdr@(Header ProtocolType_Handshake ver _) content = + runTLSRead (decryptContent hdr content >>= processHsPacket ver) + +decryptRSA :: MonadTLSState m => ByteString -> m (Maybe ByteString) +decryptRSA econtent = do + rsapriv <- getTLSState >>= return . fromJust . hstRSAPrivateKey . fromJust . stHandshake + return $ rsaDecrypt rsapriv (L.drop 2 econtent) + +setMasterSecretRandom :: ByteString -> TLSRead () +setMasterSecretRandom content = do + st <- getTLSState + let (bytes, g') = getRandomBytes (stRandomGen st) (fromIntegral $ L.length content) + putTLSState $ st { stRandomGen = g' } + setMasterSecret (L.pack bytes) + +processClientKeyXchg :: Version -> ByteString -> TLSRead () +processClientKeyXchg ver content = do + {- the TLS protocol expect the initial client version received in the ClientHello, not the negociated version -} + expectedVer <- getTLSState >>= return . hstClientVersion . fromJust . stHandshake + if expectedVer /= ver + then setMasterSecretRandom content + else setMasterSecret content + +processClientFinished :: FinishedData -> TLSRead () +processClientFinished fdata = do + cc <- getTLSState >>= return . stClientContext + expected <- getHandshakeDigest (not cc) + when (expected /= L.pack fdata) $ do + -- FIXME don't fail, but report the error so that the code can send a BadMac Alert. + fail ("client mac failure: expecting " ++ show expected ++ " received " ++ (show $L.pack fdata)) + return () + +processHsPacket :: Version -> ByteString -> TLSRead Packet +processHsPacket ver dcontent = do + (ty, econtent) <- returnEither $ decodeHandshakeHeader dcontent + -- SECURITY FIXME if RSA fail, we need to generate a random master secret and not fail. + content <- case ty of + HandshakeType_ClientKeyXchg -> do + copt <- decryptRSA econtent + return $ maybe econtent id copt + _ -> + return econtent + hs <- case (ty, decodeHandshake ver ty content) of + (_, Right x) -> return x + (HandshakeType_ClientKeyXchg, Left _) -> return $ ClientKeyXchg SSL2 [] + (_, Left err) -> throwError err + clientmode <- isClientContext + case hs of + ClientHello cver ran _ _ _ _ -> unless clientmode $ do + startHandshakeClient cver ran + ServerHello sver ran _ _ _ _ -> when clientmode $ do + setServerRandom ran + setVersion sver + Certificates [cert] -> when clientmode $ do processCertificate cert + ClientKeyXchg cver _ -> unless clientmode $ do + processClientKeyXchg cver content + Finished fdata -> processClientFinished fdata + _ -> return () + when (finishHandshakeTypeMaterial ty) (updateHandshakeDigest dcontent) + return $ Handshake hs + +decryptContentReally :: Header -> EncryptedData -> TLSRead ByteString +decryptContentReally hdr e = do + st <- getTLSState + unencrypted_content <- decryptData e + let digestSize = cipherDigestSize $ fromJust $ stCipher st + let (unencrypted_msg, digest) = L.splitAt (L.length unencrypted_content - fromIntegral digestSize) unencrypted_content + let (Header pt ver _) = hdr + let new_hdr = Header pt ver (fromIntegral $ L.length unencrypted_msg) + expected_digest <- makeDigest False new_hdr unencrypted_msg + + if expected_digest == digest + then return $ unencrypted_msg + else throwError $ Error_Digest (L.unpack expected_digest, L.unpack digest) + +decryptContent :: Header -> EncryptedData -> TLSRead ByteString +decryptContent hdr e@(EncryptedData b) = do + st <- getTLSState + if stRxEncrypted st + then decryptContentReally hdr e + else return b + +takelast :: Int -> [a] -> [a] +takelast i b = drop (length b - i) b + +decryptData :: EncryptedData -> TLSRead ByteString +decryptData (EncryptedData econtent) = do + st <- getTLSState + + assert "decrypt data" + [ ("cipher", isNothing $ stCipher st) + , ("crypt state", isNothing $ stRxCryptState st) ] + + let cipher = fromJust $ stCipher st + let cst = fromJust $ stRxCryptState st + let padding_size = fromIntegral $ cipherPaddingSize cipher + + let writekey = B.pack $ cstKey cst + let iv = B.pack $ cstIV cst + + contentpadded <- case cipherF cipher of + CipherNoneF -> fail "none decrypt" + CipherBlockF _ decryptF -> do + {- update IV -} + let newiv = takelast padding_size $ L.unpack econtent + putTLSState $ st { stRxCryptState = Just $ cst { cstIV = newiv } } + return $ decryptF writekey iv econtent + CipherStreamF initF _ decryptF -> do + let (content, newiv) = decryptF (if iv /= B.empty then iv else initF writekey) econtent + {- update Ctx -} + putTLSState $ st { stRxCryptState = Just $ cst { cstIV = B.unpack newiv } } + return $ content + let content = + if cipherPaddingSize cipher > 0 + then + let pb = L.last contentpadded + 1 in + fst $ L.splitAt ((L.length contentpadded) - fromIntegral pb) contentpadded + else contentpadded + return content + +processCertificate :: Certificate -> TLSRead () +processCertificate cert = do + case certPubKey cert of + PubKey _ (PubKeyRSA (lm, m, e)) -> do + let pk = PublicKey { public_size = fromIntegral lm, public_n = m, public_e = e } + setPublicKey pk + _ -> return () diff --git a/Network/TLS/SRandom.hs b/Network/TLS/SRandom.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/SRandom.hs @@ -0,0 +1,30 @@ +-- this is probably not a very good random interface, nor it has any good randomness capability. +-- the module is just here until a really good CPRNG implementation come up.. +module Network.TLS.SRandom + ( SRandomGen + , makeSRandomGen + , getRandomByte + , getRandomBytes + ) where + +import Random +import Control.Arrow (first) +import Data.Word + +type SRandomGen = StdGen + +makeSRandomGen :: Int -> SRandomGen +makeSRandomGen i = mkStdGen i + +getRandomByte :: SRandomGen -> (Word8, SRandomGen) +getRandomByte rng = first fromIntegral $ next rng + +getRandomBytes :: SRandomGen -> Int -> ([Word8], SRandomGen) +getRandomBytes rng n = + let list = helper rng n in + (map fst list, snd $ last list) + where + helper _ 0 = [] + helper g i = + let (b, g') = getRandomByte g in + (b, g') : helper g' (i-1) diff --git a/Network/TLS/Sending.hs b/Network/TLS/Sending.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Sending.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Network.TLS.Sending +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- the Sending module contains calls related to marshalling packets according +-- to the TLS state +-- +module Network.TLS.Sending ( + writePacket + ) where + +import Control.Monad.State +import Data.Binary.Put (runPut, putWord16be) +import Data.Maybe + +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as B + +import Network.TLS.Struct +import Network.TLS.Packet +import Network.TLS.State +import Network.TLS.Cipher +import Network.TLS.Crypto + +{- + - 'makePacketData' create a Header and a content bytestring related to a packet + - this doesn't change any state + -} +makePacketData :: MonadTLSState m => Packet -> m (Header, ByteString) +makePacketData pkt = do + ver <- getTLSState >>= return . stVersion + content <- writePacketContent pkt + let hdr = Header (packetType pkt) ver (fromIntegral $ L.length content) + return (hdr, content) + +{- + - Handshake data need to update a digest + -} +processPacketData :: MonadTLSState m => (Header, ByteString) -> m (Header, ByteString) +processPacketData dat@(Header ty _ _, content) = do + when (ty == ProtocolType_Handshake) (updateHandshakeDigest content) + return dat + +{- + - when Tx Encrypted is set, we pass the data through encryptContent, otherwise + - we just return the packet + -} +encryptPacketData :: MonadTLSState m => (Header, ByteString) -> m (Header, ByteString) +encryptPacketData dat = do + st <- getTLSState + if stTxEncrypted st + then encryptContent dat + else return dat + +{- + - ChangeCipherSpec state change need to be handled after encryption otherwise + - its own packet would be encrypted with the new context, instead of beeing sent + - under the current context + -} +postprocessPacketData :: MonadTLSState m => (Header, ByteString) -> m (Header, ByteString) +postprocessPacketData dat@(Header ProtocolType_ChangeCipherSpec _ _, _) = + switchTxEncryption >> isClientContext >>= \cc -> when cc setKeyBlock >> return dat + +postprocessPacketData dat = return dat + +{- + - marshall packet data + -} +encodePacket :: MonadTLSState m => (Header, ByteString) -> m ByteString +encodePacket (hdr, content) = return $ L.concat [ encodeHeader hdr, content ] + + +{- + - writePacket transform a packet into marshalled data related to current state + - and updating state on the go + -} +writePacket :: MonadTLSState m => Packet -> m ByteString +writePacket pkt = makePacketData pkt >>= processPacketData >>= + encryptPacketData >>= postprocessPacketData >>= encodePacket + +{------------------------------------------------------------------------------} +{- SENDING Helpers -} +{------------------------------------------------------------------------------} + +{- if the RSA encryption fails we just return an empty bytestring, and let the protocol + - fail by itself; however it would be probably better to just report it since it's an internal problem. + -} +encryptRSA :: MonadTLSState m => ByteString -> m ByteString +encryptRSA content = do + st <- getTLSState + let g = stRandomGen st + let rsakey = fromJust $ hstRSAPublicKey $ fromJust $ stHandshake st + case rsaEncrypt g rsakey content of + Nothing -> return L.empty + Just (econtent, g') -> do + putTLSState (st { stRandomGen = g' }) + return econtent + +encryptContent :: MonadTLSState m => (Header, ByteString) -> m (Header, ByteString) +encryptContent (hdr@(Header pt ver _), content) = do + digest <- makeDigest True hdr content + encrypted_msg <- encryptData $ L.concat [content, digest] + let hdrnew = Header pt ver (fromIntegral $ L.length encrypted_msg) + return (hdrnew, encrypted_msg) + +takelast :: Int -> [a] -> [a] +takelast i b = drop (length b - i) b + +encryptData :: MonadTLSState m => ByteString -> m ByteString +encryptData content = do + st <- getTLSState + + assert "encrypt data" + [ ("cipher", isNothing $ stCipher st) + , ("crypt state", isNothing $ stTxCryptState st) ] + + let cipher = fromJust $ stCipher st + let cst = fromJust $ stTxCryptState st + let padding_size = fromIntegral $ cipherPaddingSize cipher + + let msg_len = L.length content + let padding = if padding_size > 0 + then + let padbyte = padding_size - (msg_len `mod` padding_size) in + let padbyte' = if padbyte == 0 then padding_size else padbyte in + L.replicate padbyte' (fromIntegral (padbyte' - 1)) + else + L.empty + let writekey = B.pack $ cstKey cst + let iv = B.pack $ cstIV cst + + econtent <- case cipherF cipher of + CipherNoneF -> fail "none encrypt" + CipherBlockF encrypt _ -> do + let e = encrypt writekey iv (L.concat [ content, padding ]) + let newiv = takelast (fromIntegral padding_size) $ L.unpack e + putTLSState $ st { stTxCryptState = Just $ cst { cstIV = newiv } } + return e + CipherStreamF initF encryptF _ -> do + let (e, newiv) = encryptF (if iv /= B.empty then iv else initF writekey) content + putTLSState $ st { stTxCryptState = Just $ cst { cstIV = B.unpack newiv } } + return e + return econtent + +encodePacketContent :: Packet -> ByteString +encodePacketContent (Handshake h) = encodeHandshake h +encodePacketContent (Alert a) = encodeAlert a +encodePacketContent (ChangeCipherSpec) = encodeChangeCipherSpec +encodePacketContent (AppData x) = x + +writePacketContent :: MonadTLSState m => Packet -> m ByteString +writePacketContent (Handshake ckx@(ClientKeyXchg _ _)) = do + let premastersecret = runPut $ encodeHandshakeContent ckx + setMasterSecret premastersecret + econtent <- encryptRSA premastersecret + let extralength = runPut $ putWord16be $ fromIntegral $ L.length econtent + let hdr = runPut $ encodeHandshakeHeader (typeOfHandshake ckx) (fromIntegral (L.length econtent + 2)) + return $ L.concat [hdr, extralength, econtent] + +writePacketContent pkt@(Handshake (ClientHello ver crand _ _ _ _)) = do + cc <- isClientContext + when cc (startHandshakeClient ver crand) + return $ encodePacketContent pkt + +writePacketContent pkt@(Handshake (ServerHello ver srand _ _ _ _)) = do + cc <- isClientContext + unless cc $ do + setVersion ver + setServerRandom srand + return $ encodePacketContent pkt + +writePacketContent pkt = return $ encodePacketContent pkt diff --git a/Network/TLS/Server.hs b/Network/TLS/Server.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Server.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +-- | +-- Module : Network.TLS.Server +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- the Server module contains the necessary calls to create a listening TLS socket +-- aka. a server socket. +-- + +module Network.TLS.Server + ( TLSServerParams(..) + , TLSStateServer + , runTLSServer + -- * low level packet sending receiving. + , recvPacket + , sendPacket + -- * API, warning probably subject to change + , listen + , sendData + , recvData + , close + ) where + +import Data.Word +import Data.Maybe +import Data.List (intersect, find) +import Control.Monad.Trans +import Control.Monad.State +import Codec.Crypto.RSA (PrivateKey(..)) +import Data.Certificate.X509 +import qualified Data.Certificate.Key as CertificateKey +import Network.TLS.Cipher +import Network.TLS.Struct +import Network.TLS.Packet +import Network.TLS.State +import Network.TLS.Sending +import Network.TLS.Receiving +import Network.TLS.SRandom +import qualified Data.ByteString.Lazy as L +import System.IO (Handle, hFlush) + +type TLSServerCert = (L.ByteString, Certificate, CertificateKey.PrivateKey) + +data TLSServerParams = TLSServerParams + { spAllowedVersions :: [Version] -- ^ allowed versions that we can use + , spSessions :: [[Word8]] -- ^ placeholder for futur known sessions + , spCiphers :: [Cipher] -- ^ all ciphers that the server side support + , spCertificate :: Maybe TLSServerCert -- ^ the certificate we serve to the client + , spWantClientCert :: Bool -- ^ configure if we do a cert request to the client + } + +data TLSStateServer = TLSStateServer + { scParams :: TLSServerParams -- ^ server params and config for this connection + , scTLSState :: TLSState -- ^ server TLS State for this connection + } + +newtype TLSServer m a = TLSServer { runTLSC :: StateT TLSStateServer m a } + deriving (Monad, MonadState TLSStateServer) + +instance Monad m => MonadTLSState (TLSServer m) where + getTLSState = TLSServer (get >>= return . scTLSState) + putTLSState s = TLSServer (get >>= put . (\st -> st { scTLSState = s })) + +instance MonadTrans TLSServer where + lift = TLSServer . lift + +instance Monad m => Functor (TLSServer m) where + fmap f = TLSServer . fmap f . runTLSC + +runTLSServerST :: TLSServer m a -> TLSStateServer -> m (a, TLSStateServer) +runTLSServerST f s = runStateT (runTLSC f) s + +runTLSServer :: TLSServer m a -> TLSServerParams -> SRandomGen -> m (a, TLSStateServer) +runTLSServer f params rng = runTLSServerST f (TLSStateServer { scParams = params, scTLSState = state }) + where state = (newTLSState rng) { stVersion = TLS10, stClientContext = False } + +{- | receive a single TLS packet or on error a TLSError -} +recvPacket :: Handle -> TLSServer IO (Either TLSError Packet) +recvPacket handle = do + hdr <- lift $ L.hGet handle 5 >>= return . decodeHeader + case hdr of + Left err -> return $ Left err + Right header@(Header _ _ readlen) -> do + content <- lift $ L.hGet handle (fromIntegral readlen) + readPacket header (EncryptedData content) + +{- | send a single TLS packet -} +sendPacket :: Handle -> Packet -> TLSServer IO () +sendPacket handle pkt = do + dataToSend <- writePacket pkt + lift $ L.hPut handle dataToSend + +handleClientHello :: Handshake -> TLSServer IO () +handleClientHello (ClientHello ver _ _ ciphers compressionID _) = do + cfg <- get >>= return . scParams + when (not $ elem ver (spAllowedVersions cfg)) $ do + {- unsupported version -} + fail "unsupported version" + + let commonCiphers = intersect ciphers (map cipherID $ spCiphers cfg) + when (commonCiphers == []) $ do + {- unsupported cipher -} + fail ("unsupported cipher: " ++ show ciphers ++ " : server : " ++ (show $ map cipherID $ spCiphers cfg)) + + when (not $ elem 0 compressionID) $ do + {- unsupported compression -} + fail "unsupported compression" + + modifyTLSState (\st -> st + { stVersion = ver + , stCipher = find (\c -> cipherID c == (head commonCiphers)) (spCiphers cfg) + }) + +handleClientHello _ = do + fail "unexpected handshake type received. expecting client hello" + +expectingPacket :: (Either TLSError Packet) -> ProtocolType -> TLSServer IO () +expectingPacket pkt expectedType = do + apkt <- case pkt of + Right x -> return x + Left tlserror -> fail ("expecting packet but got error " ++ show tlserror) + when (packetType apkt /= expectedType) $ do + fail ("unexpected packet received, expecting " ++ show expectedType) + return () + +expectingHandshake :: (Either TLSError Packet) -> HandshakeType -> TLSServer IO () +expectingHandshake pkt expectedType = do + hs <- case pkt of + Right (Handshake hs) -> return hs + Right _ -> fail ("unexpected packet received, expecting handshake " ++ show expectedType) + Left tlserror -> fail ("expecting handshake but got error " ++ show tlserror) + when (typeOfHandshake hs /= expectedType) $ do + fail ("unexpected handshake received, expecting " ++ show expectedType) + return () + +handshakeSendServerData :: Handle -> ServerRandom -> TLSServer IO () +handshakeSendServerData handle srand = do + sp <- get >>= return . scParams + st <- getTLSState + + let cipher = fromJust $ stCipher st + + let srvhello = ServerHello (stVersion st) srand (Session Nothing) (cipherID cipher) 0 Nothing + let (_,cert,privkeycert) = fromJust $ spCertificate sp + let srvcert = Certificates [ cert ] + + + -- in TLS12, we need to check as well the certificates we are sending if they have in the extension + -- the necessary bits set. + let needkeyxchg = cipherExchangeNeedMoreData $ cipherKeyExchange cipher + + let privkey = PrivateKey + { private_size = fromIntegral $ CertificateKey.privKey_lenmodulus privkeycert + , private_n = CertificateKey.privKey_modulus privkeycert + , private_d = CertificateKey.privKey_private_exponant privkeycert + } + setPrivateKey privkey + + sendPacket handle (Handshake srvhello) + sendPacket handle (Handshake srvcert) + when needkeyxchg $ do + let skg = SKX_RSA Nothing + sendPacket handle (Handshake $ ServerKeyXchg skg) + -- FIXME we don't do this on a Anonyous server + when (spWantClientCert sp) $ do + let certTypes = [ CertificateType_RSA_Sign ] + let creq = CertRequest certTypes Nothing [0,0,0] + sendPacket handle (Handshake creq) + sendPacket handle (Handshake ServerHelloDone) + +handshakeSendFinish :: Handle -> TLSServer IO () +handshakeSendFinish handle = do + cf <- getHandshakeDigest False + sendPacket handle (Handshake $ Finished $ L.unpack cf) + +{- after receiving a client hello, we need to redo a handshake -} +handshake :: Handle -> ServerRandom -> TLSServer IO () +handshake handle srand = do + handshakeSendServerData handle srand + lift $ hFlush handle + + recvPacket handle >>= \pkt -> expectingHandshake pkt HandshakeType_ClientKeyXchg + recvPacket handle >>= \pkt -> expectingPacket pkt ProtocolType_ChangeCipherSpec + recvPacket handle >>= \pkt -> expectingHandshake pkt HandshakeType_Finished + + sendPacket handle ChangeCipherSpec + handshakeSendFinish handle + + lift $ hFlush handle + + return () + +{- | listen on a handle to a new TLS connection. -} +listen :: Handle -> ServerRandom -> TLSServer IO () +listen handle srand = do + pkt <- recvPacket handle + case pkt of + Right (Handshake hs) -> handleClientHello hs + x -> fail ("unexpected type received. expecting handshake ++ " ++ show x) + handshake handle srand + + return () + +{- | sendData sends a bunch of data -} +sendData :: Handle -> L.ByteString -> TLSServer IO () +sendData handle d = + if L.length d > 16384 + then do + let (sending, remain) = L.splitAt 16384 d + sendPacket handle $ AppData sending + sendData handle remain + else + sendPacket handle $ AppData d + +{- | recvData get data out of Data packet, and automatically renegociate if + - a Handshake ClientHello is received -} +recvData :: Handle -> TLSServer IO L.ByteString +recvData handle = do + pkt <- recvPacket handle + case pkt of + Right (Handshake (ClientHello _ _ _ _ _ _)) -> do + -- SECURITY FIXME audit the rng here.. + st <- getTLSState + let (bytes, rng') = getRandomBytes (stRandomGen st) 32 + putTLSState $ st { stRandomGen = rng' } + let srand = fromJust $ serverRandom bytes + handshake handle srand + recvData handle + Right (AppData x) -> return x + Left err -> error ("error received: " ++ show err) + _ -> error "unexpected item" + +{- | close a TLS connection. + - note that it doesn't close the handle, but just signal we're going to close + - the connection to the other side -} +close :: Handle -> TLSServer IO () +close handle = do + sendPacket handle $ Alert (AlertLevel_Warning, CloseNotify) diff --git a/Network/TLS/State.hs b/Network/TLS/State.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/State.hs @@ -0,0 +1,271 @@ +-- | +-- Module : Network.TLS.State +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- the State module contains calls related to state initialization/manipulation +-- which is use by the Receiving module and the Sending module. +-- +module Network.TLS.State + ( TLSState(..) + , TLSHandshakeState(..) + , TLSCryptState(..) + , TLSMacState(..) + , MonadTLSState, getTLSState, putTLSState, modifyTLSState + , newTLSState + , assert -- FIXME move somewhere else (Internal.hs ?) + , finishHandshakeTypeMaterial + , finishHandshakeMaterial + , makeDigest + , setMasterSecret + , setPublicKey + , setPrivateKey + , setKeyBlock + , setVersion + , setCipher + , setServerRandom + , switchTxEncryption + , switchRxEncryption + , isClientContext + , startHandshakeClient + , updateHandshakeDigest + , getHandshakeDigest + , endHandshake + ) where + +import Data.Word +import Data.Maybe (fromJust, isNothing) +import Network.TLS.Struct +import Network.TLS.SRandom +import Network.TLS.Wire +import Network.TLS.Packet +import Network.TLS.Crypto +import Network.TLS.Cipher +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as L +import Control.Monad + +assert :: Monad m => String -> [(String,Bool)] -> m () +assert fctname list = forM_ list $ \ (name, assumption) -> do + when assumption $ fail (fctname ++ ": assumption about " ++ name ++ " failed") + +data TLSCryptState = TLSCryptState + { cstKey :: ![Word8] + , cstIV :: ![Word8] + , cstMacSecret :: L.ByteString + } deriving (Show) + +data TLSMacState = TLSMacState + { msSequence :: Word64 + } deriving (Show) + +data TLSHandshakeState = TLSHandshakeState + { hstClientVersion :: !(Version) + , hstClientRandom :: !ClientRandom + , hstServerRandom :: !(Maybe ServerRandom) + , hstMasterSecret :: !(Maybe [Word8]) + , hstRSAPublicKey :: !(Maybe PublicKey) + , hstRSAPrivateKey :: !(Maybe PrivateKey) + , hstHandshakeDigest :: Maybe (HashCtx, HashCtx) -- FIXME could be only 1 hash in tls12 + } deriving (Show) + +data TLSState = TLSState + { stClientContext :: Bool + , stClientVersion :: !(Maybe Version) + , stVersion :: !Version + , stHandshake :: !(Maybe TLSHandshakeState) + , stTxEncrypted :: Bool + , stRxEncrypted :: Bool + , stTxCryptState :: !(Maybe TLSCryptState) + , stRxCryptState :: !(Maybe TLSCryptState) + , stTxMacState :: !(Maybe TLSMacState) + , stRxMacState :: !(Maybe TLSMacState) + , stCipher :: Maybe Cipher + , stRandomGen :: SRandomGen + } deriving (Show) + +class (Monad m) => MonadTLSState m where + getTLSState :: m TLSState + putTLSState :: TLSState -> m () + +newTLSState :: SRandomGen -> TLSState +newTLSState rng = TLSState + { stClientContext = False + , stClientVersion = Nothing + , stVersion = TLS10 + , stHandshake = Nothing + , stTxEncrypted = False + , stRxEncrypted = False + , stTxCryptState = Nothing + , stRxCryptState = Nothing + , stTxMacState = Nothing + , stRxMacState = Nothing + , stCipher = Nothing + , stRandomGen = rng + } + +modifyTLSState :: (MonadTLSState m) => (TLSState -> TLSState) -> m () +modifyTLSState f = getTLSState >>= \st -> putTLSState (f st) + +makeDigest :: (MonadTLSState m) => Bool -> Header -> ByteString -> m ByteString +makeDigest w hdr content = do + st <- getTLSState + assert "make digest" + [ ("cipher", isNothing $ stCipher st) + , ("crypt state", isNothing $ if w then stTxCryptState st else stRxCryptState st) + , ("mac state", isNothing $ if w then stTxMacState st else stRxMacState st) ] + let cst = fromJust $ if w then stTxCryptState st else stRxCryptState st + let ms = fromJust $ if w then stTxMacState st else stRxMacState st + let cipher = fromJust $ stCipher st + + let hmac_msg = L.concat [ encodeWord64 $ msSequence ms, encodeHeader hdr, content ] + let digest = (cipherHMAC cipher) (cstMacSecret cst) hmac_msg + + let newms = ms { msSequence = (msSequence ms) + 1 } + + modifyTLSState (\_ -> if w then st { stTxMacState = Just newms } else st { stRxMacState = Just newms }) + return digest + +finishHandshakeTypeMaterial :: HandshakeType -> Bool +finishHandshakeTypeMaterial HandshakeType_ClientHello = True +finishHandshakeTypeMaterial HandshakeType_ServerHello = True +finishHandshakeTypeMaterial HandshakeType_Certificate = True +finishHandshakeTypeMaterial HandshakeType_HelloRequest = False +finishHandshakeTypeMaterial HandshakeType_ServerHelloDone = True +finishHandshakeTypeMaterial HandshakeType_ClientKeyXchg = True +finishHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True +finishHandshakeTypeMaterial HandshakeType_CertRequest = True +finishHandshakeTypeMaterial HandshakeType_CertVerify = False +finishHandshakeTypeMaterial HandshakeType_Finished = True + +finishHandshakeMaterial :: Handshake -> Bool +finishHandshakeMaterial = finishHandshakeTypeMaterial . typeOfHandshake + +switchTxEncryption :: MonadTLSState m => m () +switchTxEncryption = getTLSState >>= putTLSState . (\st -> st { stTxEncrypted = True }) + +switchRxEncryption :: MonadTLSState m => m () +switchRxEncryption = getTLSState >>= putTLSState . (\st -> st { stRxEncrypted = True }) + +setServerRandom :: MonadTLSState m => ServerRandom -> m () +setServerRandom ran = updateHandshake "srand" (\hst -> hst { hstServerRandom = Just ran }) + +setMasterSecret :: MonadTLSState m => ByteString -> m () +setMasterSecret premastersecret = do + st <- getTLSState + hasValidHandshake "master secret" + assert "set master secret" + [ ("server random", (isNothing $ hstServerRandom $ fromJust $ stHandshake st)) ] + + updateHandshake "master secret" (\hst -> + let ms = generateMasterSecret premastersecret (hstClientRandom hst) (fromJust $ hstServerRandom hst) in + hst { hstMasterSecret = Just $ L.unpack ms } ) + return () + +setPublicKey :: MonadTLSState m => PublicKey -> m () +setPublicKey pk = updateHandshake "publickey" (\hst -> hst { hstRSAPublicKey = Just pk }) + +setPrivateKey :: MonadTLSState m => PrivateKey -> m () +setPrivateKey pk = updateHandshake "privatekey" (\hst -> hst { hstRSAPrivateKey = Just pk }) + +setKeyBlock :: MonadTLSState m => m () +setKeyBlock = do + st <- getTLSState + + let hst = fromJust $ stHandshake st + assert "set key block" + [ ("cipher", (isNothing $ stCipher st)) + , ("server random", (isNothing $ hstServerRandom hst)) + , ("master secret", (isNothing $ hstMasterSecret hst)) + ] + + let cc = stClientContext st + let cipher = fromJust $ stCipher st + let keyblockSize = fromIntegral $ cipherKeyBlockSize cipher + let digestSize = cipherDigestSize cipher + let keySize = cipherKeySize cipher + let ivSize = cipherIVSize cipher + let kb = generateKeyBlock (hstClientRandom hst) + (fromJust $ hstServerRandom hst) + (L.pack $ fromJust $ hstMasterSecret hst) keyblockSize + let (cMACSecret, r1) = L.splitAt (fromIntegral digestSize) kb + let (sMACSecret, r2) = L.splitAt (fromIntegral digestSize) r1 + let (cWriteKey, r3) = L.splitAt (fromIntegral keySize) r2 + let (sWriteKey, r4) = L.splitAt (fromIntegral keySize) r3 + let (cWriteIV, r5) = L.splitAt (fromIntegral ivSize) r4 + let (sWriteIV, _) = L.splitAt (fromIntegral ivSize) r5 + + let cstClient = TLSCryptState + { cstKey = L.unpack cWriteKey + , cstIV = L.unpack cWriteIV + , cstMacSecret = cMACSecret } + let cstServer = TLSCryptState + { cstKey = L.unpack sWriteKey + , cstIV = L.unpack sWriteIV + , cstMacSecret = sMACSecret } + let msClient = TLSMacState { msSequence = 0 } + let msServer = TLSMacState { msSequence = 0 } + putTLSState $ st + { stTxCryptState = Just $ if cc then cstClient else cstServer + , stRxCryptState = Just $ if cc then cstServer else cstClient + , stTxMacState = Just $ if cc then msClient else msServer + , stRxMacState = Just $ if cc then msServer else msClient + } + +setCipher :: MonadTLSState m => Cipher -> m () +setCipher cipher = getTLSState >>= putTLSState . (\st -> st { stCipher = Just cipher }) + +setVersion :: MonadTLSState m => Version -> m () +setVersion ver = getTLSState >>= putTLSState . (\st -> st { stVersion = ver }) + +isClientContext :: MonadTLSState m => m Bool +isClientContext = getTLSState >>= return . stClientContext + +-- create a new empty handshake state +newEmptyHandshake :: Version -> ClientRandom -> TLSHandshakeState +newEmptyHandshake ver crand = TLSHandshakeState + { hstClientVersion = ver + , hstClientRandom = crand + , hstServerRandom = Nothing + , hstMasterSecret = Nothing + , hstRSAPublicKey = Nothing + , hstRSAPrivateKey = Nothing + , hstHandshakeDigest = Nothing + } + +startHandshakeClient :: MonadTLSState m => Version -> ClientRandom -> m () +startHandshakeClient ver crand = do + -- FIXME check if handshake is already not null + chs <- getTLSState >>= return . stHandshake + when (isNothing chs) $ + modifyTLSState (\st -> st { stHandshake = Just $ newEmptyHandshake ver crand }) + +hasValidHandshake :: MonadTLSState m => String -> m () +hasValidHandshake name = getTLSState >>= \st -> assert name [ ("valid handshake", isNothing $ stHandshake st) ] + +updateHandshake :: MonadTLSState m => String -> (TLSHandshakeState -> TLSHandshakeState) -> m () +updateHandshake n f = do + hasValidHandshake n + modifyTLSState (\st -> st { stHandshake = maybe Nothing (Just . f) (stHandshake st) }) + +updateHandshakeDigest :: MonadTLSState m => ByteString -> m () +updateHandshakeDigest content = updateHandshake "update digest" (\hs -> + let ctxs = case hstHandshakeDigest hs of + Nothing -> (initHash HashTypeSHA1, initHash HashTypeMD5) + Just (sha1ctx, md5ctx) -> (sha1ctx, md5ctx) in + let (nc1, nc2) = foldl (\(c1, c2) s -> (updateHash c1 s, updateHash c2 s)) ctxs $ L.toChunks content in + hs { hstHandshakeDigest = Just (nc1, nc2) } + ) + +getHandshakeDigest :: MonadTLSState m => Bool -> m ByteString +getHandshakeDigest client = do + st <- getTLSState + let hst = fromJust $ stHandshake st + let (sha1ctx, md5ctx) = fromJust $ hstHandshakeDigest hst + let msecret = fromJust $ hstMasterSecret hst + return $ (if client then generateClientFinished else generateServerFinished) (L.pack msecret) md5ctx sha1ctx + +endHandshake :: MonadTLSState m => m () +endHandshake = modifyTLSState (\st -> st { stHandshake = Nothing }) diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Struct.hs @@ -0,0 +1,404 @@ +-- | +-- Module : Network.TLS.Struct +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- the Struct module contains all definitions and values of the TLS protocol +-- +module Network.TLS.Struct + ( Version(..) + , ConnectionEnd(..) + , CipherType(..) + , Extension + , EncryptedData(..) + , CertificateType(..) + , HashAlgorithm(..) + , SignatureAlgorithm(..) + , ProtocolType(..) + , TLSError(..) + , ServerDHParams(..) + , ServerRSAParams(..) + , ServerKeyXchgAlgorithmData(..) + , Packet(..) + , Header(..) + , ServerRandom(..) + , ClientRandom(..) + , serverRandom + , clientRandom + , FinishedData + , Session(..) + , AlertLevel(..) + , AlertDescription(..) + , HandshakeType(..) + , Handshake(..) + , numericalVer + , verOfNum + , TypeValuable, valOfType, valToType + , packetType + , typeOfHandshake + ) where + +import Data.ByteString.Lazy (ByteString) +import Data.Word +import Data.Certificate.X509 + +data Version = SSL2 | SSL3 | TLS10 | TLS11 | TLS12 deriving (Show, Eq, Ord) + +data ConnectionEnd = ConnectionServer | ConnectionClient +data CipherType = CipherStream | CipherBlock | CipherAEAD +data CertificateType = + CertificateType_RSA_Sign -- TLS10 + | CertificateType_DSS_Sign -- TLS10 + | CertificateType_RSA_Fixed_DH -- TLS10 + | CertificateType_DSS_Fixed_DH -- TLS10 + | CertificateType_RSA_Ephemeral_dh -- TLS12 + | CertificateType_DSS_Ephemeral_dh -- TLS12 + | CertificateType_fortezza_dms -- TLS12 + | CertificateType_Unknown Word8 + deriving (Show,Eq) + +data HashAlgorithm = + HashNone + | HashMD5 + | HashSHA1 + | HashSHA224 + | HashSHA256 + | HashSHA384 + | HashSHA512 + | HashOther Word8 + deriving (Show,Eq) + +data SignatureAlgorithm = + SignatureAnonymous + | SignatureRSA + | SignatureDSS + | SignatureECDSA + | SignatureOther Word8 + deriving (Show,Eq) + +data ProtocolType = + ProtocolType_ChangeCipherSpec + | ProtocolType_Alert + | ProtocolType_Handshake + | ProtocolType_AppData + deriving (Eq, Show) + +data TLSError = + Error_Misc String + | Error_Certificate String + | Error_Digest ([Word8], [Word8]) + | Error_Packet String + | Error_Packet_Size_Mismatch (Int, Int) + | Error_Internal_Packet_Remaining Int + | Error_Internal_Packet_ByteProcessed Int Int Int + | Error_Unknown_Version Word8 Word8 + | Error_Unknown_Type String + deriving (Eq, Show) + +data Packet = + Handshake Handshake + | Alert (AlertLevel, AlertDescription) + | ChangeCipherSpec + | AppData ByteString + deriving (Show,Eq) + +data Header = Header ProtocolType Version Word16 deriving (Show, Eq) + +newtype ServerRandom = ServerRandom [Word8] deriving (Show, Eq) +newtype ClientRandom = ClientRandom [Word8] deriving (Show, Eq) +newtype Session = Session (Maybe [Word8]) deriving (Show, Eq) +type CipherID = Word16 +type CompressionID = Word8 +type FinishedData = [Word8] +type Extension = (Word16, [Word8]) + +constrRandom32 :: ([Word8] -> a) -> [Word8] -> Maybe a +constrRandom32 constr l = if length l == 32 then Just (constr l) else Nothing + +serverRandom :: [Word8] -> Maybe ServerRandom +serverRandom l = constrRandom32 ServerRandom l + +clientRandom :: [Word8] -> Maybe ClientRandom +clientRandom l = constrRandom32 ClientRandom l + +newtype EncryptedData = EncryptedData ByteString + deriving (Show) + +data AlertLevel = + AlertLevel_Warning + | AlertLevel_Fatal + deriving (Show,Eq) + +data AlertDescription = + CloseNotify + | UnexpectedMessage + | BadRecordMac + | DecryptionFailed + | RecordOverflow + | DecompressionFailure + | HandshakeFailure + | BadCertificate + | UnsupportedCertificate + | CertificateRevoked + | CertificateExpired + | CertificateUnknown + | IllegalParameter + | UnknownCa + | AccessDenied + | DecodeError + | DecryptError + | ExportRestriction + | ProtocolVersion + | InsufficientSecurity + | InternalError + | UserCanceled + | NoRenegotiation + deriving (Show,Eq) + +data HandshakeType = + HandshakeType_HelloRequest + | HandshakeType_ClientHello + | HandshakeType_ServerHello + | HandshakeType_Certificate + | HandshakeType_ServerKeyXchg + | HandshakeType_CertRequest + | HandshakeType_ServerHelloDone + | HandshakeType_CertVerify + | HandshakeType_ClientKeyXchg + | HandshakeType_Finished + deriving (Show,Eq) + +data ServerDHParams = ServerDHParams + { dh_p :: Integer -- ^ prime modulus + , dh_g :: Integer -- ^ generator + , dh_Ys :: Integer -- ^ public value (g^X mod p) + } deriving (Show,Eq) + +data ServerRSAParams = ServerRSAParams + { rsa_modulus :: Integer + , rsa_exponent :: Integer + } deriving (Show,Eq) + +data ServerKeyXchgAlgorithmData = + SKX_DH_Anon ServerDHParams + | SKX_DHE_DSS ServerDHParams [Word8] + | SKX_DHE_RSA ServerDHParams [Word8] + | SKX_RSA (Maybe ServerRSAParams) + | SKX_DH_DSS (Maybe ServerRSAParams) + | SKX_DH_RSA (Maybe ServerRSAParams) + deriving (Show,Eq) + +data Handshake = + ClientHello !Version !ClientRandom !Session ![CipherID] ![CompressionID] (Maybe [Extension]) + | ServerHello !Version !ServerRandom !Session !CipherID !CompressionID (Maybe [Extension]) + | Certificates [Certificate] + | HelloRequest + | ServerHelloDone + | ClientKeyXchg Version [Word8] + | ServerKeyXchg ServerKeyXchgAlgorithmData + | CertRequest [CertificateType] (Maybe [ (HashAlgorithm, SignatureAlgorithm) ]) [Word8] + | CertVerify [Word8] + | Finished FinishedData + deriving (Show,Eq) + +packetType :: Packet -> ProtocolType +packetType (Handshake _) = ProtocolType_Handshake +packetType (Alert _) = ProtocolType_Alert +packetType ChangeCipherSpec = ProtocolType_ChangeCipherSpec +packetType (AppData _) = ProtocolType_AppData + +typeOfHandshake :: Handshake -> HandshakeType +typeOfHandshake (ClientHello _ _ _ _ _ _) = HandshakeType_ClientHello +typeOfHandshake (ServerHello _ _ _ _ _ _) = HandshakeType_ServerHello +typeOfHandshake (Certificates _) = HandshakeType_Certificate +typeOfHandshake (HelloRequest) = HandshakeType_HelloRequest +typeOfHandshake (ServerHelloDone) = HandshakeType_ServerHelloDone +typeOfHandshake (ClientKeyXchg _ _) = HandshakeType_ClientKeyXchg +typeOfHandshake (ServerKeyXchg _) = HandshakeType_ServerKeyXchg +typeOfHandshake (CertRequest _ _ _) = HandshakeType_CertRequest +typeOfHandshake (CertVerify _) = HandshakeType_CertVerify +typeOfHandshake (Finished _) = HandshakeType_Finished + +numericalVer :: Version -> (Word8, Word8) +numericalVer SSL2 = (2, 0) +numericalVer SSL3 = (3, 0) +numericalVer TLS10 = (3, 1) +numericalVer TLS11 = (3, 2) +numericalVer TLS12 = (3, 3) + +verOfNum :: (Word8, Word8) -> Maybe Version +verOfNum (2, 0) = Just SSL2 +verOfNum (3, 0) = Just SSL3 +verOfNum (3, 1) = Just TLS10 +verOfNum (3, 2) = Just TLS11 +verOfNum (3, 3) = Just TLS12 +verOfNum _ = Nothing + +class TypeValuable a where + valOfType :: a -> Word8 + valToType :: Word8 -> Maybe a + +instance TypeValuable ConnectionEnd where + valOfType ConnectionServer = 0 + valOfType ConnectionClient = 1 + + valToType 0 = Just ConnectionServer + valToType 1 = Just ConnectionClient + valToType _ = Nothing + +instance TypeValuable CipherType where + valOfType CipherStream = 0 + valOfType CipherBlock = 1 + valOfType CipherAEAD = 2 + + valToType 0 = Just CipherStream + valToType 1 = Just CipherBlock + valToType 2 = Just CipherAEAD + valToType _ = Nothing + +instance TypeValuable ProtocolType where + valOfType ProtocolType_ChangeCipherSpec = 20 + valOfType ProtocolType_Alert = 21 + valOfType ProtocolType_Handshake = 22 + valOfType ProtocolType_AppData = 23 + + valToType 20 = Just ProtocolType_ChangeCipherSpec + valToType 21 = Just ProtocolType_Alert + valToType 22 = Just ProtocolType_Handshake + valToType 23 = Just ProtocolType_AppData + valToType _ = Nothing + +instance TypeValuable HandshakeType where + valOfType HandshakeType_HelloRequest = 0 + valOfType HandshakeType_ClientHello = 1 + valOfType HandshakeType_ServerHello = 2 + valOfType HandshakeType_Certificate = 11 + valOfType HandshakeType_ServerKeyXchg = 12 + valOfType HandshakeType_CertRequest = 13 + valOfType HandshakeType_ServerHelloDone = 14 + valOfType HandshakeType_CertVerify = 15 + valOfType HandshakeType_ClientKeyXchg = 16 + valOfType HandshakeType_Finished = 20 + + valToType 0 = Just HandshakeType_HelloRequest + valToType 1 = Just HandshakeType_ClientHello + valToType 2 = Just HandshakeType_ServerHello + valToType 11 = Just HandshakeType_Certificate + valToType 12 = Just HandshakeType_ServerKeyXchg + valToType 13 = Just HandshakeType_CertRequest + valToType 14 = Just HandshakeType_ServerHelloDone + valToType 15 = Just HandshakeType_CertVerify + valToType 16 = Just HandshakeType_ClientKeyXchg + valToType 20 = Just HandshakeType_Finished + valToType _ = Nothing + +instance TypeValuable AlertLevel where + valOfType AlertLevel_Warning = 1 + valOfType AlertLevel_Fatal = 2 + + valToType 1 = Just AlertLevel_Warning + valToType 2 = Just AlertLevel_Fatal + valToType _ = Nothing + +instance TypeValuable AlertDescription where + valOfType CloseNotify = 0 + valOfType UnexpectedMessage = 10 + valOfType BadRecordMac = 20 + valOfType DecryptionFailed = 21 + valOfType RecordOverflow = 22 + valOfType DecompressionFailure = 30 + valOfType HandshakeFailure = 40 + valOfType BadCertificate = 42 + valOfType UnsupportedCertificate = 43 + valOfType CertificateRevoked = 44 + valOfType CertificateExpired = 45 + valOfType CertificateUnknown = 46 + valOfType IllegalParameter = 47 + valOfType UnknownCa = 48 + valOfType AccessDenied = 49 + valOfType DecodeError = 50 + valOfType DecryptError = 51 + valOfType ExportRestriction = 60 + valOfType ProtocolVersion = 70 + valOfType InsufficientSecurity = 71 + valOfType InternalError = 80 + valOfType UserCanceled = 90 + valOfType NoRenegotiation = 100 + + valToType 0 = Just CloseNotify + valToType 10 = Just UnexpectedMessage + valToType 20 = Just BadRecordMac + valToType 21 = Just DecryptionFailed + valToType 22 = Just RecordOverflow + valToType 30 = Just DecompressionFailure + valToType 40 = Just HandshakeFailure + valToType 42 = Just BadCertificate + valToType 43 = Just UnsupportedCertificate + valToType 44 = Just CertificateRevoked + valToType 45 = Just CertificateExpired + valToType 46 = Just CertificateUnknown + valToType 47 = Just IllegalParameter + valToType 48 = Just UnknownCa + valToType 49 = Just AccessDenied + valToType 50 = Just DecodeError + valToType 51 = Just DecryptError + valToType 60 = Just ExportRestriction + valToType 70 = Just ProtocolVersion + valToType 71 = Just InsufficientSecurity + valToType 80 = Just InternalError + valToType 90 = Just UserCanceled + valToType 100 = Just NoRenegotiation + valToType _ = Nothing + +instance TypeValuable CertificateType where + valOfType CertificateType_RSA_Sign = 1 + valOfType CertificateType_DSS_Sign = 2 + valOfType CertificateType_RSA_Fixed_DH = 3 + valOfType CertificateType_DSS_Fixed_DH = 4 + valOfType CertificateType_RSA_Ephemeral_dh = 5 + valOfType CertificateType_DSS_Ephemeral_dh = 6 + valOfType CertificateType_fortezza_dms = 20 + valOfType (CertificateType_Unknown i) = i + + valToType 1 = Just CertificateType_RSA_Sign + valToType 2 = Just CertificateType_DSS_Sign + valToType 3 = Just CertificateType_RSA_Fixed_DH + valToType 4 = Just CertificateType_DSS_Fixed_DH + valToType 5 = Just CertificateType_RSA_Ephemeral_dh + valToType 6 = Just CertificateType_DSS_Ephemeral_dh + valToType 20 = Just CertificateType_fortezza_dms + valToType i = Just (CertificateType_Unknown i) + +instance TypeValuable HashAlgorithm where + valOfType HashNone = 0 + valOfType HashMD5 = 1 + valOfType HashSHA1 = 2 + valOfType HashSHA224 = 3 + valOfType HashSHA256 = 4 + valOfType HashSHA384 = 5 + valOfType HashSHA512 = 6 + valOfType (HashOther i) = i + + valToType 0 = Just HashNone + valToType 1 = Just HashMD5 + valToType 2 = Just HashSHA1 + valToType 3 = Just HashSHA224 + valToType 4 = Just HashSHA256 + valToType 5 = Just HashSHA384 + valToType 6 = Just HashSHA512 + valToType i = Just (HashOther i) + +instance TypeValuable SignatureAlgorithm where + valOfType SignatureAnonymous = 0 + valOfType SignatureRSA = 1 + valOfType SignatureDSS = 2 + valOfType SignatureECDSA = 3 + valOfType (SignatureOther i) = i + + valToType 0 = Just SignatureAnonymous + valToType 1 = Just SignatureRSA + valToType 2 = Just SignatureDSS + valToType 3 = Just SignatureECDSA + valToType i = Just (SignatureOther i) diff --git a/Network/TLS/Wire.hs b/Network/TLS/Wire.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Wire.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving,FlexibleInstances #-} + +-- | +-- Module : Network.TLS.Wire +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- the Wire module is a specialized Binary package related to the TLS protocol. +-- all multibytes values are written as big endian. +-- +module Network.TLS.Wire + ( Get + , runGet + , remaining + , bytesRead + , getWord8 + , getWords8 + , getWord16 + , getWords16 + , getWord24 + , getBytes + , processBytes + , isEmpty + , Put + , runPut + , putWord8 + , putWords8 + , putWord16 + , putWords16 + , putWord24 + , putByteString + , putLazyByteString + , encodeWord64 + ) where + +import qualified Data.Binary.Get as Bin +import Data.Binary.Put +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as L +import Control.Monad.Error +import Data.Word +import Data.Bits +import Network.TLS.Struct + +instance Error TLSError where + noMsg = Error_Misc "" + strMsg = Error_Misc + +newtype Get a = GE { runGE :: ErrorT TLSError Bin.Get a } + deriving (Monad, MonadError TLSError) + +instance Functor Get where + fmap f = GE . fmap f . runGE + +liftGet :: Bin.Get a -> Get a +liftGet = GE . lift + +runGet :: Get a -> L.ByteString -> Either TLSError a +runGet f b = Bin.runGet (runErrorT (runGE f)) b + +remaining :: Get Int +remaining = fmap fromIntegral $ liftGet Bin.remaining + +bytesRead :: Get Int +bytesRead = fmap fromIntegral $ liftGet Bin.bytesRead + +getWord8 :: Get Word8 +getWord8 = liftGet Bin.getWord8 + +getWords8 :: Get [Word8] +getWords8 = getWord8 >>= \lenb -> replicateM (fromIntegral lenb) getWord8 + +getWord16 :: Get Word16 +getWord16 = liftGet Bin.getWord16be + +getWords16 :: Get [Word16] +getWords16 = getWord16 >>= \lenb -> replicateM (fromIntegral lenb `div` 2) getWord16 + +getWord24 :: Get Int +getWord24 = do + a <- fmap fromIntegral getWord8 + b <- fmap fromIntegral getWord8 + c <- fmap fromIntegral getWord8 + return $ (a `shiftL` 16) .|. (b `shiftL` 8) .|. c + +getBytes :: Int -> Get ByteString +getBytes i = liftGet $ Bin.getBytes i + +processBytes :: Int -> Get a -> Get a +processBytes i f = do + r1 <- bytesRead + ret <- f + r2 <- bytesRead + if r2 == (r1 + i) + then return ret + else throwError (Error_Internal_Packet_ByteProcessed r1 r2 i) + +isEmpty :: Get Bool +isEmpty = liftGet Bin.isEmpty + +putWords8 :: [Word8] -> Put +putWords8 l = do + putWord8 $ fromIntegral (length l) + mapM_ putWord8 l + +putWord16 :: Word16 -> Put +putWord16 = putWord16be + +putWords16 :: [Word16] -> Put +putWords16 l = do + putWord16 $ 2 * (fromIntegral $ length l) + mapM_ putWord16 l + +putWord24 :: Int -> Put +putWord24 i = do + let a = fromIntegral ((i `shiftR` 16) .&. 0xff) + let b = fromIntegral ((i `shiftR` 8) .&. 0xff) + let c = fromIntegral (i .&. 0xff) + mapM_ putWord8 [a,b,c] + +encodeWord64 :: Word64 -> L.ByteString +encodeWord64 = runPut . putWord64be diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,7 @@ +The hs-tls project aims to reimplement the full TLS protocol (formely known as SSL) in haskell. +The focus of the projects is to provide a safer implementation than the ones existing, +through more purity, more type-checking, and more units tests. + +While the focus is to make it safer than other implementations, this current +implementation is *not* to be considered secure, since it doesn't fully +implement everything necessary (full certificate checking, protocol requirements, etc) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Stunnel.hs b/Stunnel.hs new file mode 100644 --- /dev/null +++ b/Stunnel.hs @@ -0,0 +1,149 @@ +import Network +import System.IO +import System +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LC + +import Control.Exception (bracket) +import Network.TLS.Cipher +import qualified Network.TLS.Client as C +import qualified Network.TLS.Server as S +import Network.TLS.SRandom +import Network.TLS.Struct +import Network.TLS.MAC +import Data.Word +import Data.Bits +import Data.Maybe +import Control.Monad (forM_, when, replicateM) +import Control.Monad.Trans (lift) +import Random +import qualified Codec.Crypto.AES.Random as AESRand +import Control.Concurrent (forkIO) +import Data.Certificate.PEM +import Data.Certificate.X509 +import Data.Certificate.Key + +ciphers :: [Cipher] +ciphers = + [ cipher_AES128_SHA1 + , cipher_AES256_SHA1 + , cipher_RC4_128_MD5 + , cipher_RC4_128_SHA1 + ] + +conv :: [Word8] -> Int +conv l = (a `shiftL` 24) .|. (b `shiftL` 16) .|. (c `shiftL` 8) .|. d + where + [a,b,c,d] = map fromIntegral l + +tlsclient handle crand prerand = do + C.connect handle crand prerand + C.sendData handle (L.pack $ map (toEnum.fromEnum) "GET / HTTP/1.0\r\n\r\n") + + d <- C.recvData handle + lift $ L.putStrLn d + + d <- C.recvData handle + lift $ L.putStrLn d + + return () + +mainClient :: String -> Int -> IO () +mainClient host port = do + {- generate some random stuff ready to be used after skipping some byte for no particular reason -} + ranByte <- fmap B.head $ AESRand.randBytes 1 + _ <- AESRand.randBytes (fromIntegral ranByte) + clientRandom <- fmap (fromJust . clientRandom . B.unpack) $ AESRand.randBytes 32 + premasterRandom <- fmap B.unpack $ AESRand.randBytes 46 + seqInit <- fmap (conv . B.unpack) $ AESRand.randBytes 4 + + handle <- connectTo host (PortNumber 6061) + hSetBuffering handle NoBuffering + + let clientstate = C.TLSClientParams + { C.cpConnectVersion = TLS10 + , C.cpAllowedVersions = [ TLS10 ] + , C.cpSession = Nothing + , C.cpCiphers = ciphers + , C.cpCertificate = Nothing + } + C.runTLSClient (tlsclient handle clientRandom premasterRandom) clientstate (makeSRandomGen seqInit) + + putStrLn "end" + +tlsserver handle srand = do + S.listen handle srand + _ <- S.recvData handle + S.sendData handle (LC.pack "this is some data") + lift $ hFlush handle + lift $ putStrLn "end" + +clientProcess ((certdata, cert), pk) (handle, src) = do + serverRandom <- fmap (fromJust . serverRandom . B.unpack) $ AESRand.randBytes 32 + seqInit <- fmap (conv . B.unpack) $ AESRand.randBytes 4 + + let serverstate = S.TLSServerParams + { S.spAllowedVersions = [TLS10] + , S.spSessions = [] + , S.spCiphers = ciphers + , S.spCertificate = Just (certdata, cert, pk) + , S.spWantClientCert = False + } + + S.runTLSServer (tlsserver handle serverRandom) serverstate (makeSRandomGen seqInit) + putStrLn "end" + +mainServerAccept cert port socket = do + (h, d, _) <- accept socket + forkIO $ clientProcess cert (h, d) + mainServerAccept cert port socket + +mainServer cert port = bracket (listenOn (PortNumber port)) (sClose) (mainServerAccept cert port) + +usage :: IO () +usage = do + putStrLn "usage: stunnel [client|server] " + exitFailure + +readCertificate :: FilePath -> IO (L.ByteString, Certificate) +readCertificate filepath = do + content <- B.readFile filepath + let certdata = case parsePEMCert content of + Left err -> error ("cannot read PEM certificate: " ++ err) + Right x -> L.fromChunks [x] + let cert = case decodeCertificate certdata of + Left err -> error ("cannot decode certificate: " ++ err) + Right x -> x + return (certdata, cert) + +readPrivateKey :: FilePath -> IO (L.ByteString, PrivateKey) +readPrivateKey filepath = do + content <- B.readFile filepath + let pkdata = case parsePEMKey content of + Left err -> error ("cannot read PEM key: " ++ err) + Right x -> L.fromChunks [x] + let pk = case decodePrivateKey pkdata of + Left err -> error ("cannot decode key: " ++ err) + Right x -> x + return (pkdata, pk) + +main = do + args <- getArgs + when (length args == 0) usage + case (args !! 0) of + "server" -> do + cert <- readCertificate (args !! 1) + pk <- readPrivateKey (args !! 2) + mainServer (cert, snd pk) 6061 + "client" -> do + let port = + if length args > 1 + then read $ args !! 1 + else 6061 + let dest = + if length args > 2 + then args !! 2 + else "localhost" + mainClient dest port + _ -> usage diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,44 @@ +protocol: + +- finish implementing renegocitiation Client and Server +- implement Certificate Verify / Certificate Request +- add Client Certificates +- add check for non-self signed certificate +- alert correctly on errors +- process session as they should +- put 4 bytes of time in client/server random +- implement compression +- proper separation for key exchange algorithm (hardcoded to RSA at the moment in differents place) +- implements different key exchange algorithm + +tls v1.2: + +- finish implementation of extensions +- implement finish digest generation with hmac256 +- implement finish digest generation with client/server negociated algorithm +- proper version dispatch in marshalling packets +- properly separate different version of the protocol +- implement AEAD + +code cleanup: + +- remove show derivation on internal crypto state +- opaquify differents data type through newtype + +security audit: + +- add unit tests for pure parts +- fix SRandomGen and random usage with proper CPRNG +- match security recommendation from the RFC +- audit the RSA implementation and the usage in TLS (remove spoon). + +misc: + +- verify it works with gnutls +- stunnel: use crypto secure random generator +- stunnel: actually make it works like stunnel instead of hardcoding the data and the port. +- investigate an iteratee interface +- portability +- implement more ciphers +- check & optimize memory footprint +- compare & optimize performance diff --git a/Tests.hs b/Tests.hs new file mode 100644 --- /dev/null +++ b/Tests.hs @@ -0,0 +1,85 @@ +import Text.Printf +import Data.Word +import Test.QuickCheck +import Test.QuickCheck.Batch + +import Network.TLS.Struct +import Network.TLS.Packet +import Control.Monad + +liftM6 f m1 m2 m3 m4 m5 m6 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; return (f x1 x2 x3 x4 x5 x6) } + +someWords8 :: Int -> Gen [Word8] +someWords8 i = replicateM i (fromIntegral `fmap` (choose (0,255) :: Gen Int)) + +someWords16 :: Int -> Gen [Word16] +someWords16 i = replicateM i (fromIntegral `fmap` (choose (0,65535) :: Gen Int)) + +instance Arbitrary Version where + arbitrary = elements [ SSL2, SSL3, TLS10, TLS11, TLS12 ] + +instance Arbitrary ProtocolType where + arbitrary = elements + [ ProtocolType_ChangeCipherSpec + , ProtocolType_Alert + , ProtocolType_Handshake + , ProtocolType_AppData ] + +instance Arbitrary Word8 where + arbitrary = fromIntegral `fmap` (choose (0,255) :: Gen Int) + +instance Arbitrary Word16 where + arbitrary = fromIntegral `fmap` (choose (0,65535) :: Gen Int) + +instance Arbitrary Header where + arbitrary = do + pt <- arbitrary + ver <- arbitrary + len <- arbitrary + return $ Header pt ver len + +instance Arbitrary ClientRandom where + arbitrary = ClientRandom `fmap` someWords8 32 + +instance Arbitrary ServerRandom where + arbitrary = ServerRandom `fmap` someWords8 32 + +instance Arbitrary Session where + arbitrary = do + i <- choose (1,2) :: Gen Int + case i of + 1 -> return $ Session Nothing + 2 -> (Session . Just) `fmap` someWords8 32 + +arbitraryCiphersIDs :: Gen [Word16] +arbitraryCiphersIDs = choose (0,200) >>= someWords16 + +arbitraryCompressionIDs :: Gen [Word8] +arbitraryCompressionIDs = choose (0,200) >>= someWords8 + +instance Arbitrary Handshake where + arbitrary = oneof + [ liftM6 ClientHello arbitrary arbitrary arbitrary arbitraryCiphersIDs arbitraryCompressionIDs (return Nothing) + , liftM6 ServerHello arbitrary arbitrary arbitrary arbitrary arbitrary (return Nothing) + , return HelloRequest + , return ServerHelloDone + ] + +{- quickcheck property -} + +prop_header_marshalling_id x = (decodeHeader $ encodeHeader x) == Right x +prop_handshake_marshalling_id x = (decodeHs $ encodeHandshake x) == Right x + where + decodeHs b = either (Left . id) (\(ty, bdata) -> decodeHandshake TLS10 ty bdata) $ decodeHandshakeHeader b + +{- main -} +options = TestOptions + { no_of_tests = 2000 + , length_of_tests = 1 + , debug_tests = False } + +main = do + runTests "marshalling=id" options + [ run prop_header_marshalling_id + , run prop_handshake_marshalling_id + ] diff --git a/tls.cabal b/tls.cabal new file mode 100644 --- /dev/null +++ b/tls.cabal @@ -0,0 +1,71 @@ +Name: tls +Version: 0.1 +Description: + Implementation of the TLS protocol, focusing on purity and more type-checking. + . + Currently implement only partially the TLS1.0 protocol. Not yet properly secure. + Do not yet use as replacement to more mature implementation. +License: BSD3 +License-file: LICENSE +Copyright: Vincent Hanquez +Author: Vincent Hanquez +Maintainer: Vincent Hanquez +Synopsis: TLS protocol for Server and Client sides +Build-Type: Simple +Category: Network +stability: experimental +Cabal-Version: >=1.6 +data-files: README, TODO + +Flag test + Description: Build unit test + Default: False + +Flag executable + Description: Build the executable + Default: False + +Library + Build-Depends: base >= 3 && < 5, + mtl, + cryptohash, + binary >= 0.5, + bytestring, + vector, + AES, RSA, spoon, + cryptocipher, + certificate >= 0.2 + Exposed-modules: Network.TLS.Client + Network.TLS.Server + Network.TLS.Struct + other-modules: Network.TLS.Cipher + Network.TLS.Compression + Network.TLS.Crypto + Network.TLS.MAC + Network.TLS.Packet + Network.TLS.State + Network.TLS.Sending + Network.TLS.Receiving + Network.TLS.SRandom + Network.TLS.Wire + ghc-options: -Wall + +Executable stunnel + Main-is: Stunnel.hs + if flag(executable) + Build-Depends: network, haskell98, RSA + Buildable: True + else + Buildable: False + +executable Tests + Main-is: Tests.hs + if flag(test) + Buildable: True + Build-Depends: base >= 3 && < 5, HUnit, QuickCheck, bytestring, haskell98 + else + Buildable: False + +source-repository head + type: git + location: git://github.com/vincenthz/hs-tls