tls 0.8.5 → 0.9.0
raw patch · 7 files changed
+135/−81 lines, 7 filesdep ~certificate
Dependency ranges changed: certificate
Files
- Network/TLS.hs +4/−0
- Network/TLS/Context.hs +12/−1
- Network/TLS/Core.hs +61/−25
- Network/TLS/Packet.hs +16/−31
- Network/TLS/Wire.hs +25/−0
- Tests.hs +14/−21
- tls.cabal +3/−3
Network/TLS.hs view
@@ -30,6 +30,7 @@ -- * High level API , sendData , recvData+ , recvData' -- * Crypto Key , PrivateKey(..)@@ -44,6 +45,9 @@ , Version(..) -- * Errors , TLSError(..)+ -- * Exceptions+ , HandshakeFailed(..)+ , ConnectionNotEstablished(..) ) where import Network.TLS.Struct (Version(..), TLSError(..))
Network/TLS/Context.hs view
@@ -22,8 +22,10 @@ , ctxParams , ctxConnection , ctxEOF+ , ctxEstablished , ctxLogging , setEOF+ , setEstablished , connectionFlush , connectionSend , connectionRecv@@ -142,7 +144,8 @@ , ctxParams :: TLSParams , ctxState :: MVar TLSState , ctxMeasurement :: IORef Measurement- , ctxEOF_ :: IORef Bool -- ^ is the handle has EOFed or not.+ , ctxEOF_ :: IORef Bool -- ^ has the handle EOFed or not.+ , ctxEstablished_ :: IORef Bool -- ^ has the handshake been done and been successful. , ctxConnectionFlush :: IO () , ctxConnectionSend :: Bytes -> IO () , ctxConnectionRecv :: Int -> IO Bytes@@ -169,6 +172,12 @@ setEOF :: MonadIO m => TLSCtx c -> m () setEOF ctx = liftIO $ writeIORef (ctxEOF_ ctx) True +ctxEstablished :: MonadIO m => TLSCtx a -> m Bool+ctxEstablished ctx = liftIO $ readIORef $ ctxEstablished_ ctx++setEstablished :: MonadIO m => TLSCtx c -> Bool -> m ()+setEstablished ctx v = liftIO $ writeIORef (ctxEstablished_ ctx) v+ ctxLogging :: TLSCtx a -> TLSLogging ctxLogging = pLogging . ctxParams @@ -176,6 +185,7 @@ newCtxWith c flushF sendF recvF params st = do stvar <- newMVar st eof <- newIORef False+ established <- newIORef False stats <- newIORef newMeasurement return $ TLSCtx { ctxConnection = c@@ -183,6 +193,7 @@ , ctxState = stvar , ctxMeasurement = stats , ctxEOF_ = eof+ , ctxEstablished_ = established , ctxConnectionFlush = flushF , ctxConnectionSend = sendF , ctxConnectionRecv = recvF
Network/TLS/Core.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE DeriveDataTypeable #-} -- | -- Module : Network.TLS.Core -- License : BSD-style@@ -21,10 +22,13 @@ -- * Initialisation and Termination of context , bye , handshake+ , HandshakeFailed(..)+ , ConnectionNotEstablished(..) -- * High level API , sendData , recvData+ , recvData' ) where import Network.TLS.Context@@ -39,6 +43,7 @@ import Network.TLS.Measurement import Network.TLS.Wire (encodeWord16) import Data.Maybe+import Data.Data import Data.List (intersect, find) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L@@ -51,10 +56,29 @@ import System.IO.Error (mkIOError, eofErrorType) import Prelude hiding (catch) +data HandshakeFailed = HandshakeFailed TLSError+ deriving (Show,Eq,Typeable)++data ConnectionNotEstablished = ConnectionNotEstablished+ deriving (Show,Eq,Typeable)++instance Exception HandshakeFailed+instance Exception ConnectionNotEstablished+ errorToAlert :: TLSError -> Packet errorToAlert (Error_Protocol (_, _, ad)) = Alert [(AlertLevel_Fatal, ad)] errorToAlert _ = Alert [(AlertLevel_Fatal, InternalError)] +handshakeFailed :: TLSError -> IO ()+handshakeFailed err = throwIO $ HandshakeFailed err++checkValid :: MonadIO m => TLSCtx c -> m ()+checkValid ctx = do+ established <- ctxEstablished ctx+ unless established $ liftIO $ throwIO ConnectionNotEstablished+ eofed <- ctxEOF ctx+ when eofed $ liftIO $ throwIO $ mkIOError eofErrorType "data" Nothing Nothing+ readExact :: MonadIO m => TLSCtx c -> Int -> m Bytes readExact ctx sz = do hdrbs <- liftIO $ connectionRecv ctx sz@@ -149,14 +173,25 @@ liftIO $ connectionSend ctx dataToSend -- | Create a new Client context with a configuration, a RNG, a generic connection and the connection operation.-clientWith :: (MonadIO m, CryptoRandomGen g) => TLSParams -> g -> c -> IO () -> (Bytes -> IO ()) -> (Int -> IO Bytes) -> m (TLSCtx c)+clientWith :: (MonadIO m, CryptoRandomGen g)+ => TLSParams -- ^ Parameters to use for this context+ -> g -- ^ Random number generator associated+ -> c -- ^ An abstract connection type+ -> IO () -- ^ A method for the connection buffer to be flushed+ -> (Bytes -> IO ()) -- ^ A method for sending bytes through the connection+ -> (Int -> IO Bytes) -- ^ A method for receiving bytes through the connection+ -> m (TLSCtx c) clientWith params rng connection flushF sendF recvF = liftIO $ newCtxWith connection flushF sendF recvF params st where st = (newTLSState rng) { stClientContext = True } -- | Create a new Client context with a configuration, a RNG, and a Handle. -- It reconfigures the handle buffermode to noBuffering-client :: (MonadIO m, CryptoRandomGen g) => TLSParams -> g -> Handle -> m (TLSCtx Handle)+client :: (MonadIO m, CryptoRandomGen g)+ => TLSParams -- ^ parameters to use for this context+ -> g -- ^ random number generator associated with the context+ -> Handle -- ^ handle to use+ -> m (TLSCtx Handle) client params rng handle = liftIO $ newCtx handle params st where st = (newTLSState rng) { stClientContext = True } @@ -193,6 +228,8 @@ -- forget all handshake data now and reset bytes counters. usingState_ ctx endHandshake updateMeasure ctx resetBytesCounters+ -- mark the secure connection up and running.+ setEstablished ctx True return () -- client part of handshake. send a bunch of handshake of client@@ -441,38 +478,34 @@ -- | Handshake for a new TLS connection -- This is to be called at the beginning of a connection, and during renegociation-handshake :: MonadIO m => TLSCtx c -> m Bool+handshake :: MonadIO m => TLSCtx c -> m () handshake ctx = do cc <- usingState_ ctx (stClientContext <$> get) liftIO $ handleException $ if cc then handshakeClient ctx else handshakeServer ctx where- handleException f = catch (f >> return True) (\e -> handler e >> return False)- handler e = case fromException e of- Just err -> sendPacket ctx (errorToAlert err)- Nothing -> sendPacket ctx (errorToAlert $ Error_Misc $ show e)+ handleException f = catch f $ \exception -> do+ let tlserror = maybe (Error_Misc $ show exception) id $ fromException exception+ setEstablished ctx False+ sendPacket ctx (errorToAlert tlserror)+ handshakeFailed tlserror -- | sendData sends a bunch of data. -- It will automatically chunk data to acceptable packet size sendData :: MonadIO m => TLSCtx c -> L.ByteString -> m ()-sendData ctx dataToSend = do- eofed <- ctxEOF ctx- when eofed $ liftIO $ throwIO $ mkIOError eofErrorType "sendData" Nothing Nothing- 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+sendData ctx dataToSend = checkValid ctx >> mapM_ sendDataChunk (L.toChunks dataToSend)+ where sendDataChunk d+ | B.length d > 16384 = do+ let (sending, remain) = B.splitAt 16384 d+ sendPacket ctx $ AppData sending+ sendDataChunk remain+ | otherwise = sendPacket ctx $ AppData d -- | recvData get data out of Data packet, and automatically renegociate if -- a Handshake ClientHello is received-recvData :: MonadIO m => TLSCtx c -> m L.ByteString+recvData :: MonadIO m => TLSCtx c -> m Bytes recvData ctx = do- eofed <- ctxEOF ctx- when eofed $ liftIO $ throwIO $ mkIOError eofErrorType "recvData" Nothing Nothing- pkt <- recvPacket ctx+ checkValid ctx+ pkt <- recvPacket ctx case pkt of -- on server context receiving a client hello == renegociation Right (Handshake [ch@(ClientHello _ _ _ _ _ _)]) ->@@ -482,10 +515,13 @@ handshakeClient ctx >> recvData ctx Right (Alert [(AlertLevel_Fatal, _)]) -> do setEOF ctx- return L.empty+ return B.empty Right (Alert [(AlertLevel_Warning, CloseNotify)]) -> do setEOF ctx- return L.empty- Right (AppData x) -> return $ L.fromChunks [x]+ return B.empty+ Right (AppData x) -> return x Right p -> error ("error unexpected packet: " ++ show p) Left err -> error ("error received: " ++ show err)++recvData' :: MonadIO m => TLSCtx c -> m L.ByteString+recvData' ctx = recvData ctx >>= return . L.fromChunks . (:[])
Network/TLS/Packet.hs view
@@ -57,7 +57,7 @@ import Data.Bits ((.|.)) import Control.Applicative ((<$>)) import Control.Monad-import Data.Certificate.X509+import Data.Certificate.X509 (decodeCertificate, encodeCertificate, X509) import Network.TLS.Crypto import Network.TLS.MAC import Network.TLS.Cipher (CipherKeyExchangeType(..))@@ -149,8 +149,7 @@ decodeHandshakeHeader :: Get (HandshakeType, Bytes) decodeHandshakeHeader = do ty <- getHandshakeType- len <- getWord24- content <- getBytes len+ content <- getOpaque24 return (ty, content) decodeHandshakes :: ByteString -> Either TLSError [(HandshakeType, Bytes)]@@ -216,9 +215,7 @@ else return $ Certificates r decodeFinished :: Get Handshake-decodeFinished = do- opaque <- remaining >>= getBytes- return $ Finished $ opaque+decodeFinished = Finished <$> (remaining >>= getBytes) getSignatureHashAlgorithm :: Get (HashAlgorithm, SignatureAlgorithm) getSignatureHashAlgorithm = do@@ -257,15 +254,15 @@ decodeServerKeyXchg_DH :: Get ServerDHParams decodeServerKeyXchg_DH = do- p <- getWord16 >>= getBytes . fromIntegral- g <- getWord16 >>= getBytes . fromIntegral- y <- getWord16 >>= getBytes . fromIntegral+ p <- getOpaque16+ g <- getOpaque16+ y <- getOpaque16 return $ ServerDHParams { dh_p = os2ip p, dh_g = os2ip g, dh_Ys = os2ip y } decodeServerKeyXchg_RSA :: Get ServerRSAParams decodeServerKeyXchg_RSA = do- modulus <- getWord16 >>= getBytes . fromIntegral- expo <- getWord16 >>= getBytes . fromIntegral+ modulus <- getOpaque16+ expo <- getOpaque16 return $ ServerRSAParams { rsa_modulus = os2ip modulus, rsa_exponent = os2ip expo } decodeServerKeyXchg :: CurrentParams -> Get Handshake@@ -274,11 +271,11 @@ CipherKeyExchange_DH_Anon -> SKX_DH_Anon <$> decodeServerKeyXchg_DH CipherKeyExchange_DHE_RSA -> do dhparams <- decodeServerKeyXchg_DH- signature <- getWord16 >>= getBytes . fromIntegral+ signature <- getOpaque16 return $ SKX_DHE_RSA dhparams (B.unpack signature) CipherKeyExchange_DHE_DSS -> do dhparams <- decodeServerKeyXchg_DH- signature <- getWord16 >>= getBytes . fromIntegral+ signature <- getOpaque16 return $ SKX_DHE_DSS dhparams (B.unpack signature) _ -> do bs <- remaining >>= getBytes@@ -313,11 +310,7 @@ >> putWord16 cipherID >> putWord8 compressionID >> putExtensions exts >> return () -encodeHandshakeContent (Certificates certs) =- putWord24 len >> putBytes certbs- where- certbs = runPut $ mapM_ putCert certs- len = fromIntegral $ B.length certbs+encodeHandshakeContent (Certificates certs) = putOpaque24 (runPut $ mapM_ putCert certs) encodeHandshakeContent (ClientKeyXchg content) = do putBytes content@@ -368,7 +361,7 @@ putSession :: Session -> Put putSession (Session Nothing) = putWord8 0-putSession (Session (Just s)) = putWord8 (fromIntegral $ B.length s) >> putBytes s+putSession (Session (Just s)) = putOpaque8 s getCerts :: Int -> Get [Bytes] getCerts 0 = return []@@ -379,8 +372,7 @@ return (cert : certxs) putCert :: X509 -> Put-putCert cert = putWord24 (fromIntegral $ B.length content) >> putBytes content- where content = B.concat $ L.toChunks $ encodeCertificate cert+putCert cert = putOpaque24 (B.concat $ L.toChunks $ encodeCertificate cert) getExtensions :: Int -> Get [Extension] getExtensions 0 = return []@@ -392,16 +384,11 @@ return $ (extty, extdata) : extxs putExtension :: Extension -> Put-putExtension (ty, l) = do- putWord16 ty- putWord16 (fromIntegral $ B.length l)- putBytes l+putExtension (ty, l) = putWord16 ty >> putOpaque16 l putExtensions :: [Extension] -> Put putExtensions [] = return ()-putExtensions es = putWord16 (fromIntegral $ B.length extbs) >> putBytes extbs- where- extbs = runPut $ mapM_ putExtension es+putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) {- - decode and encode ALERT@@ -432,9 +419,7 @@ encodeExtSecureRenegotiation :: Bytes -> Maybe Bytes -> Bytes encodeExtSecureRenegotiation cvd msvd = runPut $ do let svd = maybe B.empty id msvd- putWord8 $ fromIntegral (B.length cvd + B.length svd)- putBytes cvd- putBytes svd+ putOpaque8 (cvd `B.append` svd) -- rsa pre master secret decodePreMasterSecret :: Bytes -> Either TLSError (Version, Bytes)
Network/TLS/Wire.hs view
@@ -18,6 +18,9 @@ , getWords16 , getWord24 , getBytes+ , getOpaque8+ , getOpaque16+ , getOpaque24 , processBytes , isEmpty , Put@@ -28,6 +31,9 @@ , putWords16 , putWord24 , putBytes+ , putOpaque8+ , putOpaque16+ , putOpaque24 , encodeWord16 , encodeWord64 ) where@@ -37,6 +43,7 @@ import Data.Serialize.Put import Control.Applicative ((<$>)) import Control.Monad.Error+import qualified Data.ByteString as B import Data.Word import Data.Bits import Network.TLS.Struct@@ -60,6 +67,15 @@ c <- fromIntegral <$> getWord8 return $ (a `shiftL` 16) .|. (b `shiftL` 8) .|. c +getOpaque8 :: Get Bytes+getOpaque8 = getWord8 >>= getBytes . fromIntegral++getOpaque16 :: Get Bytes+getOpaque16 = getWord16 >>= getBytes . fromIntegral++getOpaque24 :: Get Bytes+getOpaque24 = getWord24 >>= getBytes+ processBytes :: Int -> Get a -> Get a processBytes i f = isolate i f @@ -85,6 +101,15 @@ putBytes :: Bytes -> Put putBytes = putByteString++putOpaque8 :: Bytes -> Put+putOpaque8 b = putWord8 (fromIntegral $ B.length b) >> putBytes b++putOpaque16 :: Bytes -> Put+putOpaque16 b = putWord16 (fromIntegral $ B.length b) >> putBytes b++putOpaque24 :: Bytes -> Put+putOpaque24 b = putWord24 (B.length b) >> putBytes b encodeWord16 :: Word16 -> Bytes encodeWord16 = runPut . putWord16
Tests.hs view
@@ -170,14 +170,12 @@ return () where tlsServer ctx queue = do- hSuccess <- handshake ctx- unless hSuccess $ fail "handshake failed on server side"- d <- recvData ctx+ handshake ctx+ d <- recvData' ctx writeChan queue d return () tlsClient queue ctx = do- hSuccess <- handshake ctx- unless hSuccess $ fail "handshake failed on client side"+ handshake ctx d <- readChan queue sendData ctx d bye ctx@@ -199,16 +197,13 @@ return () where tlsServer ctx queue = do- hSuccess <- handshake ctx- unless hSuccess $ fail "handshake failed on server side"- d <- recvData ctx+ handshake ctx+ d <- recvData' ctx writeChan queue d return () tlsClient queue ctx = do- hSuccess <- handshake ctx- unless hSuccess $ fail "handshake failed on client side"- hSuccess2 <- handshake ctx- unless hSuccess2 $ fail "renegociation handshake failed"+ handshake ctx+ handshake ctx d <- readChan queue sendData ctx d bye ctx@@ -239,23 +234,21 @@ {- the test involves writing data on one side of the data "pipe" and - then checking we received them on the other side of the data "pipe" -}- d <- L.pack <$> pick (someWords8 256)- run $ writeChan startQueue d+ d2 <- L.pack <$> pick (someWords8 256)+ run $ writeChan startQueue d2 - dres <- run $ readChan resultQueue- d `assertEq` dres+ dres2 <- run $ readChan resultQueue+ d2 `assertEq` dres2 return () where tlsServer ctx queue = do- hSuccess <- handshake ctx- unless hSuccess $ fail "resumption failed on server side"- d <- recvData ctx+ handshake ctx+ d <- recvData' ctx writeChan queue d return () tlsClient queue ctx = do- hSuccess <- handshake ctx- unless hSuccess $ fail "resumption failed on client side"+ handshake ctx d <- readChan queue sendData ctx d bye ctx
tls.cabal view
@@ -1,5 +1,5 @@ Name: tls-Version: 0.8.5+Version: 0.9.0 Description: Native Haskell TLS and SSL protocol implementation for server and client. .@@ -42,7 +42,7 @@ , bytestring , crypto-api >= 0.5 , cryptocipher >= 0.3.0- , certificate >= 1.0.0 && < 1.1.0+ , certificate >= 1.1.0 && < 1.2.0 Exposed-modules: Network.TLS Network.TLS.Cipher Network.TLS.Compression@@ -80,7 +80,7 @@ , cryptocipher >= 0.3.0 else Buildable: False- ghc-options: -Wall -fhpc+ ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures -fhpc source-repository head type: git