mirror of
https://github.com/CatalaLang/catala.git
synced 2024-09-19 16:28:12 +03:00
Remove catala_legifrance
This commit is contained in:
Denis Merigoux
Louis Gesbert
parent
02521092d0
commit
fc9e7330ce
24
README.md
24
README.md
@ -123,10 +123,11 @@ want to compile it from the sources of this repository or use nix. For that, see
|
||||
|
||||
### Catala
|
||||
|
||||
Use `catala --help` if you have installed it to get more information about the command line
|
||||
options available. The man page is also [available online](https://catala-lang.org/en/doc/catala).
|
||||
To get the development version of the help, run `make help_catala`
|
||||
after `make build`. The `catala` binary corresponds to the Catala compiler.
|
||||
Use `catala --help` if you have installed it to get more information about the
|
||||
command line options available. The man page is also [available
|
||||
online](https://catala-lang.org/en/doc/catala). To get the development version
|
||||
of the help, run `make help_catala` after `make build`. The `catala` binary
|
||||
corresponds to the Catala compiler.
|
||||
|
||||
The top-level `Makefile` contains a lot of useful targets to run. To display
|
||||
them, use
|
||||
@ -142,13 +143,20 @@ linking: see [the dedicated README](compiler/plugins/README.md).
|
||||
|
||||
### Clerk
|
||||
|
||||
Use `clerk --help` if you have installed it to get more information about the command line
|
||||
options available. To get the development version of the help, run `make help_clerk`
|
||||
after `make build`. The `clerk` binary corresponds to the Catala build system,
|
||||
responsible for testing among other things.
|
||||
Use `clerk --help` if you have installed it to get more information about the
|
||||
command line options available. To get the development version of the help, run
|
||||
`make help_clerk` after `make build`. The `clerk` binary corresponds to the
|
||||
Catala build system, responsible for testing among other things.
|
||||
|
||||
To get more information about Clerk, see [the dedicated readme](https://github.com/CatalaLang/catala/tree/master/build_system/README.md)
|
||||
|
||||
### Catleg
|
||||
|
||||
Catleg is a command line utility providing useful integration with
|
||||
[LégiFrance](https://legifrance.gouv.fr), the official repository of French
|
||||
legal documentation. See the [decidated
|
||||
repository](https://github.com/catalaLang/catleg) for more information.
|
||||
|
||||
## Documentation
|
||||
|
||||
### Syntax cheat sheet
|
||||
|
||||
@ -1,35 +0,0 @@
|
||||
opam-version: "2.0"
|
||||
version: "0.8.0"
|
||||
synopsis: "Linter that queries the LégiFrance API to check for correctness and expiration of Catala programs"
|
||||
maintainer: ["contact@catala-lang.org"]
|
||||
authors: ["Denis Merigoux"]
|
||||
license: "Apache-2.0"
|
||||
homepage: "https://github.com/CatalaLang/catala"
|
||||
bug-reports: "https://github.com/CatalaLang/catala/issues"
|
||||
depends: [
|
||||
"dune" {>= "2.8"}
|
||||
"ocaml" {>= "4.11.0"}
|
||||
"lwt" {>= "5.6.1"}
|
||||
"re" {>= "1.9.0"}
|
||||
"cohttp-lwt-unix" {>= "5.0.0"}
|
||||
"cohttp" {>= "5.0.0"}
|
||||
"lwt_ssl" {>= "1.2.0"}
|
||||
"tls" {>= "0.15.3"}
|
||||
"catala" {= version}
|
||||
"odoc" {with-doc}
|
||||
]
|
||||
build: [
|
||||
["dune" "subst"] {dev}
|
||||
[
|
||||
"dune"
|
||||
"build"
|
||||
"-p"
|
||||
name
|
||||
"-j"
|
||||
jobs
|
||||
"@install"
|
||||
"@runtest" {with-test}
|
||||
"@doc" {with-doc}
|
||||
]
|
||||
]
|
||||
dev-repo: "git+https://github.com/CatalaLang/catala.git"
|
||||
@ -1,299 +0,0 @@
|
||||
(* This file is part of the Catala compiler, a specification language for tax
|
||||
and social benefits computation rules. Copyright (C) 2022 Inria, contributor:
|
||||
Denis Merigoux <denis.merigoux@inria.fr>
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License"); you may not
|
||||
use this file except in compliance with the License. You may obtain a copy of
|
||||
the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software
|
||||
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
|
||||
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
|
||||
License for the specific language governing permissions and limitations under
|
||||
the License. *)
|
||||
|
||||
open Catala_utils
|
||||
|
||||
type access_token = string
|
||||
|
||||
let ( let* ) = Lwt.bind
|
||||
|
||||
let get_token_aux (client_id : string) (client_secret : string) :
|
||||
(Cohttp.Code.status_code * string) Lwt.t =
|
||||
let site = "https://oauth.aife.economie.gouv.fr" in
|
||||
let token_url = "/api/oauth/token" in
|
||||
let uri = Uri.of_string (site ^ token_url) in
|
||||
let headers =
|
||||
Cohttp.Header.init_with "Content-Type" "application/x-www-form-urlencoded"
|
||||
in
|
||||
let body_string =
|
||||
[
|
||||
"grant_type", "client_credentials";
|
||||
"client_id", client_id;
|
||||
"client_secret", client_secret;
|
||||
"scope", "openid";
|
||||
]
|
||||
|> List.map (fun (k, v) -> Printf.sprintf {|%s=%s|} k v)
|
||||
|> String.concat "&"
|
||||
|> Printf.sprintf "%s"
|
||||
in
|
||||
let body = body_string |> Cohttp_lwt.Body.of_string in
|
||||
let* resp, body = Cohttp_lwt_unix.Client.post ~headers ~body uri in
|
||||
let status = resp |> Cohttp_lwt.Response.status in
|
||||
let* body = body |> Cohttp_lwt.Body.to_string in
|
||||
Lwt.return (status, body)
|
||||
|
||||
let get_token (client_id : string) (client_secret : string) : string Lwt.t =
|
||||
let rec retry count =
|
||||
if count = 0 then (
|
||||
Message.emit_debug "Too many retries, giving up\n";
|
||||
exit 1)
|
||||
else
|
||||
let* resp, body = get_token_aux client_id client_secret in
|
||||
if Cohttp.Code.code_of_status resp = 200 then begin
|
||||
let token =
|
||||
body
|
||||
|> Yojson.Basic.from_string
|
||||
|> Yojson.Basic.Util.member "access_token"
|
||||
|> Yojson.Basic.Util.to_string
|
||||
in
|
||||
Message.emit_debug "The LegiFrance API access token is %s" token;
|
||||
Lwt.return token
|
||||
end
|
||||
else if Cohttp.Code.code_of_status resp = 400 then begin
|
||||
Message.emit_debug "The API access request returned code 400%s\n"
|
||||
(if count > 1 then ", retrying..." else "");
|
||||
retry (count - 1)
|
||||
end
|
||||
else begin
|
||||
Message.emit_debug
|
||||
"The API access token request went wrong ; status is %s and the body \
|
||||
is\n\
|
||||
%s"
|
||||
(Cohttp.Code.string_of_status resp)
|
||||
body;
|
||||
exit 1
|
||||
end
|
||||
in
|
||||
retry 10
|
||||
|
||||
let site = "https://api.aife.economie.gouv.fr"
|
||||
let base_token_url = "/dila/legifrance-beta/lf-engine-app/"
|
||||
|
||||
let api_timestamp_to_localtime (timestamp : int) : Unix.tm =
|
||||
Unix.localtime (float_of_int (timestamp / 1000))
|
||||
|
||||
let make_request
|
||||
(access_token : string)
|
||||
(token_url : string)
|
||||
(body_json : (string * string) list)
|
||||
() : (string * string) Lwt.t =
|
||||
let uri = Uri.of_string (site ^ base_token_url ^ token_url) in
|
||||
let headers =
|
||||
Cohttp.Header.init_with "Authorization"
|
||||
(Printf.sprintf "Bearer %s" access_token)
|
||||
in
|
||||
let headers = Cohttp.Header.add headers "Content-Type" "application/json" in
|
||||
let headers = Cohttp.Header.add headers "Accept" "application/json" in
|
||||
let body_string =
|
||||
body_json
|
||||
|> List.map (fun (k, v) -> Printf.sprintf {|"%s":"%s"|} k v)
|
||||
|> String.concat ","
|
||||
|> Printf.sprintf "{%s}"
|
||||
in
|
||||
let body = body_string |> Cohttp_lwt.Body.of_string in
|
||||
let* resp, body = Cohttp_lwt_unix.Client.post ~headers ~body uri in
|
||||
let resp =
|
||||
resp |> Cohttp_lwt.Response.status |> Cohttp.Code.string_of_status
|
||||
in
|
||||
let* body = body |> Cohttp_lwt.Body.to_string in
|
||||
Lwt.return (resp, body)
|
||||
|
||||
type article_type = LEGIARTI | CETATEXT | JORFARTI
|
||||
type article_id = { id : string; typ : article_type }
|
||||
type article = { content : Yojson.Basic.t; typ : article_type }
|
||||
|
||||
let run_request (request : unit -> (string * string) Lwt.t) :
|
||||
Yojson.Basic.t Lwt.t =
|
||||
let handle_once resp body =
|
||||
if resp = "200 OK" then
|
||||
try body |> Yojson.Basic.from_string with
|
||||
| Yojson.Basic.Util.Type_error (msg, obj) ->
|
||||
Message.raise_error
|
||||
"Error while parsing JSON answer from API: %s\n\
|
||||
Specific JSON:\n\
|
||||
%s\n\
|
||||
Full answer:\n\
|
||||
%s"
|
||||
msg
|
||||
(Yojson.Basic.to_string obj)
|
||||
body
|
||||
| _ -> raise (Failure "")
|
||||
else raise (Failure "")
|
||||
in
|
||||
let rec try_n_times (n : int) =
|
||||
let* resp, body = request () in
|
||||
try Lwt.return (handle_once resp body)
|
||||
with Failure _ ->
|
||||
if n > 0 then (
|
||||
Unix.sleep 2;
|
||||
Message.emit_debug "Retrying request...";
|
||||
try_n_times (n - 1))
|
||||
else
|
||||
Message.raise_error
|
||||
"The API request went wrong ; status is %s and the body is\n%s" resp
|
||||
body
|
||||
in
|
||||
try_n_times 5
|
||||
|
||||
let parse_id (id : string) : article_id =
|
||||
let legi_rex =
|
||||
Re.(compile @@ whole_string @@ seq [str "LEGIARTI"; repn digit 12 None])
|
||||
in
|
||||
let ceta_tex =
|
||||
Re.(compile @@ whole_string @@ seq [str "CETATEXT"; repn digit 12 None])
|
||||
in
|
||||
let jorf_rex =
|
||||
Re.(compile @@ whole_string @@ seq [str "JORFARTI"; repn digit 12 None])
|
||||
in
|
||||
let typ =
|
||||
if Re.execp legi_rex id then LEGIARTI
|
||||
else if Re.execp ceta_tex id then CETATEXT
|
||||
else if Re.execp jorf_rex id then JORFARTI
|
||||
else
|
||||
Message.raise_error
|
||||
"LégiFrance ID \"%s\" does not correspond to an ID format recognized \
|
||||
by the LégiFrance API"
|
||||
id
|
||||
in
|
||||
{ id; typ }
|
||||
|
||||
let retrieve_article (access_token : string) (obj : article_id) : article Lwt.t
|
||||
=
|
||||
Message.emit_debug "Accessing article %s" obj.id;
|
||||
let* content =
|
||||
run_request
|
||||
(make_request access_token
|
||||
(match obj.typ with
|
||||
| CETATEXT -> "consult/juri"
|
||||
| LEGIARTI | JORFARTI -> "consult/getArticle")
|
||||
(match obj.typ with
|
||||
| CETATEXT -> ["textId", obj.id]
|
||||
| LEGIARTI | JORFARTI -> ["id", obj.id]))
|
||||
in
|
||||
Lwt.return { content; typ = obj.typ }
|
||||
|
||||
let raise_article_parsing_error
|
||||
(json : Yojson.Basic.t)
|
||||
(msg : string)
|
||||
(obj : Yojson.Basic.t) =
|
||||
Message.raise_error
|
||||
"Error while manipulating JSON answer from API: %s\n\
|
||||
Specific JSON:\n\
|
||||
%s\n\
|
||||
Full answer:\n\
|
||||
%s"
|
||||
msg
|
||||
(Yojson.Basic.to_string obj)
|
||||
(Yojson.Basic.to_string json)
|
||||
|
||||
let get_article_id (article : article) : string =
|
||||
try
|
||||
article.content
|
||||
|> Yojson.Basic.Util.member
|
||||
(match article.typ with
|
||||
| CETATEXT -> "text"
|
||||
| LEGIARTI | JORFARTI -> "article")
|
||||
|> Yojson.Basic.Util.member "id"
|
||||
|> Yojson.Basic.Util.to_string
|
||||
with Yojson.Basic.Util.Type_error (msg, obj) ->
|
||||
raise_article_parsing_error article.content msg obj
|
||||
|
||||
let get_article_text (article : article) : string =
|
||||
try
|
||||
let text =
|
||||
article.content
|
||||
|> Yojson.Basic.Util.member
|
||||
(match article.typ with
|
||||
| CETATEXT -> "text"
|
||||
| LEGIARTI | JORFARTI -> "article")
|
||||
|> Yojson.Basic.Util.member "texte"
|
||||
|> Yojson.Basic.Util.to_string
|
||||
in
|
||||
(* there might be a nota *)
|
||||
let nota =
|
||||
try
|
||||
article.content
|
||||
|> Yojson.Basic.Util.member
|
||||
(match article.typ with
|
||||
| CETATEXT -> "text"
|
||||
| LEGIARTI | JORFARTI -> "article")
|
||||
|> Yojson.Basic.Util.member "nota"
|
||||
|> Yojson.Basic.Util.to_string
|
||||
with Yojson.Basic.Util.Type_error _ -> ""
|
||||
in
|
||||
text ^ " " ^ if nota <> "" then "NOTA : " ^ nota else ""
|
||||
with Yojson.Basic.Util.Type_error (msg, obj) ->
|
||||
raise_article_parsing_error article.content msg obj
|
||||
|
||||
let get_article_title (article : article) : string =
|
||||
try
|
||||
article.content
|
||||
|> Yojson.Basic.Util.member
|
||||
(match article.typ with
|
||||
| CETATEXT -> "text"
|
||||
| LEGIARTI | JORFARTI -> "article")
|
||||
|> Yojson.Basic.Util.member "titre"
|
||||
|> Yojson.Basic.Util.to_string
|
||||
with Yojson.Basic.Util.Type_error (msg, obj) ->
|
||||
raise_article_parsing_error article.content msg obj
|
||||
|
||||
let get_article_expiration_date (article : article) : Unix.tm =
|
||||
try
|
||||
let article_id = get_article_id article in
|
||||
match article.typ with
|
||||
| CETATEXT -> Date.parse_expiration_date DDMMYYYY "01/01/2999"
|
||||
| LEGIARTI | JORFARTI ->
|
||||
article.content
|
||||
|> Yojson.Basic.Util.member "article"
|
||||
|> Yojson.Basic.Util.member "articleVersions"
|
||||
|> Yojson.Basic.Util.to_list
|
||||
|> List.find (fun version ->
|
||||
Yojson.Basic.to_string (Yojson.Basic.Util.member "id" version)
|
||||
= "\"" ^ article_id ^ "\"")
|
||||
|> Yojson.Basic.Util.member "dateFin"
|
||||
|> Yojson.Basic.Util.to_int
|
||||
|> api_timestamp_to_localtime
|
||||
with Yojson.Basic.Util.Type_error (msg, obj) ->
|
||||
raise_article_parsing_error article.content msg obj
|
||||
|
||||
let get_article_new_version (article : article) : string =
|
||||
match article.typ with
|
||||
| CETATEXT -> get_article_id article
|
||||
| LEGIARTI | JORFARTI -> (
|
||||
let expiration_date = get_article_expiration_date article in
|
||||
let get_version_date_debut (version : Yojson.Basic.t) : Unix.tm =
|
||||
version
|
||||
|> Yojson.Basic.Util.member "dateDebut"
|
||||
|> Yojson.Basic.Util.to_int
|
||||
|> api_timestamp_to_localtime
|
||||
in
|
||||
try
|
||||
article.content
|
||||
|> Yojson.Basic.Util.member "article"
|
||||
|> Yojson.Basic.Util.member "articleVersions"
|
||||
|> Yojson.Basic.Util.to_list
|
||||
|> List.filter (fun version ->
|
||||
Date.date_compare expiration_date (get_version_date_debut version)
|
||||
<= 0)
|
||||
|> List.sort (fun version1 version2 ->
|
||||
Date.date_compare
|
||||
(get_version_date_debut version1)
|
||||
(get_version_date_debut version2))
|
||||
|> List.hd
|
||||
|> Yojson.Basic.Util.member "id"
|
||||
|> Yojson.Basic.Util.to_string
|
||||
with Yojson.Basic.Util.Type_error (msg, obj) ->
|
||||
raise_article_parsing_error article.content msg obj)
|
||||
@ -1,53 +0,0 @@
|
||||
(* This file is part of the Catala compiler, a specification language for tax
|
||||
and social benefits computation rules. Copyright (C) 2022 Inria, contributor:
|
||||
Denis Merigoux <denis.merigoux@inria.fr>
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License"); you may not
|
||||
use this file except in compliance with the License. You may obtain a copy of
|
||||
the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software
|
||||
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
|
||||
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
|
||||
License for the specific language governing permissions and limitations under
|
||||
the License. *)
|
||||
|
||||
(** Performs API requests and manipulates API data. Needs a working Internet
|
||||
connection to work *)
|
||||
|
||||
(** {2 Requests}*)
|
||||
|
||||
type access_token
|
||||
(** The [access_token] is the OAuth token used in every API request for
|
||||
authentication *)
|
||||
|
||||
val get_token : string -> string -> access_token Lwt.t
|
||||
(** [get_token cliend_id client_secret] retrieves the access token from the
|
||||
LegiFrance API. You have to register on the
|
||||
{{:https://developer.aife.economie.gouv.fr/} the official website of the
|
||||
French government} to get your OAuth client ID and Secret for the
|
||||
LegiFrance API *)
|
||||
|
||||
type article
|
||||
type article_id
|
||||
|
||||
val parse_id : string -> article_id
|
||||
(** [parse_id id] parses the string representing the LégiFrance object to be
|
||||
fetched from the API, checks its validity (for instance
|
||||
["LEGIARTI000006307920"]) and returns an [object_id]*)
|
||||
|
||||
val retrieve_article : access_token -> article_id -> article Lwt.t
|
||||
(** [retrieve_article token article_id] returns the article from the LegiFrance
|
||||
API.*)
|
||||
|
||||
(**{2 Manipulating API objects}*)
|
||||
|
||||
(**{3 Articles}*)
|
||||
|
||||
val get_article_id : article -> string
|
||||
val get_article_text : article -> string
|
||||
val get_article_title : article -> string
|
||||
val get_article_expiration_date : article -> Unix.tm
|
||||
val get_article_new_version : article -> string
|
||||
@ -1,305 +0,0 @@
|
||||
(* This file is part of the Catala compiler, a specification language for tax
|
||||
and social benefits computation rules. Copyright (C) 2022 Inria, contributor:
|
||||
Denis Merigoux <denis.merigoux@inria.fr>
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License"); you may not
|
||||
use this file except in compliance with the License. You may obtain a copy of
|
||||
the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software
|
||||
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
|
||||
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
|
||||
License for the specific language governing permissions and limitations under
|
||||
the License. *)
|
||||
|
||||
open Catala_utils
|
||||
|
||||
let ( let* ) = Lwt.bind
|
||||
|
||||
(** Main logic for interacting with LégiFrance when traversing Catala source
|
||||
files *)
|
||||
|
||||
(** Returns the ID of the future version of the article if any *)
|
||||
let check_article_expiration
|
||||
(current_date : Unix.tm)
|
||||
(law_heading : Surface.Ast.law_heading)
|
||||
(access_token : Api.access_token) : string option Lwt.t =
|
||||
match law_heading.Surface.Ast.law_heading_id with
|
||||
| None -> Lwt.return None
|
||||
| Some heading_id ->
|
||||
let article_id = Api.parse_id heading_id in
|
||||
let* article = Api.retrieve_article access_token article_id in
|
||||
let legifrance_expiration_date = Api.get_article_expiration_date article in
|
||||
let is_archive = law_heading.Surface.Ast.law_heading_is_archive in
|
||||
(* At this point we have two dates. [C] the current date, [L] the expiration
|
||||
date from LégiFrance. Plus we have flag [A] that tells us if [A] is an
|
||||
archive, which should not be checked for expiration. Now, if [C > L] then
|
||||
we throw an error saying it is expired, except if [A] is true *)
|
||||
if
|
||||
(not is_archive)
|
||||
&& Date.date_compare current_date legifrance_expiration_date > 0
|
||||
then (
|
||||
let new_version_available =
|
||||
not (Date.is_infinity legifrance_expiration_date)
|
||||
in
|
||||
let new_version =
|
||||
if new_version_available then
|
||||
let new_version = Api.get_article_new_version article in
|
||||
Some new_version
|
||||
else None
|
||||
in
|
||||
Message.emit_warning
|
||||
"%s %s has expired! Its expiration date is %s according to \
|
||||
LégiFrance.%s"
|
||||
(Mark.remove law_heading.Surface.Ast.law_heading_name)
|
||||
(Pos.to_string (Mark.get law_heading.Surface.Ast.law_heading_name))
|
||||
(Date.print_tm legifrance_expiration_date)
|
||||
(match new_version with
|
||||
| None -> ""
|
||||
| Some new_version ->
|
||||
Format.asprintf " New version of the article: \"%s\"." new_version);
|
||||
Lwt.return new_version)
|
||||
else Lwt.return None
|
||||
|
||||
type law_article_text = {
|
||||
article_title : string * Pos.t;
|
||||
text : string;
|
||||
new_version : Api.article_id option;
|
||||
current_version : Api.article_id option;
|
||||
}
|
||||
(** Representation of the text of an article of law *)
|
||||
|
||||
module Diff = Diff.Make (String)
|
||||
(** Diff algorithm for a list of words *)
|
||||
|
||||
(** [compare_article_to_version token text version] retrieves the text of the
|
||||
article whose LégiFrance ID is [version] and produces a diff with the
|
||||
expected [text]*)
|
||||
let compare_article_to_version
|
||||
(access_token : Api.access_token)
|
||||
(text : string)
|
||||
(version : Api.article_id) : Diff.t option Lwt.t =
|
||||
let* new_article = Api.retrieve_article access_token version in
|
||||
let new_article_text = Api.get_article_text new_article in
|
||||
let text_to_list text =
|
||||
List.map String.trim
|
||||
(List.flatten
|
||||
(List.map
|
||||
(fun line ->
|
||||
List.filter
|
||||
(fun word -> word <> "")
|
||||
(String.split_on_char ' ' line))
|
||||
(List.filter
|
||||
(fun word -> word <> "")
|
||||
(String.split_on_char '\n'
|
||||
(Re.replace_string (Re.compile (Re.char '\t')) ~by:" " text)))))
|
||||
in
|
||||
let old_list = text_to_list text in
|
||||
let new_list = text_to_list new_article_text in
|
||||
let diff = Diff.get_diff (Array.of_list old_list) (Array.of_list new_list) in
|
||||
let all_equal =
|
||||
List.for_all
|
||||
(fun chunk -> match chunk with Diff.Equal _ -> true | _ -> false)
|
||||
diff
|
||||
in
|
||||
Lwt.return (if not all_equal then Some diff else None)
|
||||
|
||||
(** Compares [article_text_acc.current_version] and
|
||||
[article_text_acc.new_version] by accessing LégiFrance and display
|
||||
differences if any *)
|
||||
let compare_to_versions
|
||||
(law_article_text : law_article_text)
|
||||
(access_token : Api.access_token) : unit Lwt.t =
|
||||
let print_diff msg diff =
|
||||
Message.emit_warning "@[<v>%s@,%a@]" msg
|
||||
(Format.pp_print_list (fun ppf chunk ->
|
||||
match chunk with
|
||||
| Diff.Equal words ->
|
||||
Format.fprintf ppf " %s" (String.concat " " words)
|
||||
| Diff.Added words ->
|
||||
Format.fprintf ppf "@{<green>(+) %s@}" (String.concat " " words)
|
||||
| Diff.Deleted words ->
|
||||
Format.fprintf ppf "@{<red>(-) %s@}" (String.concat " " words)))
|
||||
diff
|
||||
in
|
||||
let* _checl =
|
||||
match law_article_text.current_version with
|
||||
| Some version -> (
|
||||
let* comparison =
|
||||
compare_article_to_version access_token law_article_text.text version
|
||||
in
|
||||
match comparison with
|
||||
| None -> Lwt.return_unit
|
||||
| Some diff ->
|
||||
print_diff
|
||||
(Printf.sprintf
|
||||
"There is a diff between the source code version of %s %s and the \
|
||||
text stored on LégiFrance:\n"
|
||||
(fst law_article_text.article_title)
|
||||
(Pos.to_string (snd law_article_text.article_title)))
|
||||
diff;
|
||||
Lwt.return_unit)
|
||||
| None -> Lwt.return_unit
|
||||
in
|
||||
match law_article_text.new_version with
|
||||
| Some version -> (
|
||||
let* comparison =
|
||||
compare_article_to_version access_token law_article_text.text version
|
||||
in
|
||||
match comparison with
|
||||
| None -> Lwt.return_unit
|
||||
| Some diff ->
|
||||
print_diff
|
||||
(Printf.sprintf
|
||||
"Here is the diff between the current version of %s %s and what it \
|
||||
will become in the future:\n"
|
||||
(fst law_article_text.article_title)
|
||||
(Pos.to_string (snd law_article_text.article_title)))
|
||||
diff;
|
||||
Lwt.return_unit)
|
||||
| None -> Lwt.return_unit
|
||||
|
||||
(** Fill an [@@Include ...@@] tag inside the Catala source file with the
|
||||
legislative contents retrieved from LégiFrance *)
|
||||
let include_legislative_text
|
||||
(id : string * Pos.t)
|
||||
(access_token : Api.access_token) : string Lwt.t =
|
||||
let pos = snd id in
|
||||
let id = Api.parse_id (fst id) in
|
||||
let* article = Api.retrieve_article access_token id in
|
||||
let text_to_return = Api.get_article_text article in
|
||||
let to_insert = text_to_return in
|
||||
Message.emit_debug "Position: %s" (Pos.to_string_short pos);
|
||||
let file = Pos.get_file pos in
|
||||
let include_line = Pos.get_start_line pos in
|
||||
let ic = open_in file in
|
||||
let new_file = file ^ ".new" in
|
||||
Message.emit_warning
|
||||
"LégiFrance inclusion detected, writing new contents to %s" new_file;
|
||||
let oc = open_out new_file in
|
||||
(* Pos.t lines start at 1 *)
|
||||
let counter = ref 1 in
|
||||
(try
|
||||
while true do
|
||||
let line = input_line ic in
|
||||
if include_line = !counter then Printf.fprintf oc "%s\n" to_insert
|
||||
else Printf.fprintf oc "%s\n" line;
|
||||
counter := !counter + 1
|
||||
done
|
||||
with End_of_file ->
|
||||
close_in ic;
|
||||
close_out oc);
|
||||
Lwt.return text_to_return
|
||||
|
||||
let rec traverse_source_code
|
||||
~(current_date : Unix.tm)
|
||||
~(diff : bool)
|
||||
~(expiration : bool)
|
||||
(access_token : Api.access_token)
|
||||
(item : Surface.Ast.law_structure) : string Lwt.t =
|
||||
match item with
|
||||
| Surface.Ast.LawHeading (law_heading, children) ->
|
||||
let* children_text =
|
||||
Lwt_list.fold_left_s
|
||||
(fun acc child ->
|
||||
let* traversal =
|
||||
traverse_source_code ~current_date ~diff ~expiration access_token
|
||||
child
|
||||
in
|
||||
Lwt.return (acc ^ "\n\n" ^ traversal))
|
||||
"" children
|
||||
in
|
||||
let* new_version =
|
||||
if expiration then
|
||||
check_article_expiration current_date law_heading access_token
|
||||
else Lwt.return None
|
||||
in
|
||||
let law_article_text =
|
||||
{
|
||||
article_title = law_heading.law_heading_name;
|
||||
text = children_text;
|
||||
new_version =
|
||||
(match new_version with
|
||||
| Some version -> Some (Api.parse_id version)
|
||||
| _ -> None);
|
||||
current_version = Option.map Api.parse_id law_heading.law_heading_id;
|
||||
}
|
||||
in
|
||||
let* _cmp =
|
||||
if diff then compare_to_versions law_article_text access_token
|
||||
else Lwt.return_unit
|
||||
in
|
||||
Lwt.return children_text
|
||||
| Surface.Ast.LawText art_text -> Lwt.return art_text
|
||||
| Surface.Ast.LawInclude (Surface.Ast.LegislativeText id) ->
|
||||
include_legislative_text id access_token
|
||||
| _ -> Lwt.return ""
|
||||
|
||||
(** Parses the Catala master source file and checks each article:
|
||||
|
||||
- if the article has a LégiFrance ID, checks the text of the article in the
|
||||
source code vs the text from LégiFrance;
|
||||
- if the article has an expiration date, display the difference between the
|
||||
current version of the article and the next one on LégiFrance;
|
||||
- fill each [@@Include ...@@] tag with the contents retrieved from
|
||||
LégiFrance *)
|
||||
let driver_lwt
|
||||
(file : string)
|
||||
(debug : bool)
|
||||
(diff : bool)
|
||||
(expiration : bool)
|
||||
(custom_date : string option)
|
||||
(client_id : string)
|
||||
(client_secret : string) =
|
||||
try
|
||||
let _options = Cli.enforce_globals ~debug () in
|
||||
if not (expiration || diff) then
|
||||
Message.raise_error
|
||||
"You have to check at least something, see the list of options with \
|
||||
--help";
|
||||
let* access_token = Api.get_token client_id client_secret in
|
||||
(* LégiFrance is only supported for French texts *)
|
||||
let program =
|
||||
Surface.Parser_driver.parse_top_level_file (FileName file) Fr
|
||||
in
|
||||
let current_date =
|
||||
match custom_date with
|
||||
| Some custom_date -> Date.parse_expiration_date ISO custom_date
|
||||
| None -> Unix.localtime (Unix.time ())
|
||||
in
|
||||
let* () =
|
||||
Lwt_list.iter_s
|
||||
(fun item ->
|
||||
let* _r =
|
||||
traverse_source_code ~current_date ~diff ~expiration access_token
|
||||
item
|
||||
in
|
||||
Lwt.return_unit)
|
||||
program.program_items
|
||||
in
|
||||
prerr_endline "0";
|
||||
Lwt.return 0
|
||||
with Message.CompilerError content ->
|
||||
let bt = Printexc.get_raw_backtrace () in
|
||||
Message.Content.emit content Error;
|
||||
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
|
||||
Lwt.return (-1)
|
||||
|
||||
let driver file debug diff expiration custom_date client_id client_secret =
|
||||
try
|
||||
Lwt_main.run
|
||||
(driver_lwt file debug diff expiration custom_date client_id client_secret)
|
||||
with Message.CompilerError content ->
|
||||
let bt = Printexc.get_raw_backtrace () in
|
||||
Message.Content.emit content Error;
|
||||
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
|
||||
-1
|
||||
|
||||
(** Hook for the executable *)
|
||||
let () =
|
||||
Stdlib.exit
|
||||
@@ Cmdliner.Cmd.eval' ~catch:false
|
||||
(Cmdliner.Cmd.v Legifrance_cli.info
|
||||
(Legifrance_cli.catala_legifrance_t driver))
|
||||
@ -1,73 +0,0 @@
|
||||
(* This file is part of the Catala compiler, a specification language for tax
|
||||
and social benefits computation rules. Copyright (C) 2022 Inria, contributor:
|
||||
Denis Merigoux <denis.merigoux@inria.fr>
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License"); you may not
|
||||
use this file except in compliance with the License. You may obtain a copy of
|
||||
the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software
|
||||
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
|
||||
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
|
||||
License for the specific language governing permissions and limitations under
|
||||
the License. *)
|
||||
|
||||
open Catala_utils
|
||||
|
||||
(** Helper functions to interact with {!Unix.tm} dates *)
|
||||
|
||||
type date_format = DDMMYYYY | ISO
|
||||
|
||||
(** Parses a date formatted as [DD/MM/YYYY] or [YYYY-MM-DD] into an {!Unix.tm}*)
|
||||
let parse_expiration_date (date_format : date_format) (expiration_date : string)
|
||||
: Unix.tm =
|
||||
try
|
||||
let extract_article_title =
|
||||
Re.Pcre.regexp
|
||||
(match date_format with
|
||||
| DDMMYYYY -> "([0-9]{2})\\/([0-9]{2})\\/([0-9]{4})"
|
||||
| ISO -> "([0-9]{4})\\-([0-9]{2})\\-([0-9]{2})")
|
||||
in
|
||||
let get_substring =
|
||||
Re.Pcre.get_substring
|
||||
(Re.Pcre.exec ~rex:extract_article_title expiration_date)
|
||||
in
|
||||
snd
|
||||
(Unix.mktime
|
||||
{
|
||||
Unix.tm_mday =
|
||||
int_of_string
|
||||
(get_substring
|
||||
(match date_format with DDMMYYYY -> 1 | ISO -> 3));
|
||||
Unix.tm_mon = int_of_string (get_substring 2);
|
||||
Unix.tm_year =
|
||||
int_of_string
|
||||
(get_substring
|
||||
(match date_format with DDMMYYYY -> 3 | ISO -> 1))
|
||||
- 1900;
|
||||
Unix.tm_sec = 0;
|
||||
Unix.tm_min = 0;
|
||||
Unix.tm_hour = 0;
|
||||
Unix.tm_wday = 0;
|
||||
Unix.tm_yday = 0;
|
||||
Unix.tm_isdst = false;
|
||||
})
|
||||
with _ ->
|
||||
Message.raise_error "Error while parsing expiration date argument (%s)"
|
||||
expiration_date
|
||||
|
||||
(** Prints an [Unix.tm] under the ISO formatting [YYYY-MM-DD] *)
|
||||
let print_tm (d : Unix.tm) : string =
|
||||
if d.Unix.tm_year + 1900 = 2999 then "undefined date"
|
||||
else
|
||||
Printf.sprintf "%d-%02d-%02d" (1900 + d.Unix.tm_year) (1 + d.Unix.tm_mon)
|
||||
d.Unix.tm_mday
|
||||
|
||||
(** Returns true if [d] is set in the year [2999] *)
|
||||
let is_infinity (d : Unix.tm) : bool = d.Unix.tm_year + 1900 = 2999
|
||||
|
||||
(** [date_compare d1 d2] compares the timestamps of [d1] and [d2]*)
|
||||
let date_compare (d1 : Unix.tm) (d2 : Unix.tm) : int =
|
||||
int_of_float (fst (Unix.mktime d1)) - int_of_float (fst (Unix.mktime d2))
|
||||
@ -1,112 +0,0 @@
|
||||
(* This file is part of the Catala compiler, a specification language for tax
|
||||
and social benefits computation rules. Copyright (C) 2022 Inria, contributor:
|
||||
Denis Merigoux <denis.merigoux@inria.fr>
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License"); you may not
|
||||
use this file except in compliance with the License. You may obtain a copy of
|
||||
the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software
|
||||
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
|
||||
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
|
||||
License for the specific language governing permissions and limitations under
|
||||
the License. *)
|
||||
|
||||
module type Comparable = sig
|
||||
type t
|
||||
|
||||
val compare : t -> t -> int
|
||||
end
|
||||
|
||||
module Make (X : Comparable) = struct
|
||||
type item = X.t
|
||||
type diff = Deleted of item list | Added of item list | Equal of item list
|
||||
type t = diff list
|
||||
|
||||
module ResultTable = Map.Make (struct
|
||||
type t = int * int
|
||||
|
||||
let compare (x1, x2) (y1, y2) = if x1 = y1 then x2 - y2 else x1 - y1
|
||||
end)
|
||||
|
||||
(* TODO: optimize this ! *)
|
||||
let rec longest_common_subsequence
|
||||
(results : item list ResultTable.t)
|
||||
(x1 : item array)
|
||||
(x2 : item array)
|
||||
(i1 : int)
|
||||
(i2 : int) : item list * item list ResultTable.t =
|
||||
if ResultTable.mem (i1, i2) results then
|
||||
ResultTable.find (i1, i2) results, results
|
||||
else if i1 = 0 || i2 = 0 then [], ResultTable.add (0, 0) [] results
|
||||
else if X.compare x1.(i1 - 1) x2.(i2 - 1) = 0 then
|
||||
let res, new_results =
|
||||
longest_common_subsequence results x1 x2 (i1 - 1) (i2 - 1)
|
||||
in
|
||||
let res = res @ [x1.(i1 - 1)] in
|
||||
res, ResultTable.add (i1, i2) res new_results
|
||||
else
|
||||
let res1, new_results1 =
|
||||
longest_common_subsequence results x1 x2 (i1 - 1) i2
|
||||
in
|
||||
let res2, new_results2 =
|
||||
longest_common_subsequence new_results1 x1 x2 i1 (i2 - 1)
|
||||
in
|
||||
let res = if List.length res1 > List.length res2 then res1 else res2 in
|
||||
res, ResultTable.add (i1, i2) res new_results2
|
||||
|
||||
let rec get_diff_aux
|
||||
(x1 : item array)
|
||||
(x2 : item array)
|
||||
(i1 : int)
|
||||
(i2 : int)
|
||||
(lcs : item list) : diff list =
|
||||
if i1 >= Array.length x1 && i2 >= Array.length x2 then [Equal []]
|
||||
else if i1 >= Array.length x1 then
|
||||
[Added (Array.to_list (Array.sub x2 i2 (Array.length x2 - i2)))]
|
||||
else if i2 >= Array.length x2 then
|
||||
[Deleted (Array.to_list (Array.sub x1 i1 (Array.length x1 - i1)))]
|
||||
else
|
||||
match lcs with
|
||||
| [] ->
|
||||
[
|
||||
Deleted (Array.to_list (Array.sub x1 i1 (Array.length x1 - i1)));
|
||||
Added (Array.to_list (Array.sub x2 i2 (Array.length x2 - i2)));
|
||||
]
|
||||
| hd :: lcs_rest ->
|
||||
if X.compare x1.(i1) hd = 0 && X.compare x2.(i2) hd = 0 then
|
||||
Equal [hd] :: get_diff_aux x1 x2 (i1 + 1) (i2 + 1) lcs_rest
|
||||
else if X.compare x1.(i1) hd = 0 then
|
||||
Added [x2.(i2)] :: get_diff_aux x1 x2 i1 (i2 + 1) lcs
|
||||
else if X.compare x2.(i2) hd = 0 then
|
||||
Deleted [x1.(i1)] :: get_diff_aux x1 x2 (i1 + 1) i2 lcs
|
||||
else
|
||||
let after = get_diff_aux x1 x2 (i1 + 1) (i2 + 1) lcs in
|
||||
Deleted [x1.(i1)] :: Added [x2.(i2)] :: after
|
||||
|
||||
let compress_t (x : t) : t =
|
||||
List.rev
|
||||
(List.fold_left
|
||||
(fun (acc : t) (diff : diff) ->
|
||||
match acc, diff with
|
||||
| [], _ -> [diff]
|
||||
| Added x1 :: rest_acc, Added x2 -> Added (x1 @ x2) :: rest_acc
|
||||
| Deleted x1 :: rest_acc, Deleted x2 -> Deleted (x1 @ x2) :: rest_acc
|
||||
| Equal x1 :: rest_acc, Equal x2 -> Equal (x1 @ x2) :: rest_acc
|
||||
| Added x1 :: Deleted x2 :: rest_acc, Deleted x3 ->
|
||||
Deleted (x2 @ x3) :: Added x1 :: rest_acc
|
||||
| Deleted x1 :: Added x2 :: rest_acc, Added x3 ->
|
||||
Added (x2 @ x3) :: Deleted x1 :: rest_acc
|
||||
| _ -> diff :: acc)
|
||||
[] x)
|
||||
|
||||
let get_diff (x1 : item array) (x2 : item array) : t =
|
||||
let lcs, _ =
|
||||
longest_common_subsequence ResultTable.empty x1 x2 (Array.length x1)
|
||||
(Array.length x2)
|
||||
in
|
||||
let out = get_diff_aux x1 x2 0 0 lcs in
|
||||
compress_t out
|
||||
end
|
||||
@ -1,35 +0,0 @@
|
||||
(* This file is part of the Catala compiler, a specification language for tax
|
||||
and social benefits computation rules. Copyright (C) 2022 Inria, contributor:
|
||||
Denis Merigoux <denis.merigoux@inria.fr>
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License"); you may not
|
||||
use this file except in compliance with the License. You may obtain a copy of
|
||||
the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software
|
||||
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
|
||||
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
|
||||
License for the specific language governing permissions and limitations under
|
||||
the License. *)
|
||||
|
||||
(** Simple and inefficient diff algorithm based on longest common subsequences *)
|
||||
|
||||
(** The diff algorithm works on comparable items *)
|
||||
module type Comparable = sig
|
||||
type t
|
||||
|
||||
val compare : t -> t -> int
|
||||
end
|
||||
|
||||
(** Functor that produces a [Diff] module given a comparable type *)
|
||||
module Make : functor (X : Comparable) -> sig
|
||||
type item = X.t
|
||||
type diff = Deleted of item list | Added of item list | Equal of item list
|
||||
type t = diff list
|
||||
|
||||
val get_diff : item array -> item array -> t
|
||||
(** This is the main function : [get_diff a1 a2] compares two arrays of items
|
||||
and outputs a list of chunks tagged with [Deteted], [Added] or [Removed] *)
|
||||
end
|
||||
@ -1,16 +0,0 @@
|
||||
(executable
|
||||
(public_name catala_legifrance)
|
||||
(package catala_legifrance)
|
||||
(libraries
|
||||
catala.surface
|
||||
catala.catala_utils
|
||||
cmdliner
|
||||
cohttp
|
||||
lwt
|
||||
cohttp-lwt-unix
|
||||
yojson
|
||||
re
|
||||
ocolor))
|
||||
|
||||
(documentation
|
||||
(package catala_legifrance))
|
||||
@ -1,100 +0,0 @@
|
||||
(* This file is part of the Catala compiler, a specification language for tax
|
||||
and social benefits computation rules. Copyright (C) 2022 Inria, contributor:
|
||||
Denis Merigoux <denis.merigoux@inria.fr>
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License"); you may not
|
||||
use this file except in compliance with the License. You may obtain a copy of
|
||||
the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software
|
||||
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
|
||||
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
|
||||
License for the specific language governing permissions and limitations under
|
||||
the License. *)
|
||||
|
||||
(** Command line arguments specification of [legifrance_catala] *)
|
||||
|
||||
open Cmdliner
|
||||
open Catala_utils
|
||||
|
||||
let file =
|
||||
Arg.(
|
||||
required
|
||||
& pos 0 (some string) None
|
||||
& info [] ~docv:"FILE"
|
||||
~doc:
|
||||
"Name of the Catala master file you want to get LegiFrance \
|
||||
information on")
|
||||
|
||||
let expiration =
|
||||
Arg.(
|
||||
value
|
||||
& flag
|
||||
& info ["e"; "expiration_check"]
|
||||
~doc:
|
||||
"Checks the expiration dates of articles with a LégiFrance ID tag to \
|
||||
see if they have expired as of now.")
|
||||
|
||||
let custom_date =
|
||||
Arg.(
|
||||
value
|
||||
& opt (some string) None
|
||||
& info ["c"; "custom_date"]
|
||||
~doc:
|
||||
"Use in combination with -e. Instead of checking whether articles \
|
||||
are expired now,\n\
|
||||
\ check their expiration with respect to a \
|
||||
custom date in the format YYYY-MM-DD.")
|
||||
|
||||
let diff =
|
||||
Arg.(
|
||||
value
|
||||
& flag
|
||||
& info ["D"; "diff_check"]
|
||||
~doc:
|
||||
"Checks the text of the articles with a LégiFrance ID tag to see if \
|
||||
there are differences with the official record.")
|
||||
|
||||
let client_id =
|
||||
Arg.(
|
||||
required
|
||||
& pos 1 (some string) None
|
||||
& info [] ~docv:"CLIENT_ID" ~doc:"LegiFrance PISTE API Oauth client id")
|
||||
|
||||
let client_secret =
|
||||
Arg.(
|
||||
required
|
||||
& pos 2 (some string) None
|
||||
& info [] ~docv:"CLIENT_SECRET"
|
||||
~doc:"LegiFrance PISTE API Oauth client secret")
|
||||
|
||||
let debug =
|
||||
Arg.(value & flag & info ["d"; "debug"] ~doc:"Prints debug information")
|
||||
|
||||
(** Arguments : [file debug cliend_id client_secret] *)
|
||||
let catala_legifrance_t f =
|
||||
Term.(
|
||||
const f
|
||||
$ file
|
||||
$ debug
|
||||
$ diff
|
||||
$ expiration
|
||||
$ custom_date
|
||||
$ client_id
|
||||
$ client_secret)
|
||||
|
||||
let info =
|
||||
let doc = "LegiFrance interaction tool for Catala" in
|
||||
let man =
|
||||
[
|
||||
`S Manpage.s_authors;
|
||||
`P "Denis Merigoux <denis.merigoux@inria.fr>";
|
||||
`S Manpage.s_bugs;
|
||||
`P
|
||||
"Please file bug reports at https://github.com/CatalaLang/catala/issues";
|
||||
]
|
||||
in
|
||||
let exits = Cmd.Exit.defaults @ [Cmd.Exit.info ~doc:"on error" 1] in
|
||||
Cmd.info "legifrance_catala" ~version:Cli.version ~doc ~exits ~man
|
||||
Loading…
Reference in New Issue
Block a user