From e6ee8a87a07e4159e49b6c968943ef4a0145a9cd Mon Sep 17 00:00:00 2001 From: swrup Date: Thu, 12 Mar 2026 13:23:27 +0100 Subject: [PATCH] --- src/devices.ml | 30 ------------------------------ src/mte.ml | 47 ++++++++++++++++++++++++++++------------------- src/pg.ml | 7 ++++++- 3 files changed, 34 insertions(+), 50 deletions(-) delete mode 100644 src/devices.ml diff --git a/src/devices.ml b/src/devices.ml deleted file mode 100644 index 6173478a..00000000 --- a/src/devices.ml +++ /dev/null @@ -1,30 +0,0 @@ -let db_connection caqti_switch : - (unit, Caqti_miou.connection) Vifu.Device.device = - let f () = - let db_uri = Config.Exchangedb_postgres.config in - match Caqti_miou_unix.connect ~sw:caqti_switch db_uri with - | Error err -> - Fmt.failwith "Database connection failure: %a." Caqti_error.pp err - | Ok conn -> ( - match Pg.preflight conn with - | Error err -> - Fmt.failwith "Database preflight failure: %a." Caqti_error.pp err - | Ok () -> - Logs.info (fun m -> m "database connection initialized"); - conn) - in - let finally (module Conn : Caqti_miou.CONNECTION) = Conn.disconnect () in - Vifu.Device.v ~name:"db_connection" ~finally [] f - -let keys storage = - let f (module Conn : Pg.CONN) () = - let (module Fs) = - (module struct - let t = storage - end) - in - let keys : (module Keys.S) = (module Keys.Make (Conn) (Fs)) in - keys - in - let finally _key = () in - Vifu.Device.v ~name:"keys" ~finally [ Vifu.Device.value db_connection ] f diff --git a/src/mte.ml b/src/mte.ml index 55da93d9..8319900a 100644 --- a/src/mte.ml +++ b/src/mte.ml @@ -81,8 +81,6 @@ let test (module Conn : Caqti_miou.CONNECTION) = Logs.app (fun f -> f "%d - %d = %d" a b c); () -let disconnect (module Conn : Caqti_miou.CONNECTION) = Conn.disconnect () - module RNG = Mirage_crypto_rng.Fortuna let () = @@ -101,31 +99,42 @@ let () = @@ fun rng storage (stack, tcp, udp) () -> let@ () = fun () -> Mirage_crypto_rng_mkernel.kill rng in let@ () = fun () -> Mnet.kill stack in - (* -- setup db connection -- *) let hed, he = Mnet_happy_eyeballs.create tcp in let@ () = fun () -> Mnet_happy_eyeballs.kill hed in - let dns = Mnet_dns.create (udp_db, he) in + let dns = Mnet_dns.create (udp, he) in let t = Mnet_dns.transport dns in let@ () = fun () -> Mnet_dns.Transport.kill t in + Caqti_miou.Switch.run @@ fun sw -> - Logs.app (fun m -> m "Connecting to the database"); - let db_connection = - let config = Caqti_connect_config.default in - let r = Caqti_mnet.connect ~config ~sw stack tcp dns db_uri in - caqti_get_ok r + let db_conn = + let db_uri = Config.Exchangedb_postgres.config in + match Caqti_mnet.connect ~sw stack tcp dns db_uri with + | Error err -> + Fmt.failwith "Database connection failure: %a." Caqti_error.pp err + | Ok conn -> conn in - let@ () = fun () -> disconnect db_connection in - Logs.app (fun m -> m "Connected"); - test db_connection; - Logs.app (fun m -> m "Test OK"); + let@ () = + fun () -> + let (module Conn : Caqti_miou.CONNECTION) = db_conn in + Conn.disconnect () + in + + let () = Pg.preflight db_conn in + Logs.info (fun m -> m "database connection initialized"); + + let keys : (module Keys.S) = + let (module Conn : Pg.CONN) = db_conn in + let (module Fs : Fat.FS) = + (module struct + let t = storage + end) + in + (module Keys.Make (Conn) (Fs)) + in + (* -- *) - (* -- start webserver -- *) - let devices = [] in let cfg = Vifu.Config.v Config.Exchange.port in - let db_device = Devices.db_connection sw in - let keys_device = Devices.keys storage (Vifu.Device.value db_device) in - let devices = Vifu.Devices.[ db_device; keys_device ] in - Vifu.run ~cfg ~devices tcp routes () + Vifu.run ~cfg tcp routes (db_conn, keys) (* Miou_unix.run @@ fun () -> diff --git a/src/pg.ml b/src/pg.ml index 39b29992..39d968dc 100644 --- a/src/pg.ml +++ b/src/pg.ml @@ -26,7 +26,12 @@ let preflight = "SET search_path TO exchange;"; ] in - fun (module Conn : CONN) -> Syntax.list_iter (fun p -> Conn.exec p ()) l + fun (module Conn : CONN) -> + let r = Syntax.list_iter (fun p -> Conn.exec p ()) l in + match r with + | Error err -> + Fmt.failwith "Database preflight failure: %a." Caqti_error.pp err + | Ok () -> () let find_signkey = let req =