diff options
Diffstat (limited to 'lib/cepis.ml')
| -rw-r--r-- | lib/cepis.ml | 539 |
1 files changed, 539 insertions, 0 deletions
diff --git a/lib/cepis.ml b/lib/cepis.ml new file mode 100644 index 0000000..a168d37 --- /dev/null +++ b/lib/cepis.ml @@ -0,0 +1,539 @@ +let version = "0.1.0" +let default_url = "https://cep.is" +let max_batch = 500 + +type geo = { lat : float; lon : float; raio_m : int; precisao : string } + +let is_precise g = String.equal g.precisao "logradouro" + +type address = { + cep : string; + logradouro : string; + complemento : string; + unidade : string; + bairro : string; + localidade : string; + uf : string; + estado : string; + regiao : string; + ibge : string; + gia : string; + ddd : string; + siafi : string; + geo : geo option; + raw : (string * Yojson.Safe.t) list; +} + +let formatted_cep a = + if String.length a.cep = 8 then + String.sub a.cep 0 5 ^ "-" ^ String.sub a.cep 5 3 + else a.cep + +type health = { + status : string; + dne : string; + ceps : int; + geo : int; + base_gerada_em : string; +} + +let is_ok h = String.equal h.status "ok" + +type error = + | Invalid_cep of string + | Cep_not_found of string + | Rate_limited of { message : string; retry_after : float option } + | Server_error of { message : string; status : int } + | Network_error of string + | Invalid_response of string + +let error_message = function + | Invalid_cep m | Cep_not_found m | Network_error m | Invalid_response m -> m + | Rate_limited { message; _ } | Server_error { message; _ } -> message + +let string_of_error = function + | Invalid_cep m -> "invalid CEP: " ^ m + | Cep_not_found m -> "CEP not found: " ^ m + | Rate_limited { message; retry_after = Some s } -> + Printf.sprintf "rate limited (retry after %gs): %s" s message + | Rate_limited { message; retry_after = None } -> "rate limited: " ^ message + | Server_error { message; status } -> + Printf.sprintf "server error (%d): %s" status message + | Network_error m -> "network error: " ^ m + | Invalid_response m -> "invalid response: " ^ m + +let is_digit c = c >= '0' && c <= '9' + +let normalize_cep value = + let buf = Buffer.create 8 in + String.iter + (fun c -> match c with '-' | '.' | ' ' -> () | c -> Buffer.add_char buf c) + (String.trim value); + let cleaned = Buffer.contents buf in + let ok = + String.length cleaned = 8 && String.for_all (fun c -> is_digit c) cleaned + in + if ok then Ok cleaned + else Error (Invalid_cep (Printf.sprintf "CEP must be 8 digits, got %S" value)) + +let json_to_string = function + | `String s -> s + | `Int i -> string_of_int i + | `Intlit s -> s + | `Float f -> + if Float.is_integer f then Printf.sprintf "%.0f" f + else Printf.sprintf "%g" f + | `Bool b -> string_of_bool b + | _ -> "" + +let json_to_float = function + | `Int i -> Some (float_of_int i) + | `Float f -> Some f + | `Intlit s | `String s -> float_of_string_opt s + | _ -> None + +let field fields key = + match List.assoc_opt key fields with Some v -> v | None -> `Null + +let string_field fields key = json_to_string (field fields key) + +let int_field fields key = + match field fields key with + | `Int i -> i + | `Float f -> int_of_float f + | `Intlit s | `String s -> ( + match int_of_string_opt s with Some i -> i | None -> 0) + | _ -> 0 + +let geo_of_json = function + | `Assoc fields -> ( + match + ( json_to_float (field fields "lat"), + json_to_float (field fields "lon"), + json_to_float (field fields "raio_m"), + field fields "precisao" ) + with + | Some lat, Some lon, Some raio_m, ((`String _ | `Int _ | `Float _) as p) + -> + Some + { + lat; + lon; + raio_m = int_of_float raio_m; + precisao = json_to_string p; + } + | _ -> None) + | _ -> None + +let address_of_fields fields = + { + cep = string_field fields "cep"; + logradouro = string_field fields "logradouro"; + complemento = string_field fields "complemento"; + unidade = string_field fields "unidade"; + bairro = string_field fields "bairro"; + localidade = string_field fields "localidade"; + uf = string_field fields "uf"; + estado = string_field fields "estado"; + regiao = string_field fields "regiao"; + ibge = string_field fields "ibge"; + gia = string_field fields "gia"; + ddd = string_field fields "ddd"; + siafi = string_field fields "siafi"; + geo = geo_of_json (field fields "geo"); + raw = fields; + } + +let health_of_fields fields = + { + status = string_field fields "status"; + dne = string_field fields "dne"; + ceps = int_field fields "ceps"; + geo = int_field fields "geo"; + base_gerada_em = string_field fields "base_gerada_em"; + } + +let json_kind = function + | `Assoc _ -> "object" + | `List _ -> "array" + | `String _ -> "string" + | `Int _ | `Intlit _ -> "int" + | `Float _ -> "float" + | `Bool _ -> "bool" + | `Null -> "null" + | _ -> "value" + +let truncate_body body = + if String.length body <= 120 then body else String.sub body 0 120 ^ "..." + +let json_object_of_body body = + match Yojson.Safe.from_string body with + | `Assoc fields -> Ok fields + | other -> + Error + (Invalid_response + (Printf.sprintf "expected a JSON object, got %s" (json_kind other))) + | exception _ -> + Error + (Invalid_response + (Printf.sprintf + "response is not valid JSON — something between you and the API \ + is answering instead of it: %S" + (truncate_body body))) + +let api_message body fallback = + match Yojson.Safe.from_string body with + | `Assoc fields -> ( + match field fields "mensagem" with + | `String m when m <> "" -> m + | _ -> fallback) + | _ -> fallback + | exception _ -> fallback + +let months = + [| + "jan"; + "feb"; + "mar"; + "apr"; + "may"; + "jun"; + "jul"; + "aug"; + "sep"; + "oct"; + "nov"; + "dec"; + |] + +let month_index name = + let name = String.lowercase_ascii name in + let name = if String.length name > 3 then String.sub name 0 3 else name in + let found = ref None in + Array.iteri + (fun i m -> if String.equal m name then found := Some (i + 1)) + months; + !found + +let days_from_civil y m d = + let y = if m <= 2 then y - 1 else y in + let era = (if y >= 0 then y else y - 399) / 400 in + let yoe = y - (era * 400) in + let mp = (m + 9) mod 12 in + let doy = (((153 * mp) + 2) / 5) + d - 1 in + let doe = (yoe * 365) + (yoe / 4) - (yoe / 100) + doy in + (era * 146097) + doe - 719468 + +let words s = + String.split_on_char ' ' (String.map (function ',' -> ' ' | c -> c) s) + |> List.filter (fun w -> w <> "") + +let parse_http_date value = + let tokens = + match words value with + | first :: rest when String.length first > 0 && not (is_digit first.[0]) -> + rest + | tokens -> tokens + in + match tokens with + | day :: month :: year :: time :: _ -> ( + match + ( int_of_string_opt day, + month_index month, + int_of_string_opt year, + String.split_on_char ':' time ) + with + | Some day, Some month, Some year, [ h; mi; s ] -> ( + match + (int_of_string_opt h, int_of_string_opt mi, int_of_string_opt s) + with + | Some h, Some mi, Some s -> + Some + ((float_of_int (days_from_civil year month day) *. 86400.) + +. float_of_int ((h * 3600) + (mi * 60) + s)) + | _ -> None) + | _ -> None) + | _ -> None + +let retry_after_seconds = function + | None -> None + | Some value -> ( + let value = String.trim value in + match float_of_string_opt value with + | Some seconds -> Some (Float.max 0. seconds) + | None -> ( + match parse_http_date value with + | Some target -> Some (Float.max 0. (target -. Unix.gettimeofday ())) + | None -> None)) + +let header_value headers name = + let name = String.lowercase_ascii name in + List.fold_left + (fun acc (k, v) -> + if String.equal (String.lowercase_ascii (String.trim k)) name then + Some (String.trim v) + else acc) + None headers + +let retriable_status = [ 429; 500; 502; 503; 504 ] + +let unreserved c = + is_digit c + || (c >= 'a' && c <= 'z') + || (c >= 'A' && c <= 'Z') + || c = '-' || c = '_' || c = '.' || c = '~' + +let url_encode s = + let buf = Buffer.create (String.length s) in + String.iter + (fun c -> + if unreserved c then Buffer.add_char buf c + else Buffer.add_string buf (Printf.sprintf "%%%02X" (Char.code c))) + s; + Buffer.contents buf + +let strip_bom s = + if String.length s >= 3 && String.sub s 0 3 = "\xef\xbb\xbf" then + String.sub s 3 (String.length s - 3) + else s + +let csv_rows body = + match Csv.input_all (Csv.of_string (strip_bom body)) with + | [] -> [] + | header :: rows -> + let width = List.length header in + List.filter_map + (fun row -> + if List.for_all (fun cell -> String.trim cell = "") row then None + else + let padded = + List.init width (fun i -> try List.nth row i with _ -> "") + in + Some (List.combine header padded)) + rows + +let jitter = lazy (Random.State.make_self_init ()) + +module Client = struct + type t = { + base_url : string; + timeout : float; + max_attempts : int; + backoff_base : float; + backoff_max : float; + total_timeout : float option; + user_agent : string; + } + + let rec strip_trailing_slash s = + let n = String.length s in + if n > 0 && s.[n - 1] = '/' then + strip_trailing_slash (String.sub s 0 (n - 1)) + else s + + let create ?(base_url = default_url) ?(timeout = 10.) ?(max_attempts = 3) + ?(backoff_base = 0.5) ?(backoff_max = 8.) ?total_timeout ?user_agent () = + if max_attempts < 1 then + invalid_arg "Cepis.Client.create: max_attempts must be >= 1"; + if timeout <= 0. then invalid_arg "Cepis.Client.create: timeout must be > 0"; + { + base_url = strip_trailing_slash base_url; + timeout; + max_attempts; + backoff_base; + backoff_max; + total_timeout; + user_agent = + (match user_agent with + | Some ua -> ua + | None -> Printf.sprintf "cepis-ocaml/%s (+https://cep.is)" version); + } + + let base_url t = t.base_url + let user_agent t = t.user_agent + + let perform t url = + let config = + Ezcurl.Config.( + default |> follow_location true |> max_redirects 5 |> verbose false) + in + let set_opts curl = + let ms = int_of_float (t.timeout *. 1000.) in + Curl.set_timeoutms curl ms; + Curl.set_connecttimeoutms curl ms + in + match + Ezcurl.with_client ~set_opts (fun client -> + Ezcurl.get ~client ~config ~tries:1 + ~headers: + [ + ("User-Agent", t.user_agent); + ("Accept", "application/json, text/csv;q=0.9, */*;q=0.1"); + ("Accept-Encoding", "identity"); + ] + ~url ()) + with + | Ok response -> + Ok (response.Ezcurl.code, response.Ezcurl.body, response.Ezcurl.headers) + | Error (_, message) -> Error message + | exception Curl.CurlException (_, _, message) -> Error message + + let backoff t attempt retry_after = + match retry_after with + | Some seconds -> Float.min seconds t.backoff_max + | None -> + let ceiling = + Float.min + (t.backoff_base *. (2. ** float_of_int (attempt - 1))) + t.backoff_max + in + if ceiling <= 0. then 0. + else Random.State.float (Lazy.force jitter) ceiling + + let expired = function + | None -> false + | Some deadline -> Unix.gettimeofday () >= deadline + + let request t ?(accepted_status = [ 200 ]) path = + let url = t.base_url ^ path in + let deadline = + match t.total_timeout with + | None -> None + | Some total -> Some (Unix.gettimeofday () +. total) + in + let attempts = t.max_attempts in + let give_up status retry_after network = + match status with + | Some 429 -> + Error + (Rate_limited + { + message = + Printf.sprintf + "rate limit reached at %s (after %d attempt(s))" url + attempts; + retry_after; + }) + | Some status -> + Error + (Server_error + { + message = + Printf.sprintf + "the API answered %d at %s (after %d attempt(s))" status + url attempts; + status; + }) + | None -> + Error + (Network_error + (Printf.sprintf "could not reach %s (after %d attempt(s)): %s" + url attempts + (match network with + | Some m -> m + | None -> "deadline reached"))) + in + let wait_then t attempt retry_after = + let wait = backoff t attempt retry_after in + match deadline with + | None -> + if wait > 0. then Unix.sleepf wait; + true + | Some deadline -> + let remaining = deadline -. Unix.gettimeofday () in + if remaining <= 0. then false + else begin + let wait = Float.min wait remaining in + if wait > 0. then Unix.sleepf wait; + true + end + in + let rec attempt n status retry_after network = + if n > attempts || expired deadline then + give_up status retry_after network + else + match perform t url with + | Ok (code, body, _) + when List.mem code accepted_status + || not (List.mem code retriable_status) -> + Ok (code, body) + | Ok (code, _, headers) -> + let retry_after = + retry_after_seconds (header_value headers "Retry-After") + in + if n >= attempts then give_up (Some code) retry_after None + else if wait_then t n retry_after then + attempt (n + 1) (Some code) retry_after None + else give_up (Some code) retry_after None + | Error message -> + if n >= attempts then give_up None None (Some message) + else if wait_then t n None then + attempt (n + 1) None None (Some message) + else give_up None None (Some message) + in + attempt 1 None None None + + let ( let* ) = Result.bind + + let lookup t cep = + let* number = normalize_cep cep in + let* code, body = request t ("/" ^ number) in + if code = 404 then + Error + (Cep_not_found + (Printf.sprintf "CEP %s does not exist in the DNE database" number)) + else if code = 400 then + Error + (Invalid_cep + (api_message body (Printf.sprintf "CEP %s rejected" number))) + else + let* fields = json_object_of_body body in + Ok (address_of_fields fields) + + let lookup_chunk t ceps = + let query = url_encode (String.concat "," ceps) in + let* _, body = request t ("/csv?ceps=" ^ query) in + let rows = + List.map + (fun row -> + match List.assoc_opt "localidade" row with + | Some place when String.trim place <> "" -> + Some + (address_of_fields + (List.map (fun (k, v) -> (k, `String v)) row)) + | _ -> None) + (csv_rows body) + in + let wanted = List.length ceps in + let got = List.length rows in + if got = wanted then Ok rows + else if got > wanted then Ok (List.filteri (fun i _ -> i < wanted) rows) + else Ok (rows @ List.init (wanted - got) (fun _ -> None)) + + let rec chunks size list = + if list = [] then [] + else + let head = List.filteri (fun i _ -> i < size) list in + let tail = List.filteri (fun i _ -> i >= size) list in + head :: chunks size tail + + let lookup_many t ceps = + if ceps = [] then Ok [] + else + List.fold_left + (fun acc chunk -> + let* acc = acc in + let* rows = lookup_chunk t chunk in + Ok (acc @ rows)) + (Ok []) (chunks max_batch ceps) + + let health t = + let* _, body = request t ~accepted_status:[ 200; 503 ] "/health" in + let* fields = json_object_of_body body in + Ok (health_of_fields fields) +end + +let default = lazy (Client.create ()) +let lookup cep = Client.lookup (Lazy.force default) cep +let lookup_many ceps = Client.lookup_many (Lazy.force default) ceps +let health () = Client.health (Lazy.force default) |