tls 0.3.3 → 0.4.0
raw patch · 14 files changed
+561/−636 lines, 14 files
Files
- Network/TLS.hs +40/−0
- Network/TLS/Cipher.hs +2/−0
- Network/TLS/Client.hs +0/−220
- Network/TLS/Compression.hs +10/−0
- Network/TLS/Core.hs +342/−0
- Network/TLS/Crypto.hs +1/−0
- Network/TLS/Receiving.hs +26/−45
- Network/TLS/SRandom.hs +2/−0
- Network/TLS/Sending.hs +19/−21
- Network/TLS/Server.hs +0/−236
- Network/TLS/State.hs +60/−58
- Network/TLS/Struct.hs +7/−0
- Stunnel.hs +46/−50
- tls.cabal +6/−6
+ Network/TLS.hs view
@@ -0,0 +1,40 @@+-- |+-- Module : Network.TLS+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+module Network.TLS+ (+ module Network.TLS.Core+ -- * Crypto Key+ , PrivateKey(..)+ -- * Crypto RNG+ , makeSRandomGen, SRandomGen+ -- * Compressions & Predefined compressions+ , Compression+ , nullCompression+ -- * Ciphers & Predefined ciphers+ , Cipher+ , cipher_null_null+ , cipher_null_SHA1+ , cipher_null_MD5+ , cipher_RC4_128_MD5+ , cipher_RC4_128_SHA1+ , cipher_AES128_SHA1+ , cipher_AES256_SHA1+ , cipher_AES128_SHA256+ , cipher_AES256_SHA256+ -- * Versions+ , Version(..)+ -- * Errors+ , TLSError(..)+ ) where++import Network.TLS.Struct (Version(..), TLSError(..))+import Network.TLS.Crypto (PrivateKey(..))+import Network.TLS.Cipher (Cipher(..), cipher_null_null , cipher_null_SHA1 , cipher_null_MD5 , cipher_RC4_128_MD5 , cipher_RC4_128_SHA1 , cipher_AES128_SHA1 , cipher_AES256_SHA1 , cipher_AES128_SHA256 , cipher_AES256_SHA256)+import Network.TLS.Compression (Compression(..), nullCompression)+import Network.TLS.SRandom (makeSRandomGen, SRandomGen)+import Network.TLS.Core
Network/TLS/Cipher.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_HADDOCK hide #-} -- | -- Module : Network.TLS.Cipher -- License : BSD-style@@ -61,6 +62,7 @@ | CipherKeyExchangeECDH_RSA | CipherKeyExchangeECDHE_ECDSA +-- | Cipher algorithm data Cipher = Cipher { cipherID :: Word16 , cipherName :: String
− Network/TLS/Client.hs
@@ -1,220 +0,0 @@-{-# 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(..)- , TLSClientCallbacks(..)- , TLSStateClient- , TLSClient (..)- , runTLSClient- -- * low level packet sending receiving.- , recvPacket- , sendPacket- -- * API, warning probably subject to change- , initiate- , connect- , sendData- , recvData- , close- ) where--import Data.Maybe-import Data.Word-import Control.Applicative ((<$>))-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 as B-import qualified Data.ByteString.Lazy as L-import System.IO (Handle, hFlush)-import Data.List (find)--data TLSClientCallbacks = TLSClientCallbacks- { cbCertificates :: Maybe ([X509] -> IO Bool) -- ^ optional callback to verify certificates- }--instance Show TLSClientCallbacks where- show _ = "[callbacks]"--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 X509 -- ^ an optional client certificate- , cpCallbacks :: TLSClientCallbacks -- ^ user callbacks- } 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 (modify (\st -> id $! st { scTLSState = s }))--instance MonadTrans TLSClient where- lift = TLSClient . lift--instance (Functor m, 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 = cpConnectVersion params, stClientContext = True }--{- | receive a single TLS packet or on error a TLSError -}-recvPacket :: Handle -> TLSClient IO (Either TLSError [Packet])-recvPacket handle = do- hdr <- lift $ B.hGet handle 5 >>= return . decodeHeader- case hdr of- Left err -> return $ Left err- Right header@(Header _ _ readlen) -> do- content <- lift $ B.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 $ B.hPut handle dataToSend--processServerInfo :: Packet -> TLSClient IO ()-processServerInfo (Handshake (ServerHello ver _ _ cipher _ _)) = do- ciphers <- cpCiphers . scParams <$> get- allowedvers <- cpAllowedVersions . scParams <$> get- 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--processServerInfo (Handshake (CertRequest _ _ _)) = do- modify (\sc -> sc { scCertRequested = True })--processServerInfo (Handshake (Certificates certs)) = do- callbacks <- cpCallbacks . scParams <$> get- valid <- lift $ maybe (return True) (\cb -> cb certs) (cbCertificates callbacks)- unless valid $ error "certificates received deemed invalid by user"--processServerInfo _ = return ()--recvServerInfo :: Handle -> TLSClient IO ()-recvServerInfo handle = do- whileStatus (/= (StatusHandshake HsStatusServerHelloDone)) $ do- pkts <- recvPacket handle- case pkts of- Left err -> error ("error received: " ++ show err)- Right l -> forM_ l processServerInfo--connectSendClientHello :: Handle -> TLSClient IO ()-connectSendClientHello handle = do- crand <- fromJust . clientRandom <$> withTLSRNG (\rng -> getRandomBytes rng 32)- ver <- cpConnectVersion . scParams <$> get- ciphers <- cpCiphers . scParams <$> get- sendPacket handle $ Handshake (ClientHello ver crand (Session Nothing) (map cipherID ciphers) [ 0 ] Nothing)--connectSendClientCertificate :: Handle -> TLSClient IO ()-connectSendClientCertificate handle = do- certRequested <- scCertRequested <$> get- when certRequested $ do- clientCert <- cpCertificate . scParams <$> get- sendPacket handle $ Handshake (Certificates $ maybe [] (:[]) clientCert)--connectSendClientKeyXchg :: Handle -> TLSClient IO ()-connectSendClientKeyXchg handle = do- prerand <- ClientKeyData <$> withTLSRNG (\rng -> getRandomBytes rng 46)- ver <- cpConnectVersion . scParams <$> get- sendPacket handle $ Handshake (ClientKeyXchg ver prerand)--connectSendFinish :: Handle -> TLSClient IO ()-connectSendFinish handle = do- cf <- getHandshakeDigest True- sendPacket handle (Handshake $ Finished $ B.unpack cf)--{- | initiate a new TLS connection through a handshake on a handle. -}-initiate :: Handle -> TLSClient IO ()-initiate handle = do- connectSendClientHello handle- recvServerInfo handle- connectSendClientCertificate handle-- connectSendClientKeyXchg handle-- {- maybe send certificateVerify -}- {- FIXME not implemented yet -}-- sendPacket handle (ChangeCipherSpec)- lift $ hFlush handle-- {- send Finished -}- connectSendFinish handle- - {- receive changeCipherSpec -}- _ <- recvPacket handle-- {- receive Finished -}- _ <- recvPacket handle-- return ()--{-# DEPRECATED connect "use initiate" #-}-connect :: Handle -> TLSClient IO ()-connect = initiate--sendDataChunk :: Handle -> B.ByteString -> TLSClient IO ()-sendDataChunk handle d =- if B.length d > 16384- then do- let (sending, remain) = B.splitAt 16384 d- sendPacket handle $ AppData sending- sendDataChunk handle remain- else- sendPacket handle $ AppData d--{- | sendData sends a bunch of data -}-sendData :: Handle -> L.ByteString -> TLSClient IO ()-sendData handle d = mapM_ (sendDataChunk handle) (L.toChunks 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 $ L.fromChunks [x]- Right [Handshake HelloRequest] -> connect handle >> recvData handle- Left err -> error ("error received: " ++ show err)- _ -> error "unexpected item"--{- | close a TLS connection.- - note that it doesn't close the handle, but just signal we're going to close- - the connection to the other side -}-close :: Handle -> TLSClient IO ()-close handle = do- sendPacket handle $ Alert (AlertLevel_Warning, CloseNotify)
Network/TLS/Compression.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_HADDOCK hide #-} -- | -- Module : Network.TLS.Compression -- License : BSD-style@@ -7,12 +8,21 @@ -- module Network.TLS.Compression ( Compression(..)+ , nullCompression ) where import Data.Word import Data.ByteString (ByteString) +-- | Compression algorithm data Compression = Compression { compressionID :: Word8 , compressionFct :: (ByteString -> ByteString) }++instance Show Compression where+ show = show . compressionID++-- | default null compression+nullCompression :: Compression+nullCompression = Compression { compressionID = 0, compressionFct = id }
+ Network/TLS/Core.hs view
@@ -0,0 +1,342 @@+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Network.TLS.Core+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+module Network.TLS.Core+ (+ -- * Context configuration+ TLSParams(..)+ , defaultParams++ -- * Context object+ , TLSCtx+ , ctxHandle++ -- * Creating a context+ , client+ , server++ -- * Initialisation and Termination of context+ , bye+ , handshake++ -- * High level API+ , sendData+ , recvData+ ) where++import Network.TLS.Struct+import Network.TLS.Cipher+import Network.TLS.Compression+import Network.TLS.Crypto+import Network.TLS.Packet+import Network.TLS.State+import Network.TLS.Sending+import Network.TLS.Receiving+import Network.TLS.SRandom+import Data.Maybe+import Data.Certificate.X509+import Data.List (intersect, intercalate, find)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L++import Control.Applicative ((<$>))+import Control.Concurrent.MVar+import Control.Monad.State+import System.IO (Handle, hSetBuffering, BufferMode(..), hFlush)++data TLSParams = TLSParams+ { pConnectVersion :: Version -- ^ version to use on client connection.+ , pAllowedVersions :: [Version] -- ^ allowed versions that we can use.+ , pCiphers :: [Cipher] -- ^ all ciphers supported ordered by priority.+ , pCompressions :: [Compression] -- ^ all compression supported ordered by priority.+ , pWantClientCert :: Bool -- ^ request a certificate from client.+ -- use by server only.+ , pCertificates :: [(X509, Maybe PrivateKey)] -- ^ the cert chain for this context with the associated keys if any.+ , onCertificatesRecv :: ([X509] -> IO Bool) -- ^ callback to verify received cert chain.+ }++defaultParams :: TLSParams+defaultParams = TLSParams+ { pConnectVersion = TLS10+ , pAllowedVersions = [TLS10,TLS11]+ , pCiphers = []+ , pCompressions = [nullCompression]+ , pWantClientCert = False+ , pCertificates = []+ , onCertificatesRecv = (\_ -> return True)+ }++instance Show TLSParams where+ show p = "TLSParams { " ++ (intercalate "," $ map (\(k,v) -> k ++ "=" ++ v)+ [ ("connectVersion", show $ pConnectVersion p)+ , ("allowedVersions", show $ pAllowedVersions p)+ , ("ciphers", show $ pCiphers p)+ , ("compressions", show $ pCompressions p)+ , ("want-client-cert", show $ pWantClientCert p)+ , ("certificates", show $ length $ pCertificates p)+ ]) ++ " }"++-- | A TLS Context is a handle augmented by tls specific state and parameters+data TLSCtx = TLSCtx+ { ctxHandle :: Handle+ , ctxParams :: TLSParams -- ^ return the handle associated with this context+ , ctxState :: MVar TLSState+ }++newCtx :: Handle -> TLSParams -> TLSState -> IO TLSCtx+newCtx handle params state = do+ hSetBuffering handle NoBuffering+ stvar <- newMVar state+ return $ TLSCtx+ { ctxHandle = handle+ , ctxParams = params+ , ctxState = stvar+ }++usingState :: MonadIO m => TLSCtx -> TLSSt a -> m (Either TLSError a)+usingState ctx f = liftIO (takeMVar mvar) >>= execAndStore+ where+ mvar = ctxState ctx+ execAndStore st = do+ -- FIXME add onException with (putMVar mvar st)+ let (a, newst) = runTLSState f st+ liftIO (putMVar mvar newst)+ return a++usingState_ :: MonadIO m => TLSCtx -> TLSSt a -> m a+usingState_ ctx f = do+ ret <- usingState ctx f+ case ret of+ Left err -> error ("assertion failed, wrong use of state_: " ++ show err)+ Right r -> return r++getStateRNG :: MonadIO m => TLSCtx -> Int -> m Bytes+getStateRNG ctx n = usingState_ ctx (withTLSRNG (\rng -> getRandomBytes rng n))++whileStatus :: MonadIO m => TLSCtx -> (TLSStatus -> Bool) -> m a -> m ()+whileStatus ctx p a = do+ b <- usingState_ ctx (p . stStatus <$> get)+ when b (a >> whileStatus ctx p a)++-- | receive one enveloppe from the context that contains 1 or+-- many packets (many only in case of handshake). if will returns a+-- TLSError if the packet is unexpected or malformed+recvPacket :: MonadIO m => TLSCtx -> m (Either TLSError [Packet])+recvPacket ctx = do+ hdr <- (liftIO $ B.hGet (ctxHandle ctx) 5) >>= return . decodeHeader+ case hdr of+ Left err -> return $ Left err+ Right header@(Header _ _ readlen) -> do+ content <- liftIO $ B.hGet (ctxHandle ctx) (fromIntegral readlen)+ usingState ctx $ readPacket header (EncryptedData content)++-- | Send one packet to the context+sendPacket :: MonadIO m => TLSCtx -> Packet -> m ()+sendPacket ctx pkt = do+ dataToSend <- usingState_ ctx $ writePacket pkt+ liftIO $ B.hPut (ctxHandle ctx) dataToSend++-- | Create a new Client context with a configuration, a RNG, and a Handle.+-- It reconfigures the handle buffermode to noBuffering+client :: MonadIO m => TLSParams -> SRandomGen -> Handle -> m TLSCtx+client params rng handle = liftIO $ newCtx handle params state+ where state = (newTLSState rng) { stClientContext = True }++-- | Create a new Server context with a configuration, a RNG, and a Handle.+-- It reconfigures the handle buffermode to noBuffering+server :: MonadIO m => TLSParams -> SRandomGen -> Handle -> m TLSCtx+server params rng handle = liftIO $ newCtx handle params state+ where state = (newTLSState rng) { stClientContext = False }++-- | notify the context that this side wants to close connection.+-- this is important that it is called before closing the handle, otherwise+-- the session might not be resumable (for version < TLS1.2).+--+-- this doesn't actually close the handle+bye :: MonadIO m => TLSCtx -> m ()+bye ctx = sendPacket ctx $ Alert (AlertLevel_Warning, CloseNotify)++-- client part of handshake. send a bunch of handshake of client+-- values intertwined with response from the server.+handshakeClient :: MonadIO m => TLSCtx -> m ()+handshakeClient ctx = do+ -- Send ClientHello+ crand <- getStateRNG ctx 32 >>= return . ClientRandom+ sendPacket ctx $ Handshake $ ClientHello ver crand+ (Session Nothing)+ (map cipherID ciphers)+ (map compressionID compressions)+ Nothing++ -- Receive Server information until ServerHelloDone+ whileStatus ctx (/= (StatusHandshake HsStatusServerHelloDone)) $ do+ pkts <- recvPacket ctx+ case pkts of+ Left err -> error ("error received: " ++ show err)+ Right l -> mapM_ processServerInfo l++ -- Send Certificate if requested. XXX disabled for now.+ certRequested <- return False+ when certRequested (sendPacket ctx $ Handshake (Certificates clientCerts))++ -- Send ClientKeyXchg+ prerand <- getStateRNG ctx 46 >>= return . ClientKeyData+ sendPacket ctx $ Handshake (ClientKeyXchg ver prerand)++ {- maybe send certificateVerify -}+ {- FIXME not implemented yet -}++ sendPacket ctx ChangeCipherSpec+ liftIO $ hFlush $ ctxHandle ctx++ -- Send Finished+ cf <- usingState_ ctx $ getHandshakeDigest True+ sendPacket ctx (Handshake $ Finished $ B.unpack cf)++ -- receive changeCipherSpec & Finished+ recvPacket ctx >> recvPacket ctx >> return ()++ where+ params = ctxParams ctx+ ver = pConnectVersion params+ allowedvers = pAllowedVersions params+ ciphers = pCiphers params+ compressions = pCompressions params+ clientCerts = map fst $ pCertificates params++ processServerInfo (Handshake (ServerHello rver _ _ cipher _ _)) = do+ case find ((==) rver) allowedvers of+ Nothing -> error ("received version which is not allowed: " ++ show ver)+ Just _ -> usingState_ ctx $ setVersion ver+ case find ((==) cipher . cipherID) ciphers of+ Nothing -> error "no cipher in common with the server"+ Just c -> usingState_ ctx $ setCipher c++ processServerInfo (Handshake (CertRequest _ _ _)) = do+ return ()+ --modify (\sc -> sc { scCertRequested = True })++ processServerInfo (Handshake (Certificates certs)) = do+ let cb = onCertificatesRecv $ params+ valid <- liftIO $ cb certs+ unless valid $ error "certificates received deemed invalid by user"++ processServerInfo _ = return ()++handshakeServerWith :: MonadIO m => TLSCtx -> Handshake -> m ()+handshakeServerWith ctx (ClientHello ver _ _ ciphers compressions _) = do+ -- Handle Client hello+ when (not $ elem ver (pAllowedVersions params)) $ fail "unsupported version"+ when (commonCiphers == []) $ fail "no common cipher supported"+ when (commonCompressions == []) $ fail "no common compression supported"+ usingState_ ctx $ modify (\st -> st+ { stVersion = ver+ , stCipher = Just usedCipher+ --, stCompression = Just usedCompression+ })++ -- send Server Data until ServerHelloDone+ handshakeSendServerData+ liftIO $ hFlush $ ctxHandle ctx++ -- Receive client info until client Finished.+ whileStatus ctx (/= (StatusHandshake HsStatusClientFinished)) (recvPacket ctx)++ sendPacket ctx ChangeCipherSpec++ -- Send Finish+ cf <- usingState_ ctx $ getHandshakeDigest False+ sendPacket ctx (Handshake $ Finished $ B.unpack cf)++ liftIO $ hFlush $ ctxHandle ctx+ return ()+ where+ params = ctxParams ctx+ commonCiphers = intersect ciphers (map cipherID $ pCiphers params)+ usedCipher = fromJust $ find (\c -> cipherID c == head commonCiphers) (pCiphers params)+ commonCompressions = intersect compressions (map compressionID $ pCompressions params)+ usedCompression = fromJust $ find (\c -> compressionID c == head commonCompressions) (pCompressions params)+ srvCerts = map fst $ pCertificates params+ privKeys = map snd $ pCertificates params+ needKeyXchg = cipherExchangeNeedMoreData $ cipherKeyExchange usedCipher++ handshakeSendServerData = do+ srand <- getStateRNG ctx 32 >>= return . ServerRandom++ case privKeys of+ (Just privkey : _) -> usingState_ ctx $ setPrivateKey privkey+ _ -> return () -- return a sensible error++ -- in TLS12, we need to check as well the certificates we are sending if they have in the extension+ -- the necessary bits set.++ -- send ServerHello & Certificate & ServerKeyXchg & CertReq+ sendPacket ctx $ Handshake $ ServerHello ver srand+ (Session Nothing)+ (cipherID usedCipher)+ (compressionID usedCompression)+ Nothing+ sendPacket ctx (Handshake $ Certificates srvCerts)+ when needKeyXchg $ do+ let skg = SKX_RSA Nothing+ sendPacket ctx (Handshake $ ServerKeyXchg skg)+ -- FIXME we don't do this on a Anonymous server+ when (pWantClientCert params) $ do+ let certTypes = [ CertificateType_RSA_Sign ]+ let creq = CertRequest certTypes Nothing [0,0,0]+ sendPacket ctx (Handshake creq)+ -- Send HelloDone+ sendPacket ctx (Handshake ServerHelloDone)++handshakeServerWith _ _ = fail "unexpected handshake type received. expecting client hello"++-- after receiving a client hello, we need to redo a handshake -}+handshakeServer :: MonadIO m => TLSCtx -> m ()+handshakeServer ctx = do+ pkts <- recvPacket ctx+ case pkts of+ Right [Handshake hs] -> handshakeServerWith ctx hs+ x -> fail ("unexpected type received. expecting handshake ++ " ++ show x)++-- | Handshake for a new TLS connection+-- This is to be called at the beginning of a connection, and during renegociation+handshake :: MonadIO m => TLSCtx -> m ()+handshake ctx = do+ cc <- usingState_ ctx (stClientContext <$> get)+ if cc+ then handshakeClient ctx+ else handshakeServer ctx++-- | sendData sends a bunch of data.+-- It will automatically chunk data to acceptable packet size+sendData :: MonadIO m => TLSCtx -> L.ByteString -> m ()+sendData ctx dataToSend = mapM_ sendDataChunk (L.toChunks dataToSend)+ where sendDataChunk d =+ if B.length d > 16384+ then do+ let (sending, remain) = B.splitAt 16384 d+ sendPacket ctx $ AppData sending+ sendDataChunk remain+ else+ sendPacket ctx $ AppData d++-- | recvData get data out of Data packet, and automatically renegociate if+-- a Handshake ClientHello is received+recvData :: MonadIO m => TLSCtx -> m L.ByteString+recvData ctx = do+ pkt <- recvPacket ctx+ case pkt of+ -- on server context receiving a client hello == renegociation+ Right [Handshake ch@(ClientHello _ _ _ _ _ _)] ->+ handshakeServerWith ctx ch >> recvData ctx+ -- on client context, receiving a hello request == renegociation+ Right [Handshake HelloRequest] ->+ handshakeClient ctx >> recvData ctx+ Right [AppData x] -> return $ L.fromChunks [x]+ Left err -> error ("error received: " ++ show err)+ _ -> error "unexpected item"
Network/TLS/Crypto.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_HADDOCK hide #-} module Network.TLS.Crypto ( HashType(..) , HashCtx
Network/TLS/Receiving.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}- -- | -- Module : Network.TLS.Receiving -- License : BSD-style@@ -35,33 +33,16 @@ import qualified Crypto.Cipher.RSA as RSA -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 :: Either TLSError a -> TLSSt a returnEither (Left err) = throwError err returnEither (Right a) = return a -readPacket :: MonadTLSState m => Header -> EncryptedData -> m (Either TLSError [Packet])-readPacket hdr content = runTLSRead (checkState hdr >> decryptContent hdr content >>= processPacket hdr)+readPacket :: Header -> EncryptedData -> TLSSt [Packet]+readPacket hdr content = checkState hdr >> decryptContent hdr content >>= processPacket hdr -checkState :: Header -> TLSRead ()+checkState :: Header -> TLSSt () checkState (Header pt _ _) =- stStatus <$> getTLSState >>= \status -> unless (allowed pt status) $ throwError $ Error_Packet_unexpected (show status) (show pt)+ stStatus <$> get >>= \status -> unless (allowed pt status) $ throwError $ Error_Packet_unexpected (show status) (show pt) where allowed :: ProtocolType -> TLSStatus -> Bool allowed ProtocolType_Alert _ = True@@ -73,7 +54,7 @@ allowed ProtocolType_ChangeCipherSpec (StatusHandshake HsStatusClientCertificateVerify) = True allowed _ _ = False -processPacket :: Header -> Bytes -> TLSRead [Packet]+processPacket :: Header -> Bytes -> TLSSt [Packet] processPacket (Header ProtocolType_AppData _ _) content = return [AppData content] @@ -95,7 +76,7 @@ when (finishHandshakeTypeMaterial ty) $ updateHandshakeDigestSplitted ty content return hs -processHandshake :: Version -> HandshakeType -> ByteString -> TLSRead Packet+processHandshake :: Version -> HandshakeType -> ByteString -> TLSSt Packet processHandshake ver ty econtent = do -- SECURITY FIXME if RSA fail, we need to generate a random master secret and not fail. e <- updateStatusHs ty@@ -125,44 +106,44 @@ _ -> return () return $ Handshake hs -decryptRSA :: MonadTLSState m => ByteString -> m (Either KxError ByteString)+decryptRSA :: ByteString -> TLSSt (Either KxError ByteString) decryptRSA econtent = do- ver <- return . stVersion =<< getTLSState- rsapriv <- getTLSState >>= return . fromJust "rsa private key" . hstRSAPrivateKey . fromJust "handshake" . stHandshake+ ver <- return . stVersion =<< get+ rsapriv <- get >>= return . fromJust "rsa private key" . hstRSAPrivateKey . fromJust "handshake" . stHandshake return $ kxDecrypt rsapriv (if ver < TLS10 then econtent else B.drop 2 econtent) -setMasterSecretRandom :: ByteString -> TLSRead ()+setMasterSecretRandom :: ByteString -> TLSSt () setMasterSecretRandom content = do- st <- getTLSState+ st <- get let (bytes, g') = getRandomBytes (stRandomGen st) (fromIntegral $ B.length content)- putTLSState $ st { stRandomGen = g' }+ put $ st { stRandomGen = g' } setMasterSecret bytes -processClientKeyXchg :: Version -> ByteString -> TLSRead ()+processClientKeyXchg :: Version -> ByteString -> TLSSt () 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 "handshake" . stHandshake+ expectedVer <- get >>= return . hstClientVersion . fromJust "handshake" . stHandshake if expectedVer /= ver then setMasterSecretRandom content else setMasterSecret content -processClientFinished :: FinishedData -> TLSRead ()+processClientFinished :: FinishedData -> TLSSt () processClientFinished fdata = do- cc <- getTLSState >>= return . stClientContext+ cc <- get >>= return . stClientContext expected <- getHandshakeDigest (not cc) when (expected /= B.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 () -decryptContent :: Header -> EncryptedData -> TLSRead ByteString+decryptContent :: Header -> EncryptedData -> TLSSt ByteString decryptContent hdr e@(EncryptedData b) = do- st <- getTLSState+ st <- get if stRxEncrypted st then decryptData e >>= getCipherData hdr else return b -getCipherData :: Header -> CipherData -> TLSRead ByteString+getCipherData :: Header -> CipherData -> TLSSt ByteString getCipherData hdr cdata = do -- check if the MAC is valid. macValid <- case cipherDataMAC cdata of@@ -179,7 +160,7 @@ paddingValid <- case cipherDataPadding cdata of Nothing -> return True Just pad -> do- ver <- stVersion <$> getTLSState+ ver <- stVersion <$> get let b = B.length pad - 1 if ver < TLS10 then return True@@ -190,9 +171,9 @@ return $ cipherDataContent cdata -decryptData :: EncryptedData -> TLSRead CipherData+decryptData :: EncryptedData -> TLSSt CipherData decryptData (EncryptedData econtent) = do- st <- getTLSState+ st <- get let cipher = fromJust "cipher" $ stCipher st let cst = fromJust "rx crypt state" $ stRxCryptState st@@ -219,7 +200,7 @@ then B.splitAt (fromIntegral $ cipherIVSize cipher) econtent else (cstIV cst, econtent) let newiv = fromJust "new iv" $ takelast padding_size econtent'- putTLSState $ st { stRxCryptState = Just $ cst { cstIV = newiv } }+ put $ st { stRxCryptState = Just $ cst { cstIV = newiv } } let content' = decryptF writekey iv econtent' let paddinglength = fromIntegral (B.last content') + 1@@ -236,14 +217,14 @@ {- update Ctx -} let contentlen = B.length content' - digestSize let (content, mac, _) = fromJust "p3" $ partition3 content' (contentlen, digestSize, 0)- putTLSState $ st { stRxCryptState = Just $ cst { cstIV = newiv } }+ put $ st { stRxCryptState = Just $ cst { cstIV = newiv } } return $ CipherData { cipherDataContent = content , cipherDataMAC = Just mac , cipherDataPadding = Nothing } -processCertificates :: [X509] -> TLSRead ()+processCertificates :: [X509] -> TLSSt () processCertificates certs = do let (X509 mainCert _ _ _) = head certs case certPubKey mainCert of
Network/TLS/SRandom.hs view
@@ -22,6 +22,7 @@ data Word128 = Word128 !Word64 !Word64 +{-| An opaque object containing an AES CPRNG -} data SRandomGen = RNG !ByteString !Word128 !AES.Key instance Show SRandomGen where@@ -63,6 +64,7 @@ chunk = AES.encryptCBC key iv bytes bytes = iv `bxor` (put128 counter) +{-| initialize from system a new SrandomGen -} makeSRandomGen :: IO (Either GenError SRandomGen) makeSRandomGen = getEntropy 64 >>= return . make
Network/TLS/Sending.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}- -- | -- Module : Network.TLS.Sending -- License : BSD-style@@ -32,9 +30,9 @@ - '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 :: Packet -> TLSSt (Header, ByteString) makePacketData pkt = do- ver <- getTLSState >>= return . stVersion+ ver <- get >>= return . stVersion content <- writePacketContent pkt let hdr = Header (packetType pkt) ver (fromIntegral $ B.length content) return (hdr, content)@@ -42,7 +40,7 @@ {- - Handshake data need to update a digest -}-processPacketData :: MonadTLSState m => (Header, ByteString) -> m (Header, ByteString)+processPacketData :: (Header, ByteString) -> TLSSt (Header, ByteString) processPacketData dat@(Header ty _ _, content) = do when (ty == ProtocolType_Handshake) (updateHandshakeDigest content) return dat@@ -51,9 +49,9 @@ - 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 :: (Header, ByteString) -> TLSSt (Header, ByteString) encryptPacketData dat = do- st <- getTLSState+ st <- get if stTxEncrypted st then encryptContent dat else return dat@@ -63,7 +61,7 @@ - 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 :: (Header, ByteString) -> TLSSt (Header, ByteString) postprocessPacketData dat@(Header ProtocolType_ChangeCipherSpec _ _, _) = switchTxEncryption >> isClientContext >>= \cc -> when cc setKeyBlock >> return dat @@ -72,13 +70,13 @@ {- - marshall packet data -}-encodePacket :: MonadTLSState m => (Header, ByteString) -> m ByteString+encodePacket :: (Header, ByteString) -> TLSSt ByteString encodePacket (hdr, content) = return $ B.concat [ encodeHeader hdr, content ] {- - just update TLS state machine -}-preProcessPacket :: MonadTLSState m => Packet -> m Packet+preProcessPacket :: Packet -> TLSSt Packet preProcessPacket pkt = do e <- case pkt of Handshake hs -> updateStatusHs (typeOfHandshake hs)@@ -91,7 +89,7 @@ - writePacket transform a packet into marshalled data related to current state - and updating state on the go -}-writePacket :: MonadTLSState m => Packet -> m ByteString+writePacket :: Packet -> TLSSt ByteString writePacket pkt = preProcessPacket pkt >>= makePacketData >>= processPacketData >>= encryptPacketData >>= postprocessPacketData >>= encodePacket @@ -102,27 +100,27 @@ {- 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 :: ByteString -> TLSSt ByteString encryptRSA content = do- st <- getTLSState+ st <- get let g = stRandomGen st let rsakey = fromJust "rsa public key" $ hstRSAPublicKey $ fromJust "handshake" $ stHandshake st case kxEncrypt g rsakey content of Left err -> fail ("rsa encrypt failed: " ++ show err) Right (econtent, g') -> do- putTLSState (st { stRandomGen = g' })+ put (st { stRandomGen = g' }) return econtent -encryptContent :: MonadTLSState m => (Header, ByteString) -> m (Header, ByteString)+encryptContent :: (Header, ByteString) -> TLSSt (Header, ByteString) encryptContent (hdr@(Header pt ver _), content) = do digest <- makeDigest True hdr content encrypted_msg <- encryptData $ B.concat [content, digest] let hdrnew = Header pt ver (fromIntegral $ B.length encrypted_msg) return (hdrnew, encrypted_msg) -encryptData :: MonadTLSState m => ByteString -> m ByteString+encryptData :: ByteString -> TLSSt ByteString encryptData content = do- st <- getTLSState+ st <- get let cipher = fromJust "cipher" $ stCipher st let cst = fromJust "tx crypt state" $ stTxCryptState st@@ -144,14 +142,14 @@ let iv = cstIV cst let e = encrypt writekey iv (B.concat [ content, padding ]) let newiv = fromJust "new iv" $ takelast (fromIntegral $ cipherIVSize cipher) e- putTLSState $ st { stTxCryptState = Just $ cst { cstIV = newiv } }+ put $ st { stTxCryptState = Just $ cst { cstIV = newiv } } return $ if hasExplicitBlockIV $ stVersion st then B.concat [iv,e] else e CipherStreamF initF encryptF _ -> do let iv = cstIV cst let (e, newiv) = encryptF (if iv /= B.empty then iv else initF writekey) content- putTLSState $ st { stTxCryptState = Just $ cst { cstIV = newiv } }+ put $ st { stTxCryptState = Just $ cst { cstIV = newiv } } return e return econtent @@ -161,9 +159,9 @@ encodePacketContent (ChangeCipherSpec) = encodeChangeCipherSpec encodePacketContent (AppData x) = x -writePacketContent :: MonadTLSState m => Packet -> m ByteString+writePacketContent :: Packet -> TLSSt ByteString writePacketContent (Handshake ckx@(ClientKeyXchg _ _)) = do- ver <- getTLSState >>= return . stVersion + ver <- get >>= return . stVersion let premastersecret = runPut $ encodeHandshakeContent ckx setMasterSecret premastersecret econtent <- encryptRSA premastersecret
− Network/TLS/Server.hs
@@ -1,236 +0,0 @@-{-# 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(..)- , TLSServerCallbacks(..)- , 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 Control.Applicative ((<$>))-import Data.Certificate.X509-import qualified Data.Certificate.KeyRSA as KeyRSA-import qualified Data.Certificate.KeyDSA as KeyDSA-import Network.TLS.Cipher-import Network.TLS.Crypto-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 as B-import qualified Data.ByteString.Lazy as L-import System.IO (Handle, hFlush)-import qualified Crypto.Cipher.RSA as RSA--type TLSServerCert = (B.ByteString, X509, KeyRSA.Private)--data TLSServerCallbacks = TLSServerCallbacks- { cbCertificates :: Maybe ([Certificate] -> IO Bool) -- ^ optional callback to verify certificates- }--instance Show TLSServerCallbacks where- show _ = "[callbacks]"--instance Show KeyRSA.Private where- show _ = "[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- , spCallbacks :: TLSServerCallbacks -- ^ user callbacks- } deriving (Show)--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 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) { stClientContext = False }--{- | receive a single TLS packet or on error a TLSError -}-recvPacket :: Handle -> TLSServer IO (Either TLSError [Packet])-recvPacket handle = do- hdr <- lift $ B.hGet handle 5 >>= return . decodeHeader- case hdr of- Left err -> return $ Left err- Right header@(Header _ _ readlen) -> do- content <- lift $ B.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 $ B.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"--handshakeSendServerData :: Handle -> TLSServer IO ()-handshakeSendServerData handle = do- srand <- fromJust . serverRandom <$> withTLSRNG (\rng -> getRandomBytes rng 32)- 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 = PrivRSA $ RSA.PrivateKey- { RSA.private_sz = fromIntegral $ KeyRSA.lenmodulus privkeycert- , RSA.private_n = KeyRSA.modulus privkeycert- , RSA.private_d = KeyRSA.private_exponant privkeycert- , RSA.private_p = KeyRSA.p1 privkeycert- , RSA.private_q = KeyRSA.p2 privkeycert- , RSA.private_dP = KeyRSA.exp1 privkeycert- , RSA.private_dQ = KeyRSA.exp2 privkeycert- , RSA.private_qinv = KeyRSA.coef 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 Anonymous 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 $ B.unpack cf)--{- after receiving a client hello, we need to redo a handshake -}-handshake :: Handle -> TLSServer IO ()-handshake handle = do- handshakeSendServerData handle- lift $ hFlush handle-- whileStatus (/= (StatusHandshake HsStatusClientFinished)) (recvPacket handle)-- sendPacket handle ChangeCipherSpec- handshakeSendFinish handle-- lift $ hFlush handle-- return ()--{- | listen on a handle to a new TLS connection. -}-listen :: Handle -> TLSServer IO ()-listen handle = do- pkts <- recvPacket handle- case pkts of- Right [Handshake hs] -> handleClientHello hs- x -> fail ("unexpected type received. expecting handshake ++ " ++ show x)- handshake handle--sendDataChunk :: Handle -> B.ByteString -> TLSServer IO ()-sendDataChunk handle d =- if B.length d > 16384- then do- let (sending, remain) = B.splitAt 16384 d- sendPacket handle $ AppData sending- sendDataChunk handle remain- else- sendPacket handle $ AppData d--{- | sendData sends a bunch of data -}-sendData :: Handle -> L.ByteString -> TLSServer IO ()-sendData handle d = mapM_ (sendDataChunk handle) (L.toChunks 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 _ _ _ _ _ _)] -> handshake handle >> recvData handle- Right [AppData x] -> return $ L.fromChunks [x]- Left err -> error ("error received: " ++ show err)- _ -> error "unexpected item"--{- | close a TLS connection.- - note that it doesn't close the handle, but just signal we're going to close- - the connection to the other side -}-close :: Handle -> TLSServer IO ()-close handle = do- sendPacket handle $ Alert (AlertLevel_Warning, CloseNotify)
Network/TLS/State.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, MultiParamTypeClasses #-} -- | -- Module : Network.TLS.State -- License : BSD-style@@ -10,18 +11,18 @@ -- module Network.TLS.State ( TLSState(..)+ , TLSSt+ , runTLSState , TLSHandshakeState(..) , TLSCryptState(..) , TLSMacState(..) , TLSStatus(..) , HandshakeStatus(..)- , MonadTLSState, getTLSState, putTLSState, modifyTLSState , newTLSState , withTLSRNG , assert -- FIXME move somewhere else (Internal.hs ?) , updateStatusHs , updateStatusCC- , whileStatus , finishHandshakeTypeMaterial , finishHandshakeMaterial , makeDigest@@ -55,6 +56,8 @@ import Network.TLS.MAC import qualified Data.ByteString as B import Control.Monad+import Control.Monad.State+import Control.Monad.Error assert :: Monad m => String -> [(String,Bool)] -> m () assert fctname list = forM_ list $ \ (name, assumption) -> do@@ -117,10 +120,19 @@ , stRandomGen :: SRandomGen } deriving (Show) -class (Monad m) => MonadTLSState m where- getTLSState :: m TLSState- putTLSState :: TLSState -> m ()+newtype TLSSt a = TLSSt { runTLSSt :: ErrorT TLSError (State TLSState) a }+ deriving (Monad, MonadError TLSError) +instance Functor TLSSt where+ fmap f = TLSSt . fmap f . runTLSSt++instance MonadState TLSState TLSSt where+ put x = TLSSt (lift $ put x)+ get = TLSSt (lift get)++runTLSState :: TLSSt a -> TLSState -> (Either TLSError a, TLSState)+runTLSState f st = runState (runErrorT (runTLSSt f)) st+ newTLSState :: SRandomGen -> TLSState newTLSState rng = TLSState { stClientContext = False@@ -137,19 +149,16 @@ , stRandomGen = rng } -modifyTLSState :: (MonadTLSState m) => (TLSState -> TLSState) -> m ()-modifyTLSState f = getTLSState >>= \st -> putTLSState (f st)--withTLSRNG :: MonadTLSState m => (SRandomGen -> (a, SRandomGen)) -> m a+withTLSRNG :: MonadState TLSState m => (SRandomGen -> (a, SRandomGen)) -> m a withTLSRNG f = do- st <- getTLSState+ st <- get let (a, newrng) = f (stRandomGen st)- putTLSState (st { stRandomGen = newrng })+ put (st { stRandomGen = newrng }) return a -makeDigest :: (MonadTLSState m) => Bool -> Header -> Bytes -> m Bytes+makeDigest :: MonadState TLSState m => Bool -> Header -> Bytes -> m Bytes makeDigest w hdr content = do- st <- getTLSState+ st <- get let ver = stVersion st let cst = fromJust "crypt state" $ if w then stTxCryptState st else stRxCryptState st let ms = fromJust "mac state" $ if w then stTxMacState st else stRxMacState st@@ -164,7 +173,7 @@ let newms = ms { msSequence = (msSequence ms) + 1 } - modifyTLSState (\_ -> if w then st { stTxMacState = Just newms } else st { stRxMacState = Just newms })+ modify (\_ -> if w then st { stTxMacState = Just newms } else st { stRxMacState = Just newms }) return digest hsStatusTransitionTable :: [ (HandshakeType, TLSStatus, [ TLSStatus ]) ]@@ -202,18 +211,13 @@ [ StatusHandshake HsStatusServerChangeCipher ]) ] -whileStatus :: (MonadTLSState m, Monad m) => (TLSStatus -> Bool) -> m a -> m ()-whileStatus p a = do- currentStatus <- getTLSState >>= return . stStatus- when (p currentStatus) (a >> whileStatus p a)--updateStatus :: MonadTLSState m => TLSStatus -> m ()-updateStatus x = modifyTLSState (\st -> st { stStatus = x })+updateStatus :: MonadState TLSState m => TLSStatus -> m ()+updateStatus x = modify (\st -> st { stStatus = x }) -updateStatusHs :: MonadTLSState m => HandshakeType -> m (Maybe TLSError)+updateStatusHs :: MonadState TLSState m => HandshakeType -> m (Maybe TLSError) updateStatusHs ty = do- status <- return . stStatus =<< getTLSState- ns <- return . transition . stStatus =<< getTLSState+ status <- return . stStatus =<< get+ ns <- return . transition . stStatus =<< get case ns of Nothing -> return $ Just $ Error_Packet_unexpected (show status) ("handshake:" ++ show ty) Just (_,x,_) -> updateStatus x >> return Nothing@@ -221,9 +225,9 @@ edgeEq cur (ety, _, aprevs) = ty == ety && (maybe False (const True) $ find (== cur) aprevs) transition currentStatus = find (edgeEq currentStatus) hsStatusTransitionTable -updateStatusCC :: MonadTLSState m => Bool -> m (Maybe TLSError)+updateStatusCC :: MonadState TLSState m => Bool -> m (Maybe TLSError) updateStatusCC sending = do- status <- return . stStatus =<< getTLSState+ status <- return . stStatus =<< get cc <- isClientContext let x = case (cc /= sending, status) of (False, StatusHandshake HsStatusClientKeyXchg) -> Just (StatusHandshake HsStatusClientChangeCipher)@@ -249,18 +253,16 @@ 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 })+switchTxEncryption, switchRxEncryption :: MonadState TLSState m => m ()+switchTxEncryption = modify (\st -> st { stTxEncrypted = True })+switchRxEncryption = modify (\st -> st { stRxEncrypted = True }) -setServerRandom :: MonadTLSState m => ServerRandom -> m ()+setServerRandom :: MonadState TLSState m => ServerRandom -> m () setServerRandom ran = updateHandshake "srand" (\hst -> hst { hstServerRandom = Just ran }) -setMasterSecret :: MonadTLSState m => Bytes -> m ()+setMasterSecret :: MonadState TLSState m => Bytes -> m () setMasterSecret premastersecret = do- st <- getTLSState+ st <- get hasValidHandshake "master secret" updateHandshake "master secret" (\hst ->@@ -268,15 +270,15 @@ hst { hstMasterSecret = Just ms } ) return () -setPublicKey :: MonadTLSState m => PublicKey -> m ()+setPublicKey :: MonadState TLSState m => PublicKey -> m () setPublicKey pk = updateHandshake "publickey" (\hst -> hst { hstRSAPublicKey = Just pk }) -setPrivateKey :: MonadTLSState m => PrivateKey -> m ()+setPrivateKey :: MonadState TLSState m => PrivateKey -> m () setPrivateKey pk = updateHandshake "privatekey" (\hst -> hst { hstRSAPrivateKey = Just pk }) -setKeyBlock :: MonadTLSState m => m ()+setKeyBlock :: MonadState TLSState m => m () setKeyBlock = do- st <- getTLSState+ st <- get let hst = fromJust "handshake" $ stHandshake st @@ -303,21 +305,21 @@ , cstMacSecret = sMACSecret } let msClient = TLSMacState { msSequence = 0 } let msServer = TLSMacState { msSequence = 0 }- putTLSState $ st+ put $ 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 = modifyTLSState (\st -> st { stCipher = Just cipher })+setCipher :: MonadState TLSState m => Cipher -> m ()+setCipher cipher = modify (\st -> st { stCipher = Just cipher }) -setVersion :: MonadTLSState m => Version -> m ()-setVersion ver = modifyTLSState (\st -> st { stVersion = ver })+setVersion :: MonadState TLSState m => Version -> m ()+setVersion ver = modify (\st -> st { stVersion = ver }) -isClientContext :: MonadTLSState m => m Bool-isClientContext = getTLSState >>= return . stClientContext+isClientContext :: MonadState TLSState m => m Bool+isClientContext = get >>= return . stClientContext -- create a new empty handshake state newEmptyHandshake :: Version -> ClientRandom -> TLSHandshakeState@@ -331,22 +333,22 @@ , hstHandshakeDigest = Nothing } -startHandshakeClient :: MonadTLSState m => Version -> ClientRandom -> m ()+startHandshakeClient :: MonadState TLSState m => Version -> ClientRandom -> m () startHandshakeClient ver crand = do -- FIXME check if handshake is already not null- chs <- getTLSState >>= return . stHandshake+ chs <- get >>= return . stHandshake when (isNothing chs) $- modifyTLSState (\st -> st { stHandshake = Just $ newEmptyHandshake ver crand })+ modify (\st -> st { stHandshake = Just $ newEmptyHandshake ver crand }) -hasValidHandshake :: MonadTLSState m => String -> m ()-hasValidHandshake name = getTLSState >>= \st -> assert name [ ("valid handshake", isNothing $ stHandshake st) ]+hasValidHandshake :: MonadState TLSState m => String -> m ()+hasValidHandshake name = get >>= \st -> assert name [ ("valid handshake", isNothing $ stHandshake st) ] -updateHandshake :: MonadTLSState m => String -> (TLSHandshakeState -> TLSHandshakeState) -> m ()+updateHandshake :: MonadState TLSState m => String -> (TLSHandshakeState -> TLSHandshakeState) -> m () updateHandshake n f = do hasValidHandshake n- modifyTLSState (\st -> st { stHandshake = maybe Nothing (Just . f) (stHandshake st) })+ modify (\st -> st { stHandshake = maybe Nothing (Just . f) (stHandshake st) }) -updateHandshakeDigest :: MonadTLSState m => Bytes -> m ()+updateHandshakeDigest :: MonadState TLSState m => Bytes -> m () updateHandshakeDigest content = updateHandshake "update digest" (\hs -> let (c1, c2) = case hstHandshakeDigest hs of Nothing -> (initHash HashTypeSHA1, initHash HashTypeMD5)@@ -356,18 +358,18 @@ hs { hstHandshakeDigest = Just (nc1, nc2) } ) -updateHandshakeDigestSplitted :: MonadTLSState m => HandshakeType -> Bytes -> m ()+updateHandshakeDigestSplitted :: MonadState TLSState m => HandshakeType -> Bytes -> m () updateHandshakeDigestSplitted ty bytes = updateHandshakeDigest $ B.concat [hdr, bytes] where hdr = runPut $ encodeHandshakeHeader ty (B.length bytes) -getHandshakeDigest :: MonadTLSState m => Bool -> m Bytes+getHandshakeDigest :: MonadState TLSState m => Bool -> m Bytes getHandshakeDigest client = do- st <- getTLSState+ st <- get let hst = fromJust "handshake" $ stHandshake st let (sha1ctx, md5ctx) = fromJust "handshake digest" $ hstHandshakeDigest hst let msecret = fromJust "master secret" $ hstMasterSecret hst return $ (if client then generateClientFinished else generateServerFinished) (stVersion st) msecret md5ctx sha1ctx -endHandshake :: MonadTLSState m => m ()-endHandshake = modifyTLSState (\st -> st { stHandshake = Nothing })+endHandshake :: MonadState TLSState m => m ()+endHandshake = modify (\st -> st { stHandshake = Nothing })
Network/TLS/Struct.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_HADDOCK hide #-} -- | -- Module : Network.TLS.Struct -- License : BSD-style@@ -50,6 +51,11 @@ type Bytes = ByteString +-- | Versions known to TLS+--+-- SSL2 is just defined, but this version is and will not be supported.+--+-- TLS12 is not yet supported data Version = SSL2 | SSL3 | TLS10 | TLS11 | TLS12 deriving (Show, Eq, Ord) data ConnectionEnd = ConnectionServer | ConnectionClient@@ -98,6 +104,7 @@ | ProtocolType_AppData deriving (Eq, Show) +-- | TLSError that might be returned through the TLS stack data TLSError = Error_Misc String | Error_Certificate String
Stunnel.hs view
@@ -11,20 +11,15 @@ import Control.Concurrent (forkIO) import Control.Exception (finally, try, throw) import Control.Monad (when, forever)-import Control.Monad.Trans (lift) import Data.Char (isDigit) import Data.Certificate.PEM import Data.Certificate.X509 import qualified Data.Certificate.KeyRSA as KeyRSA--import Network.TLS.Cipher-import Network.TLS.SRandom-import Network.TLS.Struct+import qualified Crypto.Cipher.RSA as RSA -import qualified Network.TLS.Client as C-import qualified Network.TLS.Server as S+import Network.TLS ciphers :: [Cipher] ciphers =@@ -44,22 +39,21 @@ Right True -> B.hGetNonBlocking h 4096 Right False -> return B.empty -tlsclient :: Handle -> Handle -> C.TLSClient IO ()+tlsclient :: Handle -> TLSCtx -> IO () tlsclient srchandle dsthandle = do- lift $ hSetBuffering dsthandle NoBuffering- lift $ hSetBuffering srchandle NoBuffering+ hSetBuffering srchandle NoBuffering - C.initiate dsthandle+ handshake dsthandle loopUntil $ do- b <- lift $ readOne srchandle- lift $ putStrLn ("sending " ++ show b)+ b <- readOne srchandle+ putStrLn ("sending " ++ show b) if B.null b then do- C.close dsthandle+ bye dsthandle return True else do- C.sendData dsthandle (L.fromChunks [b])+ sendData dsthandle (L.fromChunks [b]) return False return () @@ -67,35 +61,31 @@ getRandomGen = makeSRandomGen >>= either (fail . show) (return . id) tlsserver srchandle dsthandle = do- lift $ hSetBuffering dsthandle NoBuffering- lift $ hSetBuffering srchandle NoBuffering+ hSetBuffering dsthandle NoBuffering - S.listen srchandle+ handshake srchandle loopUntil $ do- d <- S.recvData srchandle- lift $ putStrLn ("received: " ++ show d)- S.sendData srchandle (L.pack $ map (toEnum . fromEnum) "this is some data")- lift $ hFlush srchandle+ d <- recvData srchandle+ putStrLn ("received: " ++ show d)+ sendData srchandle (L.pack $ map (toEnum . fromEnum) "this is some data")+ hFlush (ctxHandle srchandle) return False- lift $ putStrLn "end"+ putStrLn "end" -clientProcess ((certdata, cert), pk) handle dsthandle _ = do+clientProcess certs handle dsthandle _ = do rng <- getRandomGen - let serverstate = S.TLSServerParams- { S.spAllowedVersions = [SSL3,TLS10,TLS11]- , S.spSessions = []- , S.spCiphers = ciphers- , S.spCertificate = Just (certdata, cert, pk)- , S.spWantClientCert = False- , S.spCallbacks = S.TLSServerCallbacks- { S.cbCertificates = Nothing }+ let serverstate = defaultParams+ { pAllowedVersions = [SSL3,TLS10,TLS11]+ , pCiphers = ciphers+ , pCertificates = certs+ , pWantClientCert = False }-- S.runTLSServer (tlsserver handle dsthandle) serverstate rng+ ctx <- server serverstate rng handle+ tlsserver ctx dsthandle -readCertificate :: FilePath -> IO (B.ByteString, X509)+readCertificate :: FilePath -> IO X509 readCertificate filepath = do content <- B.readFile filepath let certdata = case parsePEMCert content of@@ -104,9 +94,9 @@ let cert = case decodeCertificate $ L.fromChunks [certdata] of Left err -> error ("cannot decode certificate: " ++ err) Right x -> x- return (certdata, cert)+ return cert -readPrivateKey :: FilePath -> IO (L.ByteString, KeyRSA.Private)+readPrivateKey :: FilePath -> IO PrivateKey readPrivateKey filepath = do content <- B.readFile filepath let pkdata = case parsePEMKeyRSA content of@@ -114,8 +104,17 @@ Just x -> L.fromChunks [x] let pk = case KeyRSA.decodePrivate pkdata of Left err -> error ("cannot decode key: " ++ err)- Right x -> x- return (pkdata, pk)+ Right x -> PrivRSA $ RSA.PrivateKey+ { RSA.private_sz = fromIntegral $ KeyRSA.lenmodulus x+ , RSA.private_n = KeyRSA.modulus x+ , RSA.private_d = KeyRSA.private_exponant x+ , RSA.private_p = KeyRSA.p1 x+ , RSA.private_q = KeyRSA.p2 x+ , RSA.private_dP = KeyRSA.exp1 x+ , RSA.private_dQ = KeyRSA.exp2 x+ , RSA.private_qinv = KeyRSA.coef x+ }+ return pk data Stunnel = Client@@ -204,15 +203,11 @@ srcaddr <- getAddressDescription (sourceType pargs) (source pargs) dstaddr <- getAddressDescription (destinationType pargs) (destination pargs) - let clientstate = C.TLSClientParams- { C.cpConnectVersion = TLS10- , C.cpAllowedVersions = [ TLS10, TLS11 ]- , C.cpSession = Nothing- , C.cpCiphers = ciphers- , C.cpCertificate = Nothing- , C.cpCallbacks = C.TLSClientCallbacks- { C.cbCertificates = Nothing- }+ let clientstate = defaultParams+ { pConnectVersion = TLS10+ , pAllowedVersions = [ TLS10, TLS11 ]+ , pCiphers = ciphers+ , pCertificates = [] } case srcaddr of@@ -226,8 +221,9 @@ (StunnelSocket dst) <- connectAddressDescription dstaddr dsth <- socketToHandle dst ReadWriteMode+ dstctx <- client clientstate rng dsth _ <- forkIO $ finally- (C.runTLSClient (tlsclient srch dsth) clientstate rng >> return ())+ (tlsclient srch dstctx) (hClose srch >> hClose dsth) return () AddrFD _ _ -> error "bad error fd. not implemented"@@ -248,7 +244,7 @@ (StunnelSocket dst) <- connectAddressDescription dstaddr dsth <- socketToHandle dst ReadWriteMode _ <- forkIO $ finally- (clientProcess (cert, snd pk) srch dsth addr >> return ())+ (clientProcess [(cert, Just pk)] srch dsth addr >> return ()) (hClose srch >> hClose dsth) return () AddrFD _ _ -> error "bad error fd. not implemented"
tls.cabal view
@@ -1,5 +1,5 @@ Name: tls-Version: 0.3.3+Version: 0.4.0 Description: native TLS protocol implementation, focusing on purity and more type-checking. .@@ -40,14 +40,14 @@ , crypto-api >= 0.5 , cryptocipher >= 0.2.5 , certificate >= 0.7 && < 0.8- Exposed-modules: Network.TLS.Client- Network.TLS.Server- Network.TLS.Struct+ Exposed-modules: Network.TLS Network.TLS.Cipher+ Network.TLS.Compression+ other-modules: Network.TLS.Cap Network.TLS.SRandom+ Network.TLS.Struct Network.TLS.MAC- other-modules: Network.TLS.Cap- Network.TLS.Compression+ Network.TLS.Core Network.TLS.Crypto Network.TLS.Packet Network.TLS.State