From b1619f8dd90010207fbfc3ed9cacc08a575401ac Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Andreas=20Kr=C3=BChlmann?= <andreas@kruhlmann.dev>
Date: Sun, 16 Jun 2024 20:14:38 +0200
Subject: [PATCH] Improve logger

---
 lib/data/platform/cookie.ml | 1 +
 lib/logger/async.ml         | 3 ++-
 lib/logger/level.ml         | 4 +++-
 lib/logger/sync.ml          | 3 ++-
 4 files changed, 8 insertions(+), 3 deletions(-)

diff --git a/lib/data/platform/cookie.ml b/lib/data/platform/cookie.ml
index 9ca23c3..248b1bc 100644
--- a/lib/data/platform/cookie.ml
+++ b/lib/data/platform/cookie.ml
@@ -83,6 +83,7 @@ let create login domain =
   in
   let* body_str = Cohttp_lwt.Body.to_string body in
   let cookies = extract_cookies @@ Cohttp.Response.headers response in
+  let* _ = Logger.Async.debug ~m:"Cookie" ~f:"create" "Cookie retrieved" in
   let application_gateway_affinity_cors = get_cookie_value cookies "ApplicationGatewayAffinityCORS" in
   let application_gateway_affinity = get_cookie_value cookies "ApplicationGatewayAffinity" in
   let reliclink = get_cookie_value cookies "reliclink" in
diff --git a/lib/logger/async.ml b/lib/logger/async.ml
index a9e8509..8a40bd8 100644
--- a/lib/logger/async.ml
+++ b/lib/logger/async.ml
@@ -1,7 +1,7 @@
 let log ?m ?f level fmt =
   let ksprintf_logger str =
     let formatted_msg = Base.format_message ?m ?f level str in
-    Lwt_io.printf "%s" formatted_msg
+    match level with Level.FATAL -> Lwt.fail_with formatted_msg | _ -> Lwt_io.printf "%s" formatted_msg
   in
   Printf.ksprintf ksprintf_logger fmt
 ;;
@@ -10,3 +10,4 @@ let debug ?m ?f fmt = log ?m ?f Level.DEBUG fmt
 let info ?m ?f fmt = log ?m ?f Level.INFO fmt
 let warn ?m ?f fmt = log ?m ?f Level.WARN fmt
 let error ?m ?f fmt = log ?m ?f Level.ERROR fmt
+let fatal ?m ?f fmt = log ?m ?f Level.FATAL fmt
diff --git a/lib/logger/level.ml b/lib/logger/level.ml
index 81824f8..9460754 100644
--- a/lib/logger/level.ml
+++ b/lib/logger/level.ml
@@ -3,14 +3,16 @@ type t =
   | INFO
   | WARN
   | ERROR
+  | FATAL
 
-let to_string = function DEBUG -> "DBG" | INFO -> "INF" | WARN -> "WAR" | ERROR -> "ERR"
+let to_string = function DEBUG -> "DBG" | INFO -> "INF" | WARN -> "WAR" | ERROR -> "ERR" | FATAL -> "EXT"
 
 let to_color = function
   | DEBUG -> "\x1b[36m" (* Cyan *)
   | INFO -> "\x1b[32m" (* Green *)
   | WARN -> "\x1b[33m" (* Yellow *)
   | ERROR -> "\x1b[31m" (* Red *)
+  | FATAL -> "\x1b[31m" (* Red *)
 ;;
 
 let reset_color = "\x1b[0m"
diff --git a/lib/logger/sync.ml b/lib/logger/sync.ml
index 3984ac9..025d028 100644
--- a/lib/logger/sync.ml
+++ b/lib/logger/sync.ml
@@ -1,7 +1,7 @@
 let log ?m ?f level fmt =
   let kprintf_logger str =
     let formatted_msg = Base.format_message ?m ?f level str in
-    Printf.printf "%s" formatted_msg
+    match level with Level.FATAL -> failwith formatted_msg | _ -> Printf.printf "%s" formatted_msg
   in
   Printf.ksprintf kprintf_logger fmt
 ;;
@@ -10,3 +10,4 @@ let debug ?m ?f fmt = log ?m ?f Level.DEBUG fmt
 let info ?m ?f fmt = log ?m ?f Level.INFO fmt
 let warn ?m ?f fmt = log ?m ?f Level.WARN fmt
 let error ?m ?f fmt = log ?m ?f Level.ERROR fmt
+let fatal ?m ?f fmt = log ?m ?f Level.FATAL fmt