Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Add client side of Next Protocol Negotiation.

  • Loading branch information...
commit 2ed8c777b6f7e0bec2d05f52d8d5f2579537d1c0 1 parent 2a781db
@kolmodin authored
View
2  Network/TLS/Context.hs
@@ -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
}
View
35 Network/TLS/Core.hs
@@ -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
View
10 Network/TLS/State.hs
@@ -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)
View
10 Network/TLS/Wire.hs
@@ -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
Please sign in to comment.
Something went wrong with that request. Please try again.