This commit is contained in:
parent
69755537f6
commit
8df2b129e8
7 changed files with 57 additions and 57 deletions
|
|
@ -1,4 +1,4 @@
|
||||||
let db_connection caqti_switch : (unit, Caqti_miou.connection) Vif.Device.device
|
let db_connection caqti_switch : (unit, Caqti_miou.connection) Vifu.Device.device
|
||||||
=
|
=
|
||||||
let f () =
|
let f () =
|
||||||
let db_uri = Config.Exchangedb_postgres.config in
|
let db_uri = Config.Exchangedb_postgres.config in
|
||||||
|
|
@ -14,7 +14,7 @@ let db_connection caqti_switch : (unit, Caqti_miou.connection) Vif.Device.device
|
||||||
conn)
|
conn)
|
||||||
in
|
in
|
||||||
let finally (module Conn : Caqti_miou.CONNECTION) = Conn.disconnect () in
|
let finally (module Conn : Caqti_miou.CONNECTION) = Conn.disconnect () in
|
||||||
Vif.Device.v ~name:"db_connection" ~finally [] f
|
Vifu.Device.v ~name:"db_connection" ~finally [] f
|
||||||
|
|
||||||
let keys storage =
|
let keys storage =
|
||||||
let f (module Conn : Pg.CONN) () =
|
let f (module Conn : Pg.CONN) () =
|
||||||
|
|
@ -27,4 +27,4 @@ let keys storage =
|
||||||
keys
|
keys
|
||||||
in
|
in
|
||||||
let finally _key = () in
|
let finally _key = () in
|
||||||
Vif.Device.v ~name:"keys" ~finally [ Vif.Device.value db_connection ] f
|
Vifu.Device.v ~name:"keys" ~finally [ Vifu.Device.value db_connection ] f
|
||||||
|
|
|
||||||
|
|
@ -9,7 +9,7 @@ let avail_languages_header_value =
|
||||||
(* TODO better headers_lib
|
(* TODO better headers_lib
|
||||||
Cohttp raises on invalid *)
|
Cohttp raises on invalid *)
|
||||||
let select_mimetype headers =
|
let select_mimetype headers =
|
||||||
let opt = Vif.Headers.get headers "accept" in
|
let opt = Vifu.Headers.get headers "accept" in
|
||||||
Cohttp.Accept.media_ranges opt
|
Cohttp.Accept.media_ranges opt
|
||||||
|> Cohttp.Accept.qsort
|
|> Cohttp.Accept.qsort
|
||||||
|> List.find_map (fun (_q, (m, _p)) -> Assets.Mimetype.of_cohttp m)
|
|> List.find_map (fun (_q, (m, _p)) -> Assets.Mimetype.of_cohttp m)
|
||||||
|
|
@ -18,7 +18,7 @@ let select_mimetype headers =
|
||||||
| Some mime -> mime
|
| Some mime -> mime
|
||||||
|
|
||||||
let select_language headers =
|
let select_language headers =
|
||||||
let opt = Vif.Headers.get headers "accept-language" in
|
let opt = Vifu.Headers.get headers "accept-language" in
|
||||||
Cohttp.Accept.languages opt
|
Cohttp.Accept.languages opt
|
||||||
|> Cohttp.Accept.qsort
|
|> Cohttp.Accept.qsort
|
||||||
|> List.map snd
|
|> List.map snd
|
||||||
|
|
@ -28,7 +28,7 @@ let select_language headers =
|
||||||
| Some lang -> lang
|
| Some lang -> lang
|
||||||
|
|
||||||
let select_encoding headers =
|
let select_encoding headers =
|
||||||
let opt = Vif.Headers.get headers "accept-encoding" in
|
let opt = Vifu.Headers.get headers "accept-encoding" in
|
||||||
Cohttp.Accept.encodings opt
|
Cohttp.Accept.encodings opt
|
||||||
|> Cohttp.Accept.qsort
|
|> Cohttp.Accept.qsort
|
||||||
|> List.map snd
|
|> List.map snd
|
||||||
|
|
|
||||||
14
src/mte.ml
14
src/mte.ml
|
|
@ -14,17 +14,17 @@
|
||||||
along with this program. If not, see <https://www.gnu.org/licenses/>. *)
|
along with this program. If not, see <https://www.gnu.org/licenses/>. *)
|
||||||
|
|
||||||
let hello req _server _env =
|
let hello req _server _env =
|
||||||
let open Vif.Response in
|
let open Vifu.Response in
|
||||||
let open Syntax in
|
let open Syntax in
|
||||||
let* () = with_string req "Hello~~\n" in
|
let* () = with_string req "Hello~~\n" in
|
||||||
let* () = add ~field:"content-type" "text/plain" in
|
let* () = add ~field:"content-type" "text/plain" in
|
||||||
respond `OK
|
respond `OK
|
||||||
|
|
||||||
let routes =
|
let routes =
|
||||||
let open Vif.Uri in
|
let open Vifu.Uri in
|
||||||
let open Vif.Route in
|
let open Vifu.Route in
|
||||||
let get path = get (path /?? any) in
|
let get path = get (path /?? any) in
|
||||||
let post path jsont = post (Vif.Type.json_encoding jsont) (path /?? any) in
|
let post path jsont = post (Vifu.Type.json_encoding jsont) (path /?? any) in
|
||||||
let v s = rel / s in
|
let v s = rel / s in
|
||||||
let tos =
|
let tos =
|
||||||
[
|
[
|
||||||
|
|
@ -133,9 +133,9 @@ let () =
|
||||||
let env : Devices.env =
|
let env : Devices.env =
|
||||||
{ caqti_switch; db_uri= Config.Exchangedb_postgres.config }
|
{ caqti_switch; db_uri= Config.Exchangedb_postgres.config }
|
||||||
in
|
in
|
||||||
let devices = Vif.Devices.[ Devices.db_connection; Devices.keys ] in
|
let devices = Vifu.Devices.[ Devices.db_connection; Devices.keys ] in
|
||||||
let middlewares = Vif.Middlewares.[] in
|
let middlewares = Vifu.Middlewares.[] in
|
||||||
Logs.info (fun m ->
|
Logs.info (fun m ->
|
||||||
m ~tags:(Util.Log_reporter.detail "...") "Starting MTE server");
|
m ~tags:(Util.Log_reporter.detail "...") "Starting MTE server");
|
||||||
Vif.run ~cfg ~devices ~middlewares routes env
|
Vifu.run ~cfg ~devices ~middlewares routes env
|
||||||
*)
|
*)
|
||||||
|
|
|
||||||
|
|
@ -7,9 +7,9 @@ module String_map = Stdlib.Map.Make (Stdlib.String)
|
||||||
maybe don't use the same RNG-initialization as the one used to generate keys *)
|
maybe don't use the same RNG-initialization as the one used to generate keys *)
|
||||||
let seed req _server _env =
|
let seed req _server _env =
|
||||||
Logs.info (fun m -> m "GET /seed");
|
Logs.info (fun m -> m "GET /seed");
|
||||||
(* RNG is initialized by Vif.run *)
|
(* RNG is initialized by Vifu.run *)
|
||||||
let s = Mirage_crypto_rng.generate 64 in
|
let s = Mirage_crypto_rng.generate 64 in
|
||||||
let open Vif.Response in
|
let open Vifu.Response in
|
||||||
let open Syntax in
|
let open Syntax in
|
||||||
let* () = add ~field:"content-type" "application/octet-stream" in
|
let* () = add ~field:"content-type" "application/octet-stream" in
|
||||||
let* () = with_string req s in
|
let* () = with_string req s in
|
||||||
|
|
@ -158,11 +158,11 @@ let jsont = ExchangeKeysResponse.jsont
|
||||||
|
|
||||||
let keys req server _env =
|
let keys req server _env =
|
||||||
Logs.info (fun m -> m "GET /keys");
|
Logs.info (fun m -> m "GET /keys");
|
||||||
let db_conn = Vif.Server.device Devices.db_connection server in
|
let db_conn = Vifu.Server.device Devices.db_connection server in
|
||||||
let keys = Vif.Server.device Devices.keys server in
|
let keys = Vifu.Server.device Devices.keys server in
|
||||||
let res =
|
let res =
|
||||||
let* last_issue_date =
|
let* last_issue_date =
|
||||||
match Vif.Queries.get req "last_issue_date" with
|
match Vifu.Queries.get req "last_issue_date" with
|
||||||
| [] -> Ok None
|
| [] -> Ok None
|
||||||
| s :: _ -> (
|
| s :: _ -> (
|
||||||
match Int64.of_string_opt s with
|
match Int64.of_string_opt s with
|
||||||
|
|
|
||||||
|
|
@ -7,7 +7,7 @@ module Keys_get = struct
|
||||||
|
|
||||||
let f req server _env =
|
let f req server _env =
|
||||||
Logs.info (fun m -> m "GET /management/keys/");
|
Logs.info (fun m -> m "GET /management/keys/");
|
||||||
let (module Keys : Keys.S) = Vif.Server.device Devices.keys server in
|
let (module Keys : Keys.S) = Vifu.Server.device Devices.keys server in
|
||||||
let res =
|
let res =
|
||||||
let* v = Keys.make_future_keys_response () in
|
let* v = Keys.make_future_keys_response () in
|
||||||
Api.encode jsont v
|
Api.encode jsont v
|
||||||
|
|
@ -31,9 +31,9 @@ module Keys_post = struct
|
||||||
|
|
||||||
let f req server _env =
|
let f req server _env =
|
||||||
Logs.info (fun m -> m "POST /management/keys/");
|
Logs.info (fun m -> m "POST /management/keys/");
|
||||||
let keys = Vif.Server.device Devices.keys server in
|
let keys = Vifu.Server.device Devices.keys server in
|
||||||
let res =
|
let res =
|
||||||
let* v = Vif.Request.of_json req |> unwrap_msg in
|
let* v = Vifu.Request.of_json req |> unwrap_msg in
|
||||||
let* () = verify keys v in
|
let* () = verify keys v in
|
||||||
let* () = do_ keys v in
|
let* () = do_ keys v in
|
||||||
Ok ()
|
Ok ()
|
||||||
|
|
@ -56,10 +56,10 @@ module Denom_revoke = struct
|
||||||
|
|
||||||
let f req h_denom_pub server _env =
|
let f req h_denom_pub server _env =
|
||||||
Logs.info (fun m -> m "POST /management/denominations/$H_DENOM_PUB/revoke/");
|
Logs.info (fun m -> m "POST /management/denominations/$H_DENOM_PUB/revoke/");
|
||||||
let keys = Vif.Server.device Devices.keys server in
|
let keys = Vifu.Server.device Devices.keys server in
|
||||||
let res =
|
let res =
|
||||||
let* h_denom_pub = Crypto.DenominationHash.of_b32 h_denom_pub in
|
let* h_denom_pub = Crypto.DenominationHash.of_b32 h_denom_pub in
|
||||||
let* v = Vif.Request.of_json req |> unwrap_msg in
|
let* v = Vifu.Request.of_json req |> unwrap_msg in
|
||||||
let* () = verify keys h_denom_pub v in
|
let* () = verify keys h_denom_pub v in
|
||||||
let* () = do_ keys h_denom_pub v in
|
let* () = do_ keys h_denom_pub v in
|
||||||
Ok ()
|
Ok ()
|
||||||
|
|
@ -82,10 +82,10 @@ module Signkey_revoke = struct
|
||||||
|
|
||||||
let f req exchange_pub server _env =
|
let f req exchange_pub server _env =
|
||||||
Logs.info (fun m -> m "POST /management/signkeys/$EXCHANGE_PUB/revoke/");
|
Logs.info (fun m -> m "POST /management/signkeys/$EXCHANGE_PUB/revoke/");
|
||||||
let keys = Vif.Server.device Devices.keys server in
|
let keys = Vifu.Server.device Devices.keys server in
|
||||||
let res =
|
let res =
|
||||||
let* exchange_pub = Crypto.EddsaPublicKey.of_b32 exchange_pub in
|
let* exchange_pub = Crypto.EddsaPublicKey.of_b32 exchange_pub in
|
||||||
let* v = Vif.Request.of_json req |> unwrap_msg in
|
let* v = Vifu.Request.of_json req |> unwrap_msg in
|
||||||
let* () = verify keys exchange_pub v in
|
let* () = verify keys exchange_pub v in
|
||||||
let* () = do_ keys exchange_pub v in
|
let* () = do_ keys exchange_pub v in
|
||||||
Ok ()
|
Ok ()
|
||||||
|
|
@ -133,10 +133,10 @@ module Auditors = struct
|
||||||
|
|
||||||
let f req server _env =
|
let f req server _env =
|
||||||
Logs.info (fun m -> m "POST /management/auditors/");
|
Logs.info (fun m -> m "POST /management/auditors/");
|
||||||
let keys = Vif.Server.device Devices.keys server in
|
let keys = Vifu.Server.device Devices.keys server in
|
||||||
let db_conn = Vif.Server.device Devices.db_connection server in
|
let db_conn = Vifu.Server.device Devices.db_connection server in
|
||||||
let res =
|
let res =
|
||||||
let* v = Vif.Request.of_json req |> unwrap_msg in
|
let* v = Vifu.Request.of_json req |> unwrap_msg in
|
||||||
let* () = verify keys v in
|
let* () = verify keys v in
|
||||||
let* () = do_ ~db_conn v in
|
let* () = do_ ~db_conn v in
|
||||||
Ok ()
|
Ok ()
|
||||||
|
|
@ -178,11 +178,11 @@ module Auditors_disable = struct
|
||||||
|
|
||||||
let f req auditor_pub server _env =
|
let f req auditor_pub server _env =
|
||||||
Logs.info (fun m -> m "POST /management/auditors/$AUDITOR_PUB/disable/");
|
Logs.info (fun m -> m "POST /management/auditors/$AUDITOR_PUB/disable/");
|
||||||
let keys = Vif.Server.device Devices.keys server in
|
let keys = Vifu.Server.device Devices.keys server in
|
||||||
let db_conn = Vif.Server.device Devices.db_connection server in
|
let db_conn = Vifu.Server.device Devices.db_connection server in
|
||||||
let res =
|
let res =
|
||||||
let* auditor_pub = Crypto.EddsaPublicKey.of_b32 auditor_pub in
|
let* auditor_pub = Crypto.EddsaPublicKey.of_b32 auditor_pub in
|
||||||
let* v = Vif.Request.of_json req |> unwrap_msg in
|
let* v = Vifu.Request.of_json req |> unwrap_msg in
|
||||||
let* () = verify keys auditor_pub v in
|
let* () = verify keys auditor_pub v in
|
||||||
let* () = do_ ~db_conn auditor_pub v in
|
let* () = do_ ~db_conn auditor_pub v in
|
||||||
Ok ()
|
Ok ()
|
||||||
|
|
@ -238,10 +238,10 @@ module Wire_fee = struct
|
||||||
|
|
||||||
let f req server _env =
|
let f req server _env =
|
||||||
Logs.info (fun m -> m "POST /management/wire-fee/");
|
Logs.info (fun m -> m "POST /management/wire-fee/");
|
||||||
let keys = Vif.Server.device Devices.keys server in
|
let keys = Vifu.Server.device Devices.keys server in
|
||||||
let db_conn = Vif.Server.device Devices.db_connection server in
|
let db_conn = Vifu.Server.device Devices.db_connection server in
|
||||||
let res =
|
let res =
|
||||||
let* v = Vif.Request.of_json req |> unwrap_msg in
|
let* v = Vifu.Request.of_json req |> unwrap_msg in
|
||||||
let* () = verify keys v in
|
let* () = verify keys v in
|
||||||
let* () = do_ ~db_conn v in
|
let* () = do_ ~db_conn v in
|
||||||
Ok ()
|
Ok ()
|
||||||
|
|
@ -284,9 +284,9 @@ module Global_fees = struct
|
||||||
and once set for a timeframe, it should not change. *)
|
and once set for a timeframe, it should not change. *)
|
||||||
let f req server _env =
|
let f req server _env =
|
||||||
Logs.info (fun m -> m "POST /management/global-fees/");
|
Logs.info (fun m -> m "POST /management/global-fees/");
|
||||||
let db_conn = Vif.Server.device Devices.db_connection server in
|
let db_conn = Vifu.Server.device Devices.db_connection server in
|
||||||
let res =
|
let res =
|
||||||
let* v = Vif.Request.of_json req |> unwrap_msg in
|
let* v = Vifu.Request.of_json req |> unwrap_msg in
|
||||||
let* () = verify v in
|
let* () = verify v in
|
||||||
let* () = do_ ~db_conn v in
|
let* () = do_ ~db_conn v in
|
||||||
Ok ()
|
Ok ()
|
||||||
|
|
@ -399,10 +399,10 @@ module Wire = struct
|
||||||
|
|
||||||
let f req server _env =
|
let f req server _env =
|
||||||
Logs.info (fun m -> m "POST /management/wire/");
|
Logs.info (fun m -> m "POST /management/wire/");
|
||||||
let keys = Vif.Server.device Devices.keys server in
|
let keys = Vifu.Server.device Devices.keys server in
|
||||||
let db_conn = Vif.Server.device Devices.db_connection server in
|
let db_conn = Vifu.Server.device Devices.db_connection server in
|
||||||
let res =
|
let res =
|
||||||
let* v = Vif.Request.of_json req |> unwrap_msg in
|
let* v = Vifu.Request.of_json req |> unwrap_msg in
|
||||||
let* () = verify keys v in
|
let* () = verify keys v in
|
||||||
let* () = do_ ~db_conn v in
|
let* () = do_ ~db_conn v in
|
||||||
Ok ()
|
Ok ()
|
||||||
|
|
@ -438,10 +438,10 @@ module Wire_disable = struct
|
||||||
|
|
||||||
let f req server _env =
|
let f req server _env =
|
||||||
Logs.info (fun m -> m "POST /management/wire/disable/");
|
Logs.info (fun m -> m "POST /management/wire/disable/");
|
||||||
let keys = Vif.Server.device Devices.keys server in
|
let keys = Vifu.Server.device Devices.keys server in
|
||||||
let db_conn = Vif.Server.device Devices.db_connection server in
|
let db_conn = Vifu.Server.device Devices.db_connection server in
|
||||||
let res =
|
let res =
|
||||||
let* v = Vif.Request.of_json req |> unwrap_msg in
|
let* v = Vifu.Request.of_json req |> unwrap_msg in
|
||||||
let* () = verify keys v in
|
let* () = verify keys v in
|
||||||
let* () = do_ ~db_conn v in
|
let* () = do_ ~db_conn v in
|
||||||
Ok ()
|
Ok ()
|
||||||
|
|
@ -487,10 +487,10 @@ module Drain = struct
|
||||||
|
|
||||||
let f req server _env =
|
let f req server _env =
|
||||||
Logs.info (fun m -> m "POST /management/drain/");
|
Logs.info (fun m -> m "POST /management/drain/");
|
||||||
let keys = Vif.Server.device Devices.keys server in
|
let keys = Vifu.Server.device Devices.keys server in
|
||||||
let db_conn = Vif.Server.device Devices.db_connection server in
|
let db_conn = Vifu.Server.device Devices.db_connection server in
|
||||||
let res =
|
let res =
|
||||||
let* v = Vif.Request.of_json req |> unwrap_msg in
|
let* v = Vifu.Request.of_json req |> unwrap_msg in
|
||||||
let* () = verify keys v in
|
let* () = verify keys v in
|
||||||
let* () = do_ ~db_conn v in
|
let* () = do_ ~db_conn v in
|
||||||
Ok ()
|
Ok ()
|
||||||
|
|
@ -527,10 +527,10 @@ module AmlOfficer = struct
|
||||||
|
|
||||||
let f req server _env =
|
let f req server _env =
|
||||||
Logs.info (fun m -> m "POST /management/aml-officers/");
|
Logs.info (fun m -> m "POST /management/aml-officers/");
|
||||||
let keys = Vif.Server.device Devices.keys server in
|
let keys = Vifu.Server.device Devices.keys server in
|
||||||
let db_conn = Vif.Server.device Devices.db_connection server in
|
let db_conn = Vifu.Server.device Devices.db_connection server in
|
||||||
let res =
|
let res =
|
||||||
let* v = Vif.Request.of_json req |> unwrap_msg in
|
let* v = Vifu.Request.of_json req |> unwrap_msg in
|
||||||
let* () = verify keys v in
|
let* () = verify keys v in
|
||||||
let* () = do_ ~db_conn v in
|
let* () = do_ ~db_conn v in
|
||||||
Ok ()
|
Ok ()
|
||||||
|
|
@ -569,10 +569,10 @@ module Partners = struct
|
||||||
|
|
||||||
let f req server _env =
|
let f req server _env =
|
||||||
Logs.info (fun m -> m "POST /management/partners/");
|
Logs.info (fun m -> m "POST /management/partners/");
|
||||||
let keys = Vif.Server.device Devices.keys server in
|
let keys = Vifu.Server.device Devices.keys server in
|
||||||
let db_conn = Vif.Server.device Devices.db_connection server in
|
let db_conn = Vifu.Server.device Devices.db_connection server in
|
||||||
let res =
|
let res =
|
||||||
let* v = Vif.Request.of_json req |> unwrap_msg in
|
let* v = Vifu.Request.of_json req |> unwrap_msg in
|
||||||
let* () = verify keys v in
|
let* () = verify keys v in
|
||||||
let* () = do_ ~db_conn v in
|
let* () = do_ ~db_conn v in
|
||||||
Ok ()
|
Ok ()
|
||||||
|
|
|
||||||
|
|
@ -2,9 +2,9 @@
|
||||||
|
|
||||||
let aux asset req _server _env =
|
let aux asset req _server _env =
|
||||||
let etag = Assets.etag asset in
|
let etag = Assets.etag asset in
|
||||||
let headers = Vif.Request.headers req in
|
let headers = Vifu.Request.headers req in
|
||||||
let has_matching_etag =
|
let has_matching_etag =
|
||||||
match Vif.Headers.get headers "if-none-match" with
|
match Vifu.Headers.get headers "if-none-match" with
|
||||||
| None -> Ok false
|
| None -> Ok false
|
||||||
| Some s ->
|
| Some s ->
|
||||||
Headers_lib.If_none_match.parse s
|
Headers_lib.If_none_match.parse s
|
||||||
|
|
@ -19,7 +19,7 @@ let aux asset req _server _env =
|
||||||
let compression = Headers.select_encoding headers in
|
let compression = Headers.select_encoding headers in
|
||||||
let data = Assets.get_content ~mime ~lang asset in
|
let data = Assets.get_content ~mime ~lang asset in
|
||||||
(* -- *)
|
(* -- *)
|
||||||
let open Vif.Response in
|
let open Vifu.Response in
|
||||||
let open Syntax in
|
let open Syntax in
|
||||||
let* () = with_string ?compression req data in
|
let* () = with_string ?compression req data in
|
||||||
let* () =
|
let* () =
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,7 @@ let encode_error_detail err =
|
||||||
| Ok s -> s
|
| Ok s -> s
|
||||||
|
|
||||||
let respond_json req content status =
|
let respond_json req content status =
|
||||||
let open Vif.Response in
|
let open Vifu.Response in
|
||||||
let open Syntax in
|
let open Syntax in
|
||||||
let* () = add ~field:"content-type" "application/json" in
|
let* () = add ~field:"content-type" "application/json" in
|
||||||
let* () = with_string req content in
|
let* () = with_string req content in
|
||||||
|
|
@ -32,14 +32,14 @@ let ok content req =
|
||||||
|
|
||||||
let no_content () =
|
let no_content () =
|
||||||
Logs.debug (fun m -> m "no content");
|
Logs.debug (fun m -> m "no content");
|
||||||
let open Vif.Response in
|
let open Vifu.Response in
|
||||||
let open Syntax in
|
let open Syntax in
|
||||||
let* () = empty in
|
let* () = empty in
|
||||||
respond `No_content
|
respond `No_content
|
||||||
|
|
||||||
let not_modified () =
|
let not_modified () =
|
||||||
Logs.debug (fun m -> m "not modified");
|
Logs.debug (fun m -> m "not modified");
|
||||||
let open Vif.Response in
|
let open Vifu.Response in
|
||||||
let open Syntax in
|
let open Syntax in
|
||||||
let* () = empty in
|
let* () = empty in
|
||||||
respond `Not_modified
|
respond `Not_modified
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue