initial import
This commit is contained in:
Vincent Hanquez
commit
0b5a0dc548
20 changed files with 2892 additions and 0 deletions
27
LICENSE
Normal file
27
LICENSE
Normal file
|
|
@ -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.
|
||||
268
Network/TLS/Cipher.hs
Normal file
268
Network/TLS/Cipher.hs
Normal file
|
|
@ -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
|
||||
}
|
||||
207
Network/TLS/Client.hs
Normal file
207
Network/TLS/Client.hs
Normal file
|
|
@ -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)
|
||||
18
Network/TLS/Compression.hs
Normal file
18
Network/TLS/Compression.hs
Normal file
|
|
@ -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)
|
||||
}
|
||||
101
Network/TLS/Crypto.hs
Normal file
101
Network/TLS/Crypto.hs
Normal file
|
|
@ -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)
|
||||
63
Network/TLS/MAC.hs
Normal file
63
Network/TLS/MAC.hs
Normal file
|
|
@ -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
|
||||
408
Network/TLS/Packet.hs
Normal file
408
Network/TLS/Packet.hs
Normal file
|
|
@ -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"
|
||||
194
Network/TLS/Receiving.hs
Normal file
194
Network/TLS/Receiving.hs
Normal file
|
|
@ -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 ()
|
||||
30
Network/TLS/SRandom.hs
Normal file
30
Network/TLS/SRandom.hs
Normal file
|
|
@ -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)
|
||||
178
Network/TLS/Sending.hs
Normal file
178
Network/TLS/Sending.hs
Normal file
|
|
@ -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
|
||||
241
Network/TLS/Server.hs
Normal file
241
Network/TLS/Server.hs
Normal file
|
|
@ -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)
|
||||
271
Network/TLS/State.hs
Normal file
271
Network/TLS/State.hs
Normal file
|
|
@ -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 })
|
||||
404
Network/TLS/Struct.hs
Normal file
404
Network/TLS/Struct.hs
Normal file
|
|
@ -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)
|
||||
124
Network/TLS/Wire.hs
Normal file
124
Network/TLS/Wire.hs
Normal file
|
|
@ -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
|
||||
7
README
Normal file
7
README
Normal file
|
|
@ -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)
|
||||
2
Setup.hs
Normal file
2
Setup.hs
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
149
Stunnel.hs
Normal file
149
Stunnel.hs
Normal file
|
|
@ -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
|
||||
44
TODO
Normal file
44
TODO
Normal file
|
|
@ -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
|
||||
85
Tests.hs
Normal file
85
Tests.hs
Normal file
|
|
@ -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
|
||||
]
|
||||
71
tls.cabal
Normal file
71
tls.cabal
Normal file
|
|
@ -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
|
||||
Loading…
Reference in a new issue