Merge PR #440.

haskell-tls · Nov 24, 2020 · bf9b1ac · bf9b1ac
2 parents 8c60b03 + 29bc25e
commit bf9b1ac
Show file tree

Hide file tree

Showing 2 changed files with 18 additions and 20 deletions.
diff --git a/core/Network/TLS/Handshake/Server.hs b/core/Network/TLS/Handshake/Server.hs
@@ -142,11 +142,6 @@ handshakeServerWith sparams ctx clientHello@(ClientHello legacyVersion _ clientS
             _                    -> Nothing
     maybe (return ()) (usingState_ ctx . setClientSNI) serverName
 
-    -- ALPN (Application Layer Protocol Negotiation)
-    case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode MsgTClientHello of
-        Just (ApplicationLayerProtocolNegotiation protos) -> usingState_ ctx $ setClientALPNSuggest protos
-        _ -> return ()
-
     -- TLS version dependent
     if chosenVersion <= TLS12 then
         handshakeServerWithTLS12 sparams ctx chosenVersion exts ciphers serverName clientVersion compressions clientSession
@@ -1077,21 +1072,22 @@ findHighestVersionFrom13 clientVersions serverVersions = case svs `intersect` cv
     cvs = sortOn Down clientVersions
 
 applicationProtocol :: Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw]
-applicationProtocol ctx exts sparams
-    | clientALPNSuggest = do
-        suggest <- usingState_ ctx getClientALPNSuggest
-        case (onALPNClientSuggest $ serverHooks sparams, suggest) of
-            (Just io, Just protos) -> do
-                proto <- io protos
-                usingState_ ctx $ do
-                    setExtensionALPN True
-                    setNegotiatedProtocol proto
-                return [ ExtensionRaw extensionID_ApplicationLayerProtocolNegotiation
-                                        (extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) ]
-            (_, _)                  -> return []
-    | otherwise = return []
-  where
-    clientALPNSuggest = isJust $ extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts
+applicationProtocol ctx exts sparams = do
+    -- ALPN (Application Layer Protocol Negotiation)
+    case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode MsgTClientHello of
+        Nothing -> return []
+        Just (ApplicationLayerProtocolNegotiation protos) -> do
+            case onALPNClientSuggest $ serverHooks sparams of
+                Just io -> do
+                    proto <- io protos
+                    when (proto == "") $
+                        throwCore $ Error_Protocol ("no supported application protocols", True, NoApplicationProtocol)
+                    usingState_ ctx $ do
+                        setExtensionALPN True
+                        setNegotiatedProtocol proto
+                    return [ ExtensionRaw extensionID_ApplicationLayerProtocolNegotiation
+                                            (extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) ]
+                _ -> return []
 
 credentialsFindForSigning13 :: [HashAndSignatureAlgorithm] -> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm)
 credentialsFindForSigning13 hss0 creds = loop hss0

diff --git a/core/Network/TLS/Parameters.hs b/core/Network/TLS/Parameters.hs
@@ -607,6 +607,8 @@ data ServerHooks = ServerHooks
       -- | Allow the server to choose an application layer protocol
       --   suggested from the client through the ALPN
       --   (Application Layer Protocol Negotiation) extensions.
+      --   If the server supports no protocols that the client advertises
+      --   an empty 'ByteString' should be returned.
       --
       -- Default: 'Nothing'
     , onALPNClientSuggest     :: Maybe ([B.ByteString] -> IO B.ByteString)