CP-311259: Define tls lib to manage TLS version and ciphers

dune-project

@@ -31,6 +31,15 @@
 (package
  (name zstd))
 
+(package
+ (name tls)
+ (synopsis "TLS policy types and format-specific string renderers")
+ (description
+  "Provides TLS policy types and renderers for GnuTLS priority strings and OpenSSL cipher lists.")
+ (depends
+  (ocaml
+   (>= 4.14))))
+
 (package
  (name clock)
  (synopsis "Xapi's library for managing time")

ocaml/libs/tls/dune

@@ -0,0 +1,5 @@
+(library
+  (name tls)
+  (public_name tls)
+  (wrapped false)
+)

ocaml/libs/tls/tls.ml

@@ -0,0 +1,190 @@
+(*
+ * Copyright (C) Citrix Systems Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+type version = TLS_1_2 | TLS_1_3
+
+type cipher = AES_128_GCM | AES_256_GCM
+
+type curve = Secp384r1
+
+type kex = ECDHE_RSA
+
+type policy = {
+    versions: version list
+  ; ciphers: cipher list
+  ; curves: curve list
+  ; kex: kex list
+  ; server_preference: bool
+}
+
+(* ---- Default XenServer policy ------------------------------------------- *)
+
+let default =
+  {
+    versions= [TLS_1_2]
+  ; ciphers= [AES_256_GCM; AES_128_GCM]
+  ; curves= [Secp384r1]
+  ; kex= [ECDHE_RSA]
+  ; server_preference= true
+  }
+
+(** Common interface both renderers implement. *)
+module type Renderer = sig
+  val string_of_versions : version list -> string
+  (** Format-specific colon-joined version list from a version list. *)
+
+  val string_of_ciphers : cipher list -> string
+  (** Format-specific colon-joined cipher list from a cipher list. *)
+
+  val string_of_policy : policy -> string
+  (** Format-specific combined cipher suite string from a policy. *)
+
+  val string_of_curves : curve list -> string
+  (** Format-specific colon-joined curve list from a curve list. *)
+
+  val string_of_server_preference : bool -> string
+  (** Format-specific server-preference flag *)
+end
+
+(* ---- GnuTLS renderer ---------------------------------------------------- *)
+
+module GnutlsImpl = struct
+  let string_of_version = function
+    | TLS_1_2 ->
+        "+VERS-TLS1.2"
+    | TLS_1_3 ->
+        "+VERS-TLS1.3"
+
+  let string_of_cipher = function
+    | AES_128_GCM ->
+        "+AES-128-GCM"
+    | AES_256_GCM ->
+        "+AES-256-GCM"
+
+  let string_of_versions versions =
+    List.map string_of_version versions |> String.concat ":"
+
+  let string_of_ciphers ciphers =
+    List.map string_of_cipher ciphers |> String.concat ":"
+
+  let string_of_curve = function Secp384r1 -> "+GROUP-SECP384R1"
+
+  let string_of_curves curves =
+    List.map string_of_curve curves |> String.concat ":"
+
+  let string_of_kex = function ECDHE_RSA -> "+ECDHE-RSA"
+
+  let string_of_server_preference = function
+    | true ->
+        "%SERVER_PRECEDENCE"
+    | false ->
+        ""
+
+  (** Build a GnuTLS priority string from a policy.
+      Example:
+      ["NONE:+VERS-TLS1.2:+AES-256-GCM:+AES-128-GCM:+AEAD:+ECDHE-RSA:+SIGN-ALL:+GROUP-SECP384R1:+COMP-NULL:%SERVER_PRECEDENCE"]
+      Suitable for Samba's [tls priority =] in [smb.conf]. *)
+  let string_of_policy {versions; ciphers; kex; curves; server_preference} =
+    (* GnuTLS priority token order (from the GnuTLS manual):
+       versions -> ciphers -> MACs -> KEX -> signatures -> groups -> compression -> flags *)
+    let is_aead =
+      List.exists (function AES_128_GCM | AES_256_GCM -> true) ciphers
+    in
+    let tokens =
+      List.map string_of_version versions
+      @ List.map string_of_cipher ciphers
+      @ ( if is_aead then
+            ["+AEAD"]
+          else
+            []
+        )
+      @ List.map string_of_kex kex
+      @ ["+SIGN-ALL"]
+      @ List.map string_of_curve curves
+      @ ["+COMP-NULL"]
+      @
+      if server_preference then
+        ["%SERVER_PRECEDENCE"]
+      else
+        []
+    in
+    Printf.sprintf "NONE:%s" (String.concat ":" tokens)
+end
+
+(* ---- OpenSSL renderer --------------------------------------------------- *)
+
+module OpensslImpl = struct
+  (* OpenSSL TLS 1.2 suite name: ECDHE-RSA-CIPHER-HASH.
+     For GCM (AEAD) suites the hash is used only as the PRF:
+       AES-256-GCM -> SHA-384, AES-128-GCM -> SHA-256. *)
+  let string_of_cipher = function
+    | AES_256_GCM ->
+        "ECDHE-RSA-AES256-GCM-SHA384"
+    | AES_128_GCM ->
+        "ECDHE-RSA-AES128-GCM-SHA256"
+
+  let string_of_version = function TLS_1_2 -> "TLSv1.2" | TLS_1_3 -> "TLSv1.3"
+
+  let string_of_versions versions =
+    List.map string_of_version versions |> String.concat ":"
+
+  let string_of_ciphers ciphers =
+    List.map string_of_cipher ciphers |> String.concat ":"
+
+  let string_of_curve = function Secp384r1 -> "secp384r1"
+
+  let string_of_curves curves =
+    List.map string_of_curve curves |> String.concat ":"
+
+  let string_of_server_preference = function
+    | true ->
+        "CIPHER_SERVER_PREFERENCE"
+    | false ->
+        ""
+
+  let string_of_policy _ = failwith "Not supported"
+end
+
+(** Extends any [Renderer] with convenience values pre-applied to [default]. *)
+module type RendererWithDefaults = sig
+  include Renderer
+
+  val default_policy : unit -> string
+
+  val default_ciphers : string
+
+  val default_version : string
+
+  val default_curve : string
+
+  val default_server_preference : string
+end
+
+module WithDefaults (R : Renderer) : RendererWithDefaults = struct
+  include R
+
+  let default_policy () = R.string_of_policy default
+
+  let default_ciphers = R.string_of_ciphers default.ciphers
+
+  let default_version = R.string_of_versions default.versions
+
+  let default_curve = R.string_of_curves default.curves
+
+  let default_server_preference =
+    R.string_of_server_preference default.server_preference
+end
+
+module Gnutls = WithDefaults (GnutlsImpl)
+module Openssl = WithDefaults (OpensslImpl)

ocaml/libs/tls/tls.mli

@@ -0,0 +1,95 @@
+(*
+ * Copyright (C) Citrix Systems Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+(** TLS policy types and format-specific string renderers.
+
+    Usage:
+    {[
+      let () = print_endline (Tls.Gnutls.default_policy ())
+      let () = print_endline (Tls.Openssl.default_policy ())
+      let () = print_endline Tls.Openssl.default_curve
+      (* or with a custom policy: *)
+      let my_policy = { ... }
+      let () = print_endline (Tls.Openssl.string_of_policy my_policy)
+    ]} *)
+
+type version = TLS_1_2 | TLS_1_3
+
+type cipher =
+  | AES_128_GCM  (** AEAD; paired with SHA-256 in OpenSSL suite names *)
+  | AES_256_GCM  (** AEAD; paired with SHA-384 in OpenSSL suite names *)
+
+type curve = Secp384r1
+
+type kex = ECDHE_RSA
+
+type policy = {
+    versions: version list
+  ; ciphers: cipher list
+  ; curves: curve list  (** Only the first curve is used for stunnel. *)
+  ; kex: kex list
+  ; server_preference: bool  (** When [true], the server picks the cipher. *)
+}
+
+(** Common interface both renderers implement. *)
+module type Renderer = sig
+  val string_of_versions : version list -> string
+  (** Format-specific colon-joined version list from a version list. *)
+
+  val string_of_ciphers : cipher list -> string
+  (** Format-specific colon-joined cipher list from a cipher list. *)
+
+  val string_of_policy : policy -> string
+  (** Format-specific combined cipher suite string from a policy. *)
+
+  val string_of_curves : curve list -> string
+  (** Format-specific colon-joined curve list from a curve list. *)
+
+  val string_of_server_preference : bool -> string
+  (** Format-specific server-preference flag, or ["" ] if disabled. *)
+end
+
+(** Extends [Renderer] with convenience values pre-applied to the default policy. *)
+module type RendererWithDefaults = sig
+  include Renderer
+
+  val default_policy : unit -> string
+  (** Format-specific combined cipher suite string for the default policy.
+
+      This is a [unit -> string] function rather than a plain [string] value to
+      avoid eager evaluation at module initialisation time.  OCaml evaluates
+      every top-level [let] in a functor body when the functor is applied, so a
+      plain [string] binding would call [string_of_policy] immediately —
+      crashing for renderers (e.g. [Openssl]) where [string_of_policy] raises.
+      The other [default_*] values are plain strings because their underlying
+      functions are defined for every renderer. *)
+
+  val default_ciphers : string
+  (** Colon-joined cipher string for the default cipher list. *)
+
+  val default_version : string
+  (** Colon-joined version string for the default version list. *)
+
+  val default_curve : string
+  (** Colon-joined curve string for the default curve list. *)
+
+  val default_server_preference : string
+  (** Server-preference string for the default policy. *)
+end
+
+(** GnuTLS priority string renderer. *)
+module Gnutls : RendererWithDefaults
+
+(** OpenSSL cipher list renderer. *)
+module Openssl : RendererWithDefaults

ocaml/tests/dune

@@ -9,7 +9,8 @@
       test_vm_placement test_vm_helpers test_repository test_repository_helpers
       test_ref test_xapi_helpers test_vm_group
       test_livepatch test_rpm test_updateinfo test_storage_smapiv1_wrapper test_storage_quicktest test_observer
-      test_pool_periodic_update_sync test_pkg_mgr test_tar_ext test_pool_repository))
+      test_pool_periodic_update_sync test_pkg_mgr test_tar_ext test_pool_repository
+      test_tls))
   (libraries
     alcotest
     angstrom
@@ -172,6 +173,13 @@
   (action (run ./check-no-xenctrl %{x}))
 )
 
+(test
+  (name test_tls)
+  (modes exe)
+  (modules test_tls)
+  (libraries alcotest tls)
+)
+
 (env (_ (env-vars (XAPI_TEST 1))))
 
 ; disassemble, but without sources