Add client side of Next Protocol Negotiation.
This commit is contained in:
Lennart Kolmodin
parent
2a781dbc44
commit
2ed8c777b6
4 changed files with 50 additions and 7 deletions
|
|
@ -85,6 +85,7 @@ data TLSParams = TLSParams
|
|||
, 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.
|
||||
, onNPNServerSuggest :: Maybe ([B.ByteString] -> IO B.ByteString)
|
||||
, sessionResumeWith :: Maybe (SessionID, SessionData) -- ^ try to establish a connection using this session.
|
||||
}
|
||||
|
||||
|
|
@ -113,6 +114,7 @@ defaultParams = TLSParams
|
|||
, onSessionEstablished = (\_ _ -> return ())
|
||||
, onSessionInvalidated = (\_ -> return ())
|
||||
, onSuggestNextProtocols = return Nothing
|
||||
, onNPNServerSuggest = Nothing
|
||||
, sessionResumeWith = Nothing
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@ import Network.TLS.State as S
|
|||
import Network.TLS.Sending
|
||||
import Network.TLS.Receiving
|
||||
import Network.TLS.Measurement
|
||||
import Network.TLS.Wire (encodeWord16, encodeNPNAlternatives)
|
||||
import Network.TLS.Wire (encodeWord16, encodeNPNAlternatives, decodeNPNAlternatives)
|
||||
import Data.Maybe
|
||||
import Data.Data
|
||||
import Data.List (intersect, find)
|
||||
|
|
@ -147,6 +147,17 @@ runRecvState ctx iniState = recvPacketHandshake ctx >>= loop iniState >
|
|||
sendChangeCipherAndFinish :: MonadIO m => TLSCtx c -> Bool -> m ()
|
||||
sendChangeCipherAndFinish ctx isClient = do
|
||||
sendPacket ctx ChangeCipherSpec
|
||||
when isClient $ do
|
||||
suggest <- usingState_ ctx $ getServerNextProtocolSuggest
|
||||
case (onNPNServerSuggest (ctxParams ctx), suggest) of
|
||||
-- client offered, server picked up. send NPN handshake.
|
||||
(Just io, Just protos) -> do proto <- liftIO $ io protos
|
||||
sendPacket ctx (Handshake [NextProtocolNegotiation proto])
|
||||
usingState_ ctx $ setNegotiatedProtocol proto
|
||||
-- client offered, server didn't pick up. do nothing.
|
||||
(Just _, Nothing) -> return ()
|
||||
-- client didn't offer. do nothing.
|
||||
(Nothing, _) -> return ()
|
||||
liftIO $ connectionFlush ctx
|
||||
cf <- usingState_ ctx $ getHandshakeDigest isClient
|
||||
sendPacket ctx (Handshake [Finished cf])
|
||||
|
|
@ -263,11 +274,14 @@ handshakeClient ctx = do
|
|||
ciphers = pCiphers params
|
||||
compressions = pCompressions params
|
||||
clientCerts = map fst $ pCertificates params
|
||||
getExtensions =
|
||||
getExtensions = sequence [secureReneg, npnExtention] >>= return . catMaybes
|
||||
secureReneg =
|
||||
if pUseSecureRenegotiation params
|
||||
then usingState_ ctx (getVerifiedData True) >>= \vd -> return [ (0xff01, encodeExtSecureRenegotiation vd Nothing) ]
|
||||
else return []
|
||||
|
||||
then usingState_ ctx (getVerifiedData True) >>= \vd -> return $ Just (0xff01, encodeExtSecureRenegotiation vd Nothing)
|
||||
else return Nothing
|
||||
npnExtention = if isJust $ onNPNServerSuggest params
|
||||
then return $ Just (13172, "")
|
||||
else return Nothing
|
||||
sendClientHello = do
|
||||
crand <- getStateRNG ctx 32 >>= return . ClientRandom
|
||||
let clientSession = Session . maybe Nothing (Just . fst) $ sessionResumeWith params
|
||||
|
|
@ -296,7 +310,7 @@ handshakeClient ctx = do
|
|||
recvServerHello = runRecvState ctx (RecvStateHandshake onServerHello)
|
||||
|
||||
onServerHello :: MonadIO m => Handshake -> m (RecvState m)
|
||||
onServerHello sh@(ServerHello rver _ serverSession cipher _ _) = do
|
||||
onServerHello sh@(ServerHello rver _ serverSession cipher _ exts) = do
|
||||
when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion)
|
||||
case find ((==) rver) allowedvers of
|
||||
Nothing -> throwCore $ Error_Protocol ("version " ++ show ver ++ "is not supported", True, ProtocolVersion)
|
||||
|
|
@ -310,6 +324,12 @@ handshakeClient ctx = do
|
|||
Nothing -> Nothing
|
||||
usingState_ ctx $ setSession serverSession (isJust resumingSession)
|
||||
usingState_ ctx $ processServerHello sh
|
||||
case fmap decodeNPNAlternatives (lookup 13172 exts) of
|
||||
Just (Right protos) -> usingState_ ctx $ do
|
||||
setExtensionNPN True
|
||||
setServerNextProtocolSuggest protos
|
||||
Just (Left err) -> throwCore (Error_Protocol ("could not decode NPN handshake: " ++ err, True, DecodeError))
|
||||
Nothing -> return ()
|
||||
case resumingSession of
|
||||
Nothing -> return $ RecvStateHandshake processCertificate
|
||||
Just sessionData -> do
|
||||
|
|
@ -466,7 +486,8 @@ handshakeServerWith ctx clientHello@(ClientHello ver _ clientSession ciphers com
|
|||
then liftIO $ onSuggestNextProtocols params
|
||||
else return Nothing
|
||||
npnExt <- case nextProtocols of
|
||||
Just protos -> do usingState_ ctx $ setExtensionNPN True
|
||||
Just protos -> do usingState_ ctx $ do setExtensionNPN True
|
||||
setServerNextProtocolSuggest protos
|
||||
return [ (13172, encodeNPNAlternatives protos) ]
|
||||
Nothing -> return []
|
||||
let extensions = secRengExt ++ npnExt
|
||||
|
|
|
|||
|
|
@ -39,6 +39,8 @@ module Network.TLS.State
|
|||
, getExtensionNPN
|
||||
, setNegotiatedProtocol
|
||||
, getNegotiatedProtocol
|
||||
, setServerNextProtocolSuggest
|
||||
, getServerNextProtocolSuggest
|
||||
, getVerifiedData
|
||||
, setSession
|
||||
, getSession
|
||||
|
|
@ -120,6 +122,7 @@ data TLSState = TLSState
|
|||
, stServerVerifiedData :: Bytes -- RFC 5746
|
||||
, stExtensionNPN :: Bool -- NPN draft extension
|
||||
, stNegotiatedProtocol :: Maybe B.ByteString -- NPN protocol
|
||||
, stServerNextProtocolSuggest :: Maybe [B.ByteString]
|
||||
} deriving (Show)
|
||||
|
||||
newtype TLSSt a = TLSSt { runTLSSt :: ErrorT TLSError (State TLSState) a }
|
||||
|
|
@ -156,6 +159,7 @@ newTLSState rng = TLSState
|
|||
, stServerVerifiedData = B.empty
|
||||
, stExtensionNPN = False
|
||||
, stNegotiatedProtocol = Nothing
|
||||
, stServerNextProtocolSuggest = Nothing
|
||||
}
|
||||
|
||||
withTLSRNG :: StateRNG -> (forall g . CryptoRandomGen g => g -> Either e (a,g)) -> Either e (a, StateRNG)
|
||||
|
|
@ -336,6 +340,12 @@ setNegotiatedProtocol s = modify (\st -> st { stNegotiatedProtocol = Just s })
|
|||
getNegotiatedProtocol :: MonadState TLSState m => m (Maybe B.ByteString)
|
||||
getNegotiatedProtocol = get >>= return . stNegotiatedProtocol
|
||||
|
||||
setServerNextProtocolSuggest :: MonadState TLSState m => [B.ByteString] -> m ()
|
||||
setServerNextProtocolSuggest ps = modify (\st -> st { stServerNextProtocolSuggest = Just ps})
|
||||
|
||||
getServerNextProtocolSuggest :: MonadState TLSState m => m (Maybe [B.ByteString])
|
||||
getServerNextProtocolSuggest = get >>= return . stServerNextProtocolSuggest
|
||||
|
||||
getCipherKeyExchangeType :: MonadState TLSState m => m (Maybe CipherKeyExchangeType)
|
||||
getCipherKeyExchangeType = get >>= return . (maybe Nothing (Just . cipherKeyExchange) . stCipher)
|
||||
|
||||
|
|
|
|||
|
|
@ -37,6 +37,7 @@ module Network.TLS.Wire
|
|||
, encodeWord16
|
||||
, encodeWord64
|
||||
, encodeNPNAlternatives
|
||||
, decodeNPNAlternatives
|
||||
) where
|
||||
|
||||
import Data.Serialize.Get hiding (runGet)
|
||||
|
|
@ -120,3 +121,12 @@ encodeWord64 = runPut . putWord64be
|
|||
|
||||
encodeNPNAlternatives :: [Bytes] -> Bytes
|
||||
encodeNPNAlternatives = runPut . mapM_ putOpaque8
|
||||
|
||||
decodeNPNAlternatives :: Bytes -> Either String [Bytes]
|
||||
decodeNPNAlternatives = runGet "" p
|
||||
where
|
||||
p = do
|
||||
avail <- remaining
|
||||
case avail of
|
||||
0 -> return []
|
||||
_ -> do liftM2 (:) getOpaque8 p
|
||||
|
|
|
|||
Loading…
Reference in a new issue