Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Merge remote-tracking branch 'kolmodin/npn' into npn

  • Loading branch information...
commit 2a781dbc44f939754b68f5caee50ab9b2e98cd29 2 parents 81464e7 + 1bd53d9
@vincenthz vincenthz authored
View
3  Network/TLS.hs
@@ -27,6 +27,9 @@ module Network.TLS
, bye
, handshake
+ -- * Next Protocol Negotiation
+ , getNegotiatedProtocol
+
-- * High level API
, sendData
, recvData
View
3  Network/TLS/Context.hs
@@ -76,7 +76,6 @@ data TLSParams = TLSParams
, pWantClientCert :: Bool -- ^ request a certificate from client.
-- use by server only.
, pUseSecureRenegotiation :: Bool -- ^ notify that we want to use secure renegotation
- , pUseNextProtocolNegociation :: Bool -- ^ use draft Next Protocol Negociation extension.
, pUseSession :: Bool -- ^ generate new session if specified
, pCertificates :: [(X509, Maybe PrivateKey)] -- ^ the cert chain for this context with the associated keys if any.
, pLogging :: TLSLogging -- ^ callback for logging
@@ -85,6 +84,7 @@ data TLSParams = TLSParams
, onSessionResumption :: SessionID -> IO (Maybe SessionData) -- ^ callback to maybe resume session on server.
, onSessionEstablished :: SessionID -> SessionData -> IO () -- ^ callback when session have been established
, onSessionInvalidated :: SessionID -> IO () -- ^ callback when session is invalidated by error
+ , onSuggestNextProtocols :: IO (Maybe [B.ByteString]) -- ^ suggested next protocols accoring to the next protocol negotiation extension.
, sessionResumeWith :: Maybe (SessionID, SessionData) -- ^ try to establish a connection using this session.
}
@@ -112,6 +112,7 @@ defaultParams = TLSParams
, onSessionResumption = (\_ -> return Nothing)
, onSessionEstablished = (\_ _ -> return ())
, onSessionInvalidated = (\_ -> return ())
+ , onSuggestNextProtocols = return Nothing
, sessionResumeWith = Nothing
}
View
40 Network/TLS/Core.hs
@@ -1,5 +1,5 @@
{-# OPTIONS_HADDOCK hide #-}
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
-- |
-- Module : Network.TLS.Core
-- License : BSD-style
@@ -19,6 +19,9 @@ module Network.TLS.Core
, server
, serverWith
+ -- * Next Protocol Negotiation
+ , Network.TLS.Core.getNegotiatedProtocol
+
-- * Initialisation and Termination of context
, bye
, handshake
@@ -37,15 +40,16 @@ import Network.TLS.Record
import Network.TLS.Cipher
import Network.TLS.Compression
import Network.TLS.Packet
-import Network.TLS.State
+import Network.TLS.State as S
import Network.TLS.Sending
import Network.TLS.Receiving
import Network.TLS.Measurement
-import Network.TLS.Wire (encodeWord16)
+import Network.TLS.Wire (encodeWord16, encodeNPNAlternatives)
import Data.Maybe
import Data.Data
import Data.List (intersect, find)
import qualified Data.ByteString as B
+import Data.ByteString.Char8 ()
import qualified Data.ByteString.Lazy as L
import Crypto.Random
@@ -215,6 +219,11 @@ server params rng handle = liftIO $ newCtx handle params st
bye :: MonadIO m => TLSCtx c -> m ()
bye ctx = sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)]
+-- | If the Next Protocol Negotiation extension has been used, this will
+-- return get the protocol agreed upon.
+getNegotiatedProtocol :: MonadIO m => TLSCtx c -> m (Maybe B.ByteString)
+getNegotiatedProtocol ctx = usingState_ ctx S.getNegotiatedProtocol
+
-- | when a new handshake is done, wrap up & clean up.
handshakeTerminate :: MonadIO m => TLSCtx c -> m ()
handshakeTerminate ctx = do
@@ -359,7 +368,7 @@ handshakeClient ctx = do
throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown)
handshakeServerWith :: MonadIO m => TLSCtx c -> Handshake -> m ()
-handshakeServerWith ctx clientHello@(ClientHello ver _ clientSession ciphers compressions _) = do
+handshakeServerWith ctx clientHello@(ClientHello ver _ clientSession ciphers compressions exts) = do
-- check if policy allow this new handshake to happens
handshakeAuthorized <- withMeasure ctx (onHandshake $ ctxParams ctx)
unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied")
@@ -408,9 +417,10 @@ handshakeServerWith ctx clientHello@(ClientHello ver _ clientSession ciphers com
srvCerts = map fst $ pCertificates params
privKeys = map snd $ pCertificates params
needKeyXchg = cipherExchangeNeedMoreData $ cipherKeyExchange usedCipher
+ clientRequestedNPN = isJust $ lookup 13172 exts
---
- recvClientData = runRecvState ctx (RecvStateHandshake $ processClientCertificate)
+ recvClientData = runRecvState ctx (RecvStateHandshake processClientCertificate)
processClientCertificate (Certificates _) = return $ RecvStateHandshake processClientKeyExchange
processClientCertificate p = processClientKeyExchange p
@@ -421,11 +431,14 @@ handshakeServerWith ctx clientHello@(ClientHello ver _ clientSession ciphers com
processCertificateVerify (Handshake [CertVerify _]) = return $ RecvStateNext expectChangeCipher
processCertificateVerify p = expectChangeCipher p
- expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish
+ expectChangeCipher ChangeCipherSpec = do npn <- usingState_ ctx getExtensionNPN
+ return $ RecvStateHandshake $ if npn
+ then expectNPN
+ else expectFinish
expectChangeCipher p = unexpected (show p) (Just "change cipher")
- expectNPN (NextProtocolNegociation _) = return $ RecvStateHandshake expectFinish
- expectNPN p = unexpected (show p) (Just "Handshake NextProtocolNegociation")
+ expectNPN (NextProtocolNegotiation _) = return $ RecvStateHandshake expectFinish
+ expectNPN p = unexpected (show p) (Just "Handshake NextProtocolNegotiation")
expectFinish (Finished _) = return RecvStateDone
expectFinish p = unexpected (show p) (Just "Handshake Finished")
@@ -440,7 +453,7 @@ handshakeServerWith ctx clientHello@(ClientHello ver _ clientSession ciphers com
-- in TLS12, we need to check as well the certificates we are sending if they have in the extension
-- the necessary bits set.
secReneg <- usingState_ ctx getSecureRenegotiation
- extensions <- if secReneg
+ secRengExt <- if secReneg
then do
vf <- usingState_ ctx $ do
cvf <- getVerifiedData True
@@ -448,6 +461,15 @@ handshakeServerWith ctx clientHello@(ClientHello ver _ clientSession ciphers com
return $ encodeExtSecureRenegotiation cvf (Just svf)
return [ (0xff01, vf) ]
else return []
+ nextProtocols <-
+ if clientRequestedNPN
+ then liftIO $ onSuggestNextProtocols params
+ else return Nothing
+ npnExt <- case nextProtocols of
+ Just protos -> do usingState_ ctx $ setExtensionNPN True
+ return [ (13172, encodeNPNAlternatives protos) ]
+ Nothing -> return []
+ let extensions = secRengExt ++ npnExt
usingState_ ctx (setVersion ver >> setServerRandom srand)
return $ ServerHello ver srand session (cipherID usedCipher)
(compressionID usedCompression) extensions
View
12 Network/TLS/Packet.hs
@@ -72,7 +72,7 @@ import qualified Crypto.Hash.MD5 as MD5
data CurrentParams = CurrentParams
{ cParamsVersion :: Version -- ^ current protocol version
, cParamsKeyXchgType :: CipherKeyExchangeType -- ^ current key exchange type
- , cParamsSupportNPN :: Bool -- ^ support Next Protocol Negociation extension
+ , cParamsSupportNPN :: Bool -- ^ support Next Protocol Negotiation extension
} deriving (Show,Eq)
runGetErr :: String -> Get a -> ByteString -> Either TLSError a
@@ -176,7 +176,7 @@ decodeHandshake cp ty = runGetErr "handshake" $ case ty of
HandshakeType_Finished -> decodeFinished
HandshakeType_NPN -> do
unless (cParamsSupportNPN cp) $ fail "unsupported handshake type"
- decodeNextProtocolNegociation
+ decodeNextProtocolNegotiation
decodeHelloRequest :: Get Handshake
decodeHelloRequest = return HelloRequest
@@ -221,11 +221,11 @@ decodeCertificates = do
decodeFinished :: Get Handshake
decodeFinished = Finished <$> (remaining >>= getBytes)
-decodeNextProtocolNegociation :: Get Handshake
-decodeNextProtocolNegociation = do
+decodeNextProtocolNegotiation :: Get Handshake
+decodeNextProtocolNegotiation = do
opaque <- getOpaque8
_ <- getOpaque8
- return $ NextProtocolNegociation opaque
+ return $ NextProtocolNegotiation opaque
getSignatureHashAlgorithm :: Get (HashAlgorithm, SignatureAlgorithm)
getSignatureHashAlgorithm = do
@@ -343,7 +343,7 @@ encodeHandshakeContent (CertVerify _) = undefined
encodeHandshakeContent (Finished opaque) = putBytes opaque
-encodeHandshakeContent (NextProtocolNegociation protocol) = do
+encodeHandshakeContent (NextProtocolNegotiation protocol) = do
putOpaque8 protocol
putOpaque8 $ B.replicate paddingLen 0
where paddingLen = 32 - ((B.length protocol + 2) `mod` 32)
View
6 Network/TLS/Receiving.hs
@@ -43,10 +43,11 @@ processPacket (Record ProtocolType_ChangeCipherSpec _ fragment) = do
processPacket (Record ProtocolType_Handshake ver fragment) = do
keyxchg <- getCipherKeyExchangeType
+ npn <- getExtensionNPN
let currentparams = CurrentParams
{ cParamsVersion = ver
, cParamsKeyXchgType = maybe CipherKeyExchange_RSA id $ keyxchg
- , cParamsSupportNPN = False
+ , cParamsSupportNPN = npn
}
handshakes <- returnEither (decodeHandshakes $ fragmentGetBytes fragment)
hss <- forM handshakes $ \(ty, content) -> do
@@ -65,6 +66,9 @@ processHandshake hs = do
Certificates certs -> when clientmode $ do processCertificates certs
ClientKeyXchg content -> unless clientmode $ do
processClientKeyXchg content
+ NextProtocolNegotiation selected_protocol ->
+ unless clientmode $ do
+ setNegotiatedProtocol selected_protocol
Finished fdata -> processClientFinished fdata
_ -> return ()
when (finishHandshakeTypeMaterial $ typeOfHandshake hs) (updateHandshakeDigest $ encodeHandshake hs)
View
18 Network/TLS/State.hs
@@ -35,6 +35,10 @@ module Network.TLS.State
, setServerRandom
, setSecureRenegotiation
, getSecureRenegotiation
+ , setExtensionNPN
+ , getExtensionNPN
+ , setNegotiatedProtocol
+ , getNegotiatedProtocol
, getVerifiedData
, setSession
, getSession
@@ -115,6 +119,7 @@ data TLSState = TLSState
, stClientVerifiedData :: Bytes -- RFC 5746
, stServerVerifiedData :: Bytes -- RFC 5746
, stExtensionNPN :: Bool -- NPN draft extension
+ , stNegotiatedProtocol :: Maybe B.ByteString -- NPN protocol
} deriving (Show)
newtype TLSSt a = TLSSt { runTLSSt :: ErrorT TLSError (State TLSState) a }
@@ -150,6 +155,7 @@ newTLSState rng = TLSState
, stClientVerifiedData = B.empty
, stServerVerifiedData = B.empty
, stExtensionNPN = False
+ , stNegotiatedProtocol = Nothing
}
withTLSRNG :: StateRNG -> (forall g . CryptoRandomGen g => g -> Either e (a,g)) -> Either e (a, StateRNG)
@@ -318,6 +324,18 @@ setSecureRenegotiation b = modify (\st -> st { stSecureRenegotiation = b })
getSecureRenegotiation :: MonadState TLSState m => m Bool
getSecureRenegotiation = get >>= return . stSecureRenegotiation
+setExtensionNPN :: MonadState TLSState m => Bool -> m ()
+setExtensionNPN b = modify (\st -> st { stExtensionNPN = b })
+
+getExtensionNPN :: MonadState TLSState m => m Bool
+getExtensionNPN = get >>= return . stExtensionNPN
+
+setNegotiatedProtocol :: MonadState TLSState m => B.ByteString -> m ()
+setNegotiatedProtocol s = modify (\st -> st { stNegotiatedProtocol = Just s })
+
+getNegotiatedProtocol :: MonadState TLSState m => m (Maybe B.ByteString)
+getNegotiatedProtocol = get >>= return . stNegotiatedProtocol
+
getCipherKeyExchangeType :: MonadState TLSState m => m (Maybe CipherKeyExchangeType)
getCipherKeyExchangeType = get >>= return . (maybe Nothing (Just . cipherKeyExchange) . stCipher)
View
7 Network/TLS/Struct.hs
@@ -205,7 +205,7 @@ data HandshakeType =
| HandshakeType_CertVerify
| HandshakeType_ClientKeyXchg
| HandshakeType_Finished
- | HandshakeType_NPN -- Next Protocol Negociation extension
+ | HandshakeType_NPN -- Next Protocol Negotiation extension
deriving (Show,Eq)
data ServerDHParams = ServerDHParams
@@ -240,7 +240,7 @@ data Handshake =
| CertRequest [CertificateType] (Maybe [ (HashAlgorithm, SignatureAlgorithm) ]) [Word8]
| CertVerify [Word8]
| Finished FinishedData
- | NextProtocolNegociation Bytes -- NPN extension
+ | NextProtocolNegotiation Bytes -- NPN extension
deriving (Show,Eq)
packetType :: Packet -> ProtocolType
@@ -260,7 +260,7 @@ typeOfHandshake (ServerKeyXchg {}) = HandshakeType_ServerKeyXchg
typeOfHandshake (CertRequest {}) = HandshakeType_CertRequest
typeOfHandshake (CertVerify {}) = HandshakeType_CertVerify
typeOfHandshake (Finished {}) = HandshakeType_Finished
-typeOfHandshake (NextProtocolNegociation {}) = HandshakeType_Finished
+typeOfHandshake (NextProtocolNegotiation {}) = HandshakeType_NPN
numericalVer :: Version -> (Word8, Word8)
numericalVer SSL2 = (2, 0)
@@ -334,6 +334,7 @@ instance TypeValuable HandshakeType where
valToType 15 = Just HandshakeType_CertVerify
valToType 16 = Just HandshakeType_ClientKeyXchg
valToType 20 = Just HandshakeType_Finished
+ valToType 67 = Just HandshakeType_NPN
valToType _ = Nothing
instance TypeValuable AlertLevel where
View
4 Network/TLS/Wire.hs
@@ -36,6 +36,7 @@ module Network.TLS.Wire
, putOpaque24
, encodeWord16
, encodeWord64
+ , encodeNPNAlternatives
) where
import Data.Serialize.Get hiding (runGet)
@@ -116,3 +117,6 @@ encodeWord16 = runPut . putWord16
encodeWord64 :: Word64 -> Bytes
encodeWord64 = runPut . putWord64be
+
+encodeNPNAlternatives :: [Bytes] -> Bytes
+encodeNPNAlternatives = runPut . mapM_ putOpaque8
View
2  README.md
@@ -21,5 +21,5 @@ Features
* supported versions: SSL3, TLS1.0, TLS1.1, TLS1.2.
* key exchange supported: only RSA.
* bulk algorithm supported: any stream or block ciphers.
-* supported extensions: secure renegociation, next protocol renegociation (draft 2)
+* supported extensions: secure renegociation, next protocol negotiation (draft 2)
Please sign in to comment.
Something went wrong with that request. Please try again.