tls (empty) → 0.1
raw patch · 20 files changed
+2892/−0 lines, 20 filesdep +AESdep +HUnitdep +QuickChecksetup-changed
Dependencies added: AES, HUnit, QuickCheck, RSA, base, binary, bytestring, certificate, cryptocipher, cryptohash, haskell98, mtl, network, spoon, vector
Files
- LICENSE +27/−0
- Network/TLS/Cipher.hs +268/−0
- Network/TLS/Client.hs +207/−0
- Network/TLS/Compression.hs +18/−0
- Network/TLS/Crypto.hs +101/−0
- Network/TLS/MAC.hs +63/−0
- Network/TLS/Packet.hs +408/−0
- Network/TLS/Receiving.hs +194/−0
- Network/TLS/SRandom.hs +30/−0
- Network/TLS/Sending.hs +178/−0
- Network/TLS/Server.hs +241/−0
- Network/TLS/State.hs +271/−0
- Network/TLS/Struct.hs +404/−0
- Network/TLS/Wire.hs +124/−0
- README +7/−0
- Setup.hs +2/−0
- Stunnel.hs +149/−0
- TODO +44/−0
- Tests.hs +85/−0
- tls.cabal +71/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2010 Vincent Hanquez <vincent@snarc.org>++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.
+ Network/TLS/Cipher.hs view
@@ -0,0 +1,268 @@+-- |+-- Module : Network.TLS.Cipher+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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+ }
+ Network/TLS/Client.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}++-- |+-- Module : Network.TLS.Client+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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)
+ Network/TLS/Compression.hs view
@@ -0,0 +1,18 @@+-- |+-- Module : Network.TLS.Compression+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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)+ }
+ Network/TLS/Crypto.hs view
@@ -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)
+ Network/TLS/MAC.hs view
@@ -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
+ Network/TLS/Packet.hs view
@@ -0,0 +1,408 @@+-- |+-- Module : Network.TLS.Packet+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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"
+ Network/TLS/Receiving.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}++-- |+-- Module : Network.TLS.Receiving+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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 ()
+ Network/TLS/SRandom.hs view
@@ -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)
+ Network/TLS/Sending.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module : Network.TLS.Sending+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
+ Network/TLS/Server.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+-- |+-- Module : Network.TLS.Server+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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)
+ Network/TLS/State.hs view
@@ -0,0 +1,271 @@+-- |+-- Module : Network.TLS.State+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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 })
+ Network/TLS/Struct.hs view
@@ -0,0 +1,404 @@+-- |+-- Module : Network.TLS.Struct+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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)
+ Network/TLS/Wire.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE GeneralizedNewtypeDeriving,FlexibleInstances #-}++-- |+-- Module : Network.TLS.Wire+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- 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
+ README view
@@ -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)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Stunnel.hs view
@@ -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] <params...>"+ 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
+ TODO view
@@ -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
+ Tests.hs view
@@ -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+ ]
+ tls.cabal view
@@ -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 <vincent@snarc.org>+Author: Vincent Hanquez <vincent@snarc.org>+Maintainer: Vincent Hanquez <vincent@snarc.org>+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