Created
March 19, 2026 08:10
-
-
Save divarvel/7f388f517a52a40f95db78421edbc4c2 to your computer and use it in GitHub Desktop.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| open Vif | |
| module Reduction = struct | |
| type t = Standard | |
| let assoc = [ ("STANDARD", Standard) ] | |
| let jsont = Jsont.enum ~kind:"Reduction" assoc | |
| end | |
| module Country = struct | |
| type t = | |
| | DE | |
| | UK | |
| | FR | |
| | IT | |
| | ES | |
| | PL | |
| | RO | |
| | NL | |
| | BE | |
| | EL | |
| | CZ | |
| | PT | |
| | HU | |
| | SE | |
| | AT | |
| | BG | |
| | DK | |
| | FI | |
| | SK | |
| | IE | |
| | HR | |
| | LT | |
| | SI | |
| | LV | |
| | EE | |
| | CY | |
| | LU | |
| | MT | |
| let assoc = | |
| [ | |
| ("DE", DE); | |
| ("UK", UK); | |
| ("FR", FR); | |
| ("IT", IT); | |
| ("ES", ES); | |
| ("PL", PL); | |
| ("RO", RO); | |
| ("NL", NL); | |
| ("BE", BE); | |
| ("EL", EL); | |
| ("CZ", CZ); | |
| ("PT", PT); | |
| ("HU", HU); | |
| ("SE", SE); | |
| ("AT", AT); | |
| ("BG", BG); | |
| ("DK", DK); | |
| ("FI", FI); | |
| ("SK", SK); | |
| ("IE", IE); | |
| ("HR", HR); | |
| ("LT", LT); | |
| ("SI", SI); | |
| ("LV", LV); | |
| ("EE", EE); | |
| ("CY", CY); | |
| ("LU", LU); | |
| ("MT", MT); | |
| ] | |
| let jsont = Jsont.enum ~kind:"Country" assoc | |
| end | |
| module Input = struct | |
| type t = { | |
| prices : float list; | |
| quantities : int list; | |
| country : Country.t; | |
| reduction : Reduction.t; | |
| } | |
| let make prices quantities country reduction = | |
| { prices; quantities; country; reduction } | |
| let prices i = i.prices | |
| let quantities i = i.quantities | |
| let country i = i.country | |
| let reduction i = i.reduction | |
| let jsont = | |
| Jsont.Object.map ~kind:"Input" make | |
| |> Jsont.Object.mem "prices" Jsont.(list number) ~enc:prices | |
| |> Jsont.Object.mem "quantities" Jsont.(list int) ~enc:quantities | |
| |> Jsont.Object.mem "country" Country.jsont ~enc:country | |
| |> Jsont.Object.mem "reduction" Reduction.jsont ~enc:reduction | |
| |> Jsont.Object.finish | |
| end | |
| module Output = struct | |
| type t = { total : float } | |
| let jsont = | |
| Jsont.Object.map ~kind:"Output" (fun total -> { total }) | |
| |> Jsont.Object.mem "total" Jsont.number ~enc:(fun { total } -> total) | |
| |> Jsont.Object.finish | |
| end | |
| module Feedback = struct | |
| type t = { content : string } | |
| let jsont = | |
| Jsont.Object.map ~kind:"Feedback" (fun content -> { content }) | |
| |> Jsont.Object.mem "content" Jsont.string ~enc:(fun { content } -> content) | |
| |> Jsont.Object.finish | |
| end | |
| let apply_tax (country : Country.t) base = | |
| base | |
| *. | |
| match country with | |
| | Country.DE -> 1.20 | |
| | Country.UK -> 1.21 | |
| | Country.FR -> 1.20 | |
| | Country.IT -> 1.25 | |
| | Country.ES -> 1.19 | |
| | Country.PL -> 1.21 | |
| | Country.RO -> 1.20 | |
| | Country.NL -> 1.20 | |
| | Country.BE -> 1.24 | |
| | Country.EL -> 1.20 | |
| | Country.CZ -> 1.19 | |
| | Country.PT -> 1.23 | |
| | Country.HU -> 1.27 | |
| | Country.SE -> 1.23 | |
| | Country.AT -> 1.22 | |
| | Country.BG -> 1.21 | |
| | Country.DK -> 1.21 | |
| | Country.FI -> 1.17 | |
| | Country.SK -> 1.18 | |
| | Country.IE -> 1.21 | |
| | Country.HR -> 1.23 | |
| | Country.LT -> 1.23 | |
| | Country.SI -> 1.24 | |
| | Country.LV -> 1.20 | |
| | Country.EE -> 1.22 | |
| | Country.CY -> 1.21 | |
| | Country.LU -> 1.25 | |
| | Country.MT -> 1.20 | |
| let get_standard_rate p = | |
| match p with | |
| | _ when p >= 50000.0 -> 0.15 | |
| | _ when p >= 10000.0 -> 0.10 | |
| | _ when p >= 7000.0 -> 0.07 | |
| | _ when p >= 5000.0 -> 0.05 | |
| | _ when p >= 1000.0 -> 0.03 | |
| | _ -> 0.0 | |
| let apply_reduction (reduction : Reduction.t) (p : float) : float = | |
| let rate = match reduction with Reduction.Standard -> get_standard_rate p in | |
| p *. (1.0 -. rate) | |
| let compute ({ prices; quantities; country; reduction } : Input.t) : | |
| float = | |
| let base = | |
| List.fold_left2 | |
| (fun s p q -> s +. (p *. float_of_int q)) | |
| 0.0 prices quantities | |
| in | |
| let after_tax = apply_tax country base in | |
| let after_reduction = apply_reduction reduction after_tax in | |
| after_reduction *. 100.0 |> Float.round |> fun x -> | |
| x /. 100.0 | |
| let compute_taxes req _server () = | |
| let open Vif.Response.Syntax in | |
| match Vif.Request.of_json req with | |
| | Ok (input : Input.t) -> ( | |
| match compute input with | |
| | total -> | |
| let* () = Vif.Response.with_json req Output.jsont { total } in | |
| Vif.Response.respond `OK | |
| | exception _ -> | |
| let* () = Vif.Response.with_string req "bad request" in | |
| Vif.Response.respond (`Code 400)) | |
| | Error (`Msg msg) -> | |
| Logs.err (fun m -> m "Invalid JSON: %s" msg); | |
| let* () = | |
| Vif.Response.add ~field:"content-type" "text/plain; charset=utf-8" | |
| in | |
| let* () = Vif.Response.with_string req msg in | |
| Vif.Response.respond (`Code 400) | |
| let feedback req _server () = | |
| let open Vif.Response.Syntax in | |
| match Vif.Request.of_json req with | |
| | Ok (input : Feedback.t) -> | |
| let () = print_endline input.content in | |
| let* () = Vif.Response.with_string req "OK" in | |
| Vif.Response.respond `OK | |
| | Error (`Msg msg) -> | |
| Logs.err (fun m -> m "Invalid JSON: %s" msg); | |
| let* () = | |
| Vif.Response.add ~field:"content-type" "text/plain; charset=utf-8" | |
| in | |
| let* () = Vif.Response.with_string req msg in | |
| Vif.Response.respond (`Code 400) | |
| let routes = | |
| let open Vif.Uri in | |
| let open Vif.Route in | |
| let open Vif.Type in | |
| [ | |
| post (json_encoding Input.jsont) (rel / "order" /?? nil) --> compute_taxes; | |
| post (json_encoding Feedback.jsont) (rel / "feedback" /?? nil) --> feedback; | |
| ] | |
| let log = | |
| Vif.Middlewares.v ~name:"log" @@ fun req _target _server _ -> | |
| let () = print_endline (Vif.Request.target_of_request req) in | |
| None | |
| let middlewares = Vif.Middlewares.[ log ] | |
| let () = Miou_unix.run @@ fun () -> Vif.run ~middlewares routes () |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment