Expose ALPN configuration and negotiated protocol for TLS clients

.github/workflows/proofs/formatting.txt

@@ -1 +1 @@
-6b44977fe76c555d6919a7ea4efe69ee9302c402ef3bec69aec5445076f0f731 ab5370655049c955d122d644eb26598258e7998bf91ebc7433f068470a966a9e pass
+13efc96da3bfb5b2560a49ac70fa8842cd30a1158e52c787def09dd8d14fb24a ab5370655049c955d122d644eb26598258e7998bf91ebc7433f068470a966a9e pass

.github/workflows/proofs/tests.txt

@@ -1 +1 @@
-37ec63df5a1906ffa4520b1c2993a228a8a9555e0415b81198933281b74b6a79 7a39b8df88ef160e852c6aac30ee2a8bfdb8074b060d5afc8c72bf5f03d1f0a7 pass
+9bb69d38e11c089c170a23626bc64b63fda439be9c7123c42ee8822e8cefb340 7a39b8df88ef160e852c6aac30ee2a8bfdb8074b060d5afc8c72bf5f03d1f0a7 pass

.github/workflows/proofs/transcripts.txt

@@ -1 +1 @@
-11b365a07b04255c18a3acabab1bc76533a6daadff43fe6711c7fc4966a1252a 72c0b9bfd651515ecb3d3f4981a6bdb8c6d52eba2308cd11fea004d31941aeef pass
+78be91be2ebe0b4fef4930d5cf57a11fabcf105748e1f62f36a7e1010b6da75b 72c0b9bfd651515ecb3d3f4981a6bdb8c6d52eba2308cd11fea004d31941aeef pass

parser-typechecker/src/Unison/Builtin.hs

@@ -1127,12 +1127,15 @@ ioBuiltins =
     ("Tls.encodePrivateKey", tlsPrivateKey --> bytes),
     ("Tls.receive.impl.v3", tls --> iof bytes),
     ("Tls.terminate.impl.v3", tls --> iof unit),
+    ("Tls.negotiatedProtocol", tls --> iof (optionalt bytes)),
     ("Tls.ClientConfig.default", text --> bytes --> tlsClientConfig),
     ("Tls.ServerConfig.default", list tlsSignedCert --> tlsPrivateKey --> tlsServerConfig),
     ("TLS.ClientConfig.ciphers.set", list tlsCipher --> tlsClientConfig --> tlsClientConfig),
     ("Tls.ServerConfig.ciphers.set", list tlsCipher --> tlsServerConfig --> tlsServerConfig),
     ("Tls.ClientConfig.certificates.set", list tlsSignedCert --> tlsClientConfig --> tlsClientConfig),
     ("Tls.ClientConfig.certificates.get", tlsClientConfig --> list tlsSignedCert),
+    ("Tls.ClientConfig.alpn.set", list bytes --> tlsClientConfig --> tlsClientConfig),
+    ("Tls.ServerConfig.alpn.set", list bytes --> tlsServerConfig --> tlsServerConfig),
     ("Tls.ServerConfig.certificates.set", list tlsSignedCert --> tlsServerConfig --> tlsServerConfig),
     ("Tls.ServerConfig.certificates.get", tlsServerConfig --> list tlsSignedCert),
     ("Tls.ClientConfig.validation.disableHostNameValidation", tlsClientConfig --> tlsClientConfig),

unison-runtime/src/Unison/Runtime/Builtin.hs

@@ -1198,6 +1198,8 @@ declareForeigns = do
   declareForeign Tracked 2 Tls_ClientConfig_certificates_set
   declareForeign Tracked 2 Tls_ServerConfig_certificates_set
   declareForeign Tracked 1 Tls_ClientConfig_certificates_get
+  declareForeign Tracked 2 Tls_ClientConfig_alpn_set
+  declareForeign Tracked 2 Tls_ServerConfig_alpn_set
   declareForeign Tracked 1 Tls_ServerConfig_certificates_get
   declareForeign Tracked 1 Tls_ClientConfig_validation_disableHostNameValidation
   declareForeign Tracked 1 Tls_ClientConfig_validation_disableCertificateValidation
@@ -1220,6 +1222,7 @@ declareForeigns = do
   declareForeign Tracked 2 Tls_newClient_impl_v3
   declareForeign Tracked 2 Tls_newServer_impl_v3
   declareForeign Tracked 1 Tls_handshake_impl_v3
+  declareForeign Tracked 1 Tls_negotiatedProtocol
   declareForeign Tracked 2 Tls_send_impl_v3
   declareForeign Tracked 1 Tls_decodeCert_impl_v3
 

unison-runtime/src/Unison/Runtime/Foreign/Function.hs

@@ -489,6 +489,38 @@ foreignCallHelper = \case
   Tls_ClientConfig_certificates_get ->
     mkForeign $
       \(client :: TLS.ClientParams) -> pure $ X.listCertificates $ TLS.sharedCAStore $ TLS.clientShared client
+  Tls_ClientConfig_alpn_set ->
+    let updateClient :: [Bytes.Bytes] -> TLS.ClientParams -> TLS.ClientParams
+        updateClient protocols client =
+          client
+            { TLS.clientHooks =
+                (TLS.clientHooks client)
+                  { TLS.onSuggestALPN = pure (Just (map Bytes.toArray protocols))
+                  }
+            }
+     in mkForeign $
+          \(protocols :: [Bytes.Bytes], params :: ClientParams) -> pure $ updateClient protocols params
+  Tls_ServerConfig_alpn_set ->
+    let updateServer :: [Bytes.Bytes] -> TLS.ServerParams -> TLS.ServerParams
+        updateServer protocols server =
+          server
+            { TLS.serverHooks =
+                (TLS.serverHooks server)
+                  { TLS.onALPNClientSuggest =
+                      Just $ \clientProtocols ->
+                        pure $
+                          foldr
+                            ( \protocol selected ->
+                                if Bytes.toArray protocol `elem` clientProtocols
+                                  then Bytes.toArray protocol
+                                  else selected
+                            )
+                            ""
+                            protocols
+                  }
+            }
+     in mkForeign $
+          \(protocols :: [Bytes.Bytes], params :: ServerParams) -> pure $ updateServer protocols params
   Tls_ClientConfig_validation_disableHostNameValidation ->
     let customChecks = X.defaultChecks {checkFQHN = False}
         customHooks = def {TLS.onServerCertificate = X.validate X.HashSHA256 defaultHooks customChecks}
@@ -543,6 +575,8 @@ foreignCallHelper = \case
          ) -> Tls socket <$> TLS.contextNew socket config
   Tls_handshake_impl_v3 -> mkForeignTls $
     \(tls :: Tls) -> TLS.handshake tls.context
+  Tls_negotiatedProtocol -> mkForeignTls $
+    \(tls :: Tls) -> fmap (fmap Bytes.fromArray) $ TLS.getNegotiatedProtocol tls.context
   Tls_send_impl_v3 ->
     mkForeignTls $
       \( tls :: Tls,

unison-runtime/src/Unison/Runtime/Foreign/Function/Type.hs

@@ -106,6 +106,9 @@ data ForeignFunc
   | Tls_ServerConfig_default
   | Tls_ClientConfig_certificates_set
   | Tls_ClientConfig_certificates_get
+  | Tls_ClientConfig_alpn_set
+  | Tls_ServerConfig_alpn_set
+  | Tls_negotiatedProtocol
   | Tls_ClientConfig_validation_disableHostNameValidation
   | Tls_ClientConfig_validation_disableCertificateValidation
   | Tls_ServerConfig_certificates_set
@@ -569,6 +572,9 @@ foreignFuncBuiltinName = \case
   Tls_ClientConfig_certificates_set -> "Tls.ClientConfig.certificates.set"
   Tls_ServerConfig_certificates_set -> "Tls.ServerConfig.certificates.set"
   Tls_ClientConfig_certificates_get -> "Tls.ClientConfig.certificates.get"
+  Tls_ClientConfig_alpn_set -> "Tls.ClientConfig.alpn.set"
+  Tls_ServerConfig_alpn_set -> "Tls.ServerConfig.alpn.set"
+  Tls_negotiatedProtocol -> "Tls.negotiatedProtocol"
   Tls_ServerConfig_certificates_get -> "Tls.ServerConfig.certificates.get"
   Tls_ClientConfig_validation_disableCertificateValidation -> "Tls.ClientConfig.validation.disableCertificateValidation"
   Tls_ClientConfig_validation_disableHostNameValidation -> "Tls.ClientConfig.validation.disableHostNameValidation"