diff --git a/code/pds.conf b/code/pds.conf index d03ea6e3..577240be 100644 --- a/code/pds.conf +++ b/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 diff --git a/code/src/cohttp_abb/cohttp_abb.ml b/code/src/cohttp_abb/cohttp_abb.ml index a1230a8e..da318755 100644 --- a/code/src/cohttp_abb/cohttp_abb.ml +++ b/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 diff --git a/code/src/cohttp_abb/cohttp_abb_io.ml b/code/src/cohttp_abb/cohttp_abb_io.ml index 02acfee4..c421e380 100644 --- a/code/src/cohttp_abb/cohttp_abb_io.ml +++ b/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 diff --git a/code/src/otls/otls.ml b/code/src/otls/otls.ml index 51a76429..9511fb3c 100644 --- a/code/src/otls/otls.ml +++ b/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 diff --git a/code/src/otls/otls.mli b/code/src/otls/otls.mli index 765d8456..0ae4d835 100644 --- a/code/src/otls/otls.mli +++ b/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 diff --git a/code/src/otls/otls_c_bindings.ml b/code/src/otls/otls_c_bindings.ml index 58ebf0e7..7cd8be93 100644 --- a/code/src/otls/otls_c_bindings.ml +++ b/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) diff --git a/code/src/terrat_ee/terrat_ee.ml b/code/src/terrat_ee/terrat_ee.ml index 36f62fad..108ed466 100644 --- a/code/src/terrat_ee/terrat_ee.ml +++ b/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 diff --git a/code/src/terrat_oss/terrat_oss.ml b/code/src/terrat_oss/terrat_oss.ml index 32eb7d46..6d5b5cd2 100644 --- a/code/src/terrat_oss/terrat_oss.ml +++ b/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 diff --git a/docker/terrat/service/terrat b/docker/terrat/service/terrat index ce9831cb..bd5abcef 100755 --- a/docker/terrat/service/terrat +++ b/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'