Merge pull request #234 from terrateamio/233-add-support-self-signed-…

…https_proxy

#233 ADD Support for self-signed https proxy

code/pds.conf

@@ -300,7 +300,25 @@ deps = ["abbs", "brtl", "magic-mime"]
 
 [src.cohttp_abb]
 install = true
-deps = ["abb_channel", "abb_channel_queue", "abb_future_combinators", "abb_happy_eyeballs", "abb_intf", "abb_io", "abb_tls", "cohttp", "containers", "duration", "oth", "oth_abb", "ppx_deriving", "ppx_deriving.eq", "ppx_deriving.show", "uri"]
+deps = [
+     "abb_channel",
+     "abb_channel_queue",
+     "abb_future_combinators",
+     "abb_happy_eyeballs",
+     "abb_intf",
+     "abb_io",
+     "abb_tls",
+     "cohttp",
+     "containers",
+     "duration",
+     "logs",
+     "oth",
+     "oth_abb",
+     "ppx_deriving",
+     "ppx_deriving.eq",
+     "ppx_deriving.show",
+     "uri",
+]
 
 [src.cohttp_abb_curl]
 install = false

code/src/cohttp_abb/cohttp_abb.ml

@@ -1,5 +1,9 @@
 module List = ListLabels
 
+let src = Logs.Src.create "cohttp_abb"
+
+module Logs = (val Logs.src_log src : Logs.LOG)
+
 type connect_err =
   [ Abb_happy_eyeballs.connect_err
   | `E_connection_refused
@@ -125,6 +129,7 @@ module Make (Abb : Abb_intf.S with type Native.t = Unix.file_descr) = struct
 
       let connect_to_port host port =
         let open Fut_comb.Infix_result_monad in
+        Logs.debug (fun m -> m "CONNECT : %s : %d" host port);
         Happy_eyeballs.connect host [ port ] >>= fun (_, sock) -> Abb.Future.return (Ok sock)
 
       let connect_with_sock tls_config uri =
@@ -202,13 +207,25 @@ module Make (Abb : Abb_intf.S with type Native.t = Unix.file_descr) = struct
             CCFun.(CCString.split_on_char ',' %> CCList.map CCString.trim)
             (get_env "no_verify_tls_name")
         in
+        let local_certs_dir = Sys.getenv_opt "CERTS_DIR" in
         let connect tls_config request =
           let tls_config host =
             let config = tls_config host in
+            CCOption.iter
+              (fun local_certs_dir ->
+                Logs.debug (fun m -> m "CERTS_DIR : %s" local_certs_dir);
+                ignore (Otls.Tls_config.set_ca_path config local_certs_dir))
+              local_certs_dir;
             if CCList.mem ~eq:CCString.equal host no_verify_tls_cert || no_verify_tls_cert = [ "*" ]
-            then Otls.Tls_config.insecure_noverifycert config;
+            then (
+              Logs.debug (fun m ->
+                  m "NO_VERIFY_CERT : %s : %s" host (CCString.concat " " no_verify_tls_cert));
+              Otls.Tls_config.insecure_noverifycert config);
             if CCList.mem ~eq:CCString.equal host no_verify_tls_name || no_verify_tls_name = [ "*" ]
-            then Otls.Tls_config.insecure_noverifyname config;
+            then (
+              Logs.debug (fun m ->
+                  m "NO_VERIFY_NAME : %s : %s" host (CCString.concat " " no_verify_tls_name));
+              Otls.Tls_config.insecure_noverifyname config);
             config
           in
           let request_host = Uri.host_with_default ~default:"" (Request.uri request) in
@@ -217,6 +234,8 @@ module Make (Abb : Abb_intf.S with type Native.t = Unix.file_descr) = struct
             when (not (CCList.mem ~eq:CCString.equal request_host no_proxy)) && no_proxy <> [ "*" ]
             -> (
               (* Proxy only those hosts that are not in the no_proxy list. *)
+              Logs.debug (fun m ->
+                  m "PROXY : %s : %s" (Uri.to_string (Request.uri request)) (Uri.to_string proxy));
               let run =
                 let open Fut_comb.Infix_result_monad in
                 connect_with_sock tls_config proxy

code/src/cohttp_abb/cohttp_abb_io.ml

@@ -1,3 +1,7 @@
+let src = Logs.Src.create "cohttp_abb.io"
+
+module Logs = (val Logs.src_log src : Logs.LOG)
+
 module Make (Abb : Abb_intf.S) = struct
   module Fut_comb = Abb_future_combinators.Make (Abb.Future)
   module Buffered = Abb_io_buffered.Make (Abb.Future)
@@ -15,7 +19,10 @@ module Make (Abb : Abb_intf.S) = struct
     Buffered.read_line ic
     >>| function
     | Ok s -> Some s
-    | Error _ -> None
+    | Error (`Unexpected End_of_file) -> None
+    | Error (#Abb_io_buffered.read_err as err) ->
+        Logs.debug (fun m -> m "read_line : %a" Abb_io_buffered.pp_read_err err);
+        None
 
   let read ic n =
     let open Abb.Future.Infix_monad in
@@ -24,7 +31,9 @@ module Make (Abb : Abb_intf.S) = struct
     >>| function
     | Ok 0 -> ""
     | Ok n -> Bytes.sub_string buf 0 n
-    | Error _ -> assert false
+    | Error (#Abb_io_buffered.read_err as err) ->
+        Logs.debug (fun m -> m "read : %a" Abb_io_buffered.pp_read_err err);
+        assert false
 
   let flush oc =
     let open Abb.Future.Infix_monad in

code/src/otls/otls.ml

@@ -48,6 +48,11 @@ module Tls_config = struct
   let create () = Otls_c_bindings.Tls_config.tls_config_new ()
   let destroy t = Otls_c_bindings.Tls_config.tls_config_free t
 
+  let set_ca_path t fname =
+    match Otls_c_bindings.Tls_config.tls_config_set_ca_path t fname with
+    | -1 -> Error `Error
+    | _ -> Ok ()
+
   let set_ca_file t fname =
     match Otls_c_bindings.Tls_config.tls_config_set_ca_file t fname with
     | -1 -> Error `Error

code/src/otls/otls.mli

@@ -27,6 +27,7 @@ module Tls_config : sig
 
   val create : unit -> t
   val destroy : t -> unit
+  val set_ca_path : t -> string -> (unit, [> err ]) result
   val set_ca_file : t -> string -> (unit, [> err ]) result
   val set_cert_file : t -> string -> (unit, [> err ]) result
   val set_key_file : t -> string -> (unit, [> err ]) result

code/src/otls/otls_c_bindings.ml

@@ -12,6 +12,7 @@ module Tls_config = struct
   let tls_config_free = F.foreign "tls_config_free" C.(t @-> returning void)
   let tls_config_error = F.foreign "tls_config_error" C.(t @-> returning string)
   let tls_config_set_ca_file = F.foreign "tls_config_set_ca_file" C.(t @-> string @-> returning int)
+  let tls_config_set_ca_path = F.foreign "tls_config_set_ca_path" C.(t @-> string @-> returning int)
 
   let tls_config_set_cert_file =
     F.foreign "tls_config_set_cert_file" C.(t @-> string @-> returning int)

code/src/terrat_ee/terrat_ee.ml

@@ -17,33 +17,54 @@ module Cmdline = struct
         (* TODO: Make this use the proper Abb time *)
         let time = Unix.gettimeofday () in
         let time_str = ISO8601.Permissive.string_of_datetime time in
-        Format.kfprintf k ppf ("[%s] %a @[" ^^ fmt ^^ "@]@.") time_str Logs.pp_header (level, h)
+        Format.kfprintf
+          k
+          ppf
+          ("[%s] %a [%s] @[" ^^ fmt ^^ "@]@.")
+          time_str
+          Logs.pp_header
+          (level, h)
+          (Logs.Src.name src)
       in
       msgf @@ fun ?header ?tags fmt -> with_stamp header tags k ppf fmt
     in
     { Logs.report }
 
-  let setup_log level dns_logging =
+  let setup_log level dns_logging http_logging =
     Logs.set_reporter (reporter Format.std_formatter);
     Logs.set_level level;
-    if not dns_logging then
-      CCList.iter
-        (fun src ->
-          if
-            CCList.mem
-              ~eq:CCString.equal
-              (Logs.Src.name src)
-              [ "happy-eyeballs"; "dns_client"; "dns_cache"; "abb.dns" ]
-          then
-            (* Increase these loggers because they are too verbose *)
-            Logs.Src.set_level src (Some Logs.Error))
-        (Logs.Src.list ())
+    CCList.iter
+      (fun src ->
+        if
+          (not dns_logging)
+          && CCList.mem
+               ~eq:CCString.equal
+               (Logs.Src.name src)
+               [ "happy-eyeballs"; "dns_client"; "dns_cache"; "abb.dns" ]
+          || (not http_logging)
+             && CCList.mem ~eq:CCString.equal (Logs.Src.name src) [ "cohttp_abb"; "cohttp_abb.io" ]
+        then
+          (* Increase these loggers because they are too verbose *)
+          Logs.Src.set_level src (Some Logs.Error))
+      (Logs.Src.list ())
 
   let dns_logging =
+    let env =
+      let doc = "Enable DNS logging" in
+      C.Cmd.Env.info ~doc "TERRAT_DNS_LOGGING"
+    in
     let doc = "Log DNS operations." in
-    C.Arg.(value & flag & info [ "dns-logging" ] ~doc)
+    C.Arg.(value & flag & info [ "dns-logging" ] ~env ~doc)
+
+  let http_logging =
+    let env =
+      let doc = "Enable HTTP logging" in
+      C.Cmd.Env.info ~doc "TERRAT_HTTP_LOGGING"
+    in
+    let doc = "Log HTTP operations." in
+    C.Arg.(value & flag & info [ "http-logging" ] ~env ~doc)
 
-  let logs = C.Term.(const setup_log $ Logs_cli.level () $ dns_logging)
+  let logs = C.Term.(const setup_log $ Logs_cli.level () $ dns_logging $ http_logging)
 
   let app_id =
     let doc = "App ID." in

code/src/terrat_oss/terrat_oss.ml

@@ -17,33 +17,54 @@ module Cmdline = struct
         (* TODO: Make this use the proper Abb time *)
         let time = Unix.gettimeofday () in
         let time_str = ISO8601.Permissive.string_of_datetime time in
-        Format.kfprintf k ppf ("[%s] %a @[" ^^ fmt ^^ "@]@.") time_str Logs.pp_header (level, h)
+        Format.kfprintf
+          k
+          ppf
+          ("[%s] %a [%s] @[" ^^ fmt ^^ "@]@.")
+          time_str
+          Logs.pp_header
+          (level, h)
+          (Logs.Src.name src)
       in
       msgf @@ fun ?header ?tags fmt -> with_stamp header tags k ppf fmt
     in
     { Logs.report }
 
-  let setup_log level dns_logging =
+  let setup_log level dns_logging http_logging =
     Logs.set_reporter (reporter Format.std_formatter);
     Logs.set_level level;
-    if not dns_logging then
-      CCList.iter
-        (fun src ->
-          if
-            CCList.mem
-              ~eq:CCString.equal
-              (Logs.Src.name src)
-              [ "happy-eyeballs"; "dns_client"; "dns_cache"; "abb.dns" ]
-          then
-            (* Increase these loggers because they are too verbose *)
-            Logs.Src.set_level src (Some Logs.Error))
-        (Logs.Src.list ())
+    CCList.iter
+      (fun src ->
+        if
+          (not dns_logging)
+          && CCList.mem
+               ~eq:CCString.equal
+               (Logs.Src.name src)
+               [ "happy-eyeballs"; "dns_client"; "dns_cache"; "abb.dns" ]
+          || (not http_logging)
+             && CCList.mem ~eq:CCString.equal (Logs.Src.name src) [ "cohttp_abb"; "cohttp_abb.io" ]
+        then
+          (* Increase these loggers because they are too verbose *)
+          Logs.Src.set_level src (Some Logs.Error))
+      (Logs.Src.list ())
 
   let dns_logging =
+    let env =
+      let doc = "Enable DNS logging" in
+      C.Cmd.Env.info ~doc "TERRAT_DNS_LOGGING"
+    in
     let doc = "Log DNS operations." in
-    C.Arg.(value & flag & info [ "dns-logging" ] ~doc)
+    C.Arg.(value & flag & info [ "dns-logging" ] ~env ~doc)
+
+  let http_logging =
+    let env =
+      let doc = "Enable HTTP logging" in
+      C.Cmd.Env.info ~doc "TERRAT_HTTP_LOGGING"
+    in
+    let doc = "Log HTTP operations." in
+    C.Arg.(value & flag & info [ "http-logging" ] ~env ~doc)
 
-  let logs = C.Term.(const setup_log $ Logs_cli.level () $ dns_logging)
+  let logs = C.Term.(const setup_log $ Logs_cli.level () $ dns_logging $ http_logging)
 
   let app_id =
     let doc = "App ID." in

docker/terrat/service/terrat

@@ -21,6 +21,7 @@ def setup_environment():
         with open(cert_path, 'w') as cert_file:
             cert_file.write(os.getenv('CUSTOM_CA_CERT'))
         subprocess.check_call(['update-ca-certificates'])
+        os.environ['CERTS_DIR'] = '/etc/ssl/certs'
         print(f"Self-signed certificate installed to {cert_path}")
     os.environ['GITHUB_APP_PEM'] = os.environ['GITHUB_APP_PEM'].replace('\\n', '\n')
     os.environ['TERRAT_PYTHON_EXEC'] = '/usr/bin/python3'