From add6fc0e37dd0e6b8776766467507a68c1ec0522 Mon Sep 17 00:00:00 2001 From: swrup Date: Sat, 22 Nov 2025 21:40:24 +0100 Subject: [PATCH] --- src/database.ml | 33 ++++++++++++++---- src/devices.ml | 18 +++++----- src/mte.ml | 5 +-- src/pg.ml | 93 +++++++++++++++++++++++++++++-------------------- 4 files changed, 94 insertions(+), 55 deletions(-) diff --git a/src/database.ml b/src/database.ml index b4121bcc..bb37ed21 100644 --- a/src/database.ml +++ b/src/database.ml @@ -1,17 +1,16 @@ (* TODO - - pg.ml - - preflight - GNU Taler db-events? - https://git.gnunet.org/gana.git/tree/gnu-taler-db-events/registry.rec *) + it seems caqti/pgx does not support it *) let test req server _ = - let pool = Vif.Server.device Devices.caqti server in + let (module Conn : Caqti_miou.CONNECTION) = + Vif.Server.device Devices.db_connection server + in let query = let open Caqti_request.Infix in Caqti_type.(unit ->! int) "SELECT 53 - 11" in - let fn (module Conn : Caqti_miou.CONNECTION) = Conn.find query () in - match Caqti_miou_unix.Pool.use fn pool with + match Conn.find query () with | Ok n -> let open Vif.Response.Syntax in let* () = @@ -26,4 +25,24 @@ let test req server _ = let* () = Vif.Response.with_string req str in Vif.Response.respond `Internal_server_error -let init = test +let test_activate req server _ = + (*let (module Conn : Caqti_miou.CONNECTION) =*) + let db_conn = Vif.Server.device Devices.db_connection server in + let secmod_signkey = Vif.Server.device Devices.secmod_signkey server in + let exchange_public_key = secmod_signkey.sm_key in + match Pg.activate_signing_key db_conn exchange_public_key with + | Ok () -> + let open Vif.Response.Syntax in + let* () = + Vif.Response.add ~field:"content-type" "text/plain; charset= utf-8" + in + let* () = + Vif.Response.with_string req (Fmt.str "activate_signing_key done~~@.") + in + Vif.Response.respond `OK + | Error err -> + (* TODO don't leak private data in error messages *) + let open Vif.Response.Syntax in + let str = Fmt.str "Database error: %a." Caqti_error.pp err in + let* () = Vif.Response.with_string req str in + Vif.Response.respond `Internal_server_error diff --git a/src/devices.ml b/src/devices.ml index 5053eada..673a8113 100644 --- a/src/devices.ml +++ b/src/devices.ml @@ -36,13 +36,15 @@ end let secmod_signkey = Secmod_signkey.v let secmod_denom = Secmod_denom.v -let caqti : - ( env, - (Caqti_miou.connection, Caqti_error.t) Caqti_miou_unix.Pool.t ) - Vif.Device.device = - let finally pool = Caqti_miou_unix.Pool.drain pool in - Vif.Device.v ~name:"caqti" ~finally [] @@ fun { caqti_switch; db_uri } -> - match Caqti_miou_unix.connect_pool ~sw:caqti_switch db_uri with +let db_connection : (env, Caqti_miou.connection) Vif.Device.device = + let finally (module Conn : Caqti_miou.CONNECTION) = Conn.disconnect () in + Vif.Device.v ~name:"db_connection" ~finally [] + @@ fun { caqti_switch; db_uri } -> + match Caqti_miou_unix.connect ~sw:caqti_switch db_uri with | Error err -> Fmt.failwith "Database connection failure: %a." Caqti_error.pp err - | Ok pool -> pool + | Ok conn -> ( + match Pg.preflight conn with + | Error err -> + Fmt.failwith "Database preflight failure: %a." Caqti_error.pp err + | Ok () -> conn) diff --git a/src/mte.ml b/src/mte.ml index b7e7e153..ee5d2591 100644 --- a/src/mte.ml +++ b/src/mte.ml @@ -113,7 +113,7 @@ let routes = get (rel / "privacy" /?? nil) --> Static.privacy; get (rel / "management" / "keys" /?? nil) --> Management.keys; get (rel / "db_test" /?? nil) --> Database.test; - get (rel / "db_init" /?? nil) --> Database.init; + get (rel / "db_activate" /?? nil) --> Database.test_activate; ] let () = @@ -129,7 +129,8 @@ let () = in let devices = (* todo: rm unneeded env parameter from secmod devices *) - Vif.Devices.[ Devices.secmod_signkey; Devices.secmod_denom; Devices.caqti ] + Vif.Devices. + [ Devices.secmod_signkey; Devices.secmod_denom; Devices.db_connection ] in let middlewares = Vif.Middlewares.[] in Vif.run ~cfg ~devices ~middlewares routes env diff --git a/src/pg.ml b/src/pg.ml index c38a0fd9..0e2f5b45 100644 --- a/src/pg.ml +++ b/src/pg.ml @@ -1,59 +1,75 @@ +type pool = (Caqti_miou.connection, Caqti_error.t) Caqti_miou_unix.Pool.t (* TODO be sure to not use postgres ptime add a dune stanza like for prelude: "(flags (:standard -open Prelude))" *) + +open Crypto + module Caqti_type = struct include Caqti_type (* we want to use int64 timestamps, not postgresql built-in timestamp type *) - let ptime : Ptime.t Caqti_type.t = + let ptime : Ptime.t t = let encode i = Ok (Util.ptime_to_int64 i) in let decode = Util.ptime_of_int64 in - Caqti_type.custom ~encode ~decode Caqti_type.(int64) + custom ~encode ~decode int64 + + let amount : Amount.t t = + let open Amount in + custom + ~encode:(fun amount -> Ok (amount.value, amount.fraction)) + ~decode:(fun (value, fraction) -> + Amount.make ~sign:None ~currency:Config.currency ~value ~fraction) + (t2 int64 int32) + + let eddsa_public : EddsaPublicKey.t t = + let open EddsaPublicKey in + custom + ~encode:(fun v -> Ok (to_octets v)) + ~decode:(fun v -> Ok (of_octets v)) + octets + + let eddsa_signature : EddsaSignature.t t = + let open EddsaSignature in + custom + ~encode:(fun v -> Ok (to_octets v)) + ~decode:(fun s -> Ok (of_octets s)) + octets + + include Caqti_request.Infix end -open Crypto -(*open Bin_type*) - -let amount_t : Amount.t Caqti_type.t = - let open Amount in - Caqti_type.custom - ~encode:(fun amount -> Ok (amount.value, amount.fraction)) - ~decode:(fun (value, fraction) -> - Amount.make ~sign:None ~currency:Config.currency ~value ~fraction) - Caqti_type.(t2 int64 int32) - -let eddsa_signature_t : EddsaSignature.t Caqti_type.t = - let open EddsaSignature in - Caqti_type.custom - ~encode:(fun master_sig -> Ok (to_octets master_sig)) - ~decode:(fun s -> Ok (of_octets s)) - Caqti_type.octets - (* WIP: minimum db functions for basic /management *) -let pg_todo () = assert false - -open Caqti_request.Infix - -(* signkey *) -(* todo: - - what type to use for TALER_ExchangePublicKeyP + TALER_EXCHANGEDB_SignkeyMetaData - -> I think it could be something = to FutureSignKey.t - - master signature: over smthing? *) -let activate_signing_key _cls (exchange_public_key : Signkey.t) = - (*let open Bin_type in*) - let _exchange_pub = EddsaPublicKey.(to_octets exchange_public_key.pub) in - let _master_sig = - exchange_public_key.master_sig |> Option.get - (*|> EddsaSignature.to_octets*) +let preflight = + let l = + List.map + Caqti_type.(unit ->. unit) + [ + "SET SESSION CHARACTERISTICS AS TRANSACTION ISOLATION LEVEL \ + SERIALIZABLE;"; "SET enable_sort=OFF;"; "SET enable_seqscan=OFF;"; + "SET enable_mergejoin=OFF;"; "SET search_path TO exchange;"; + ] in - let _insert_signkey = - Caqti_type.(t5 string ptime ptime ptime string ->! int) + fun (module Conn : Caqti_miou.CONNECTION) -> + Syntax.list_iter (fun p -> Conn.exec p ()) l + +let activate_signing_key = + let insert_signkey = + Caqti_type.(t5 eddsa_public ptime ptime ptime eddsa_signature ->. unit) "INSERT INTO exchange_sign_keys (exchange_pub, valid_from, expire_sign, \ expire_legal, master_sig) VALUES ($1, $2, $3, $4, $5);" in - pg_todo () + fun (module Conn : Caqti_miou.CONNECTION) (exchange_public_key : Signkey.t) -> + let exchange_pub = exchange_public_key.pub in + let valid_from = exchange_public_key.stamp_start in + let expire_sign = exchange_public_key.stamp_expire in + let expire_legal = exchange_public_key.stamp_end in + (*let master_sig = exchange_public_key.master_sig |> Option.get in*) + let master_sig = EddsaSignature.of_octets (String.make 64 'x') in + Conn.exec insert_signkey + (exchange_pub, valid_from, expire_sign, expire_legal, master_sig) (* @@ -78,6 +94,7 @@ TEH_PG_activate_signing_key ( (* ----- *) +let pg_todo () = assert false let lookup_signing_key = pg_todo let iterate_active_signkeys = pg_todo let insert_signkey_revocation = pg_todo