Improvements to expiration checking

compiler/surface/ast.ml

@@ -783,7 +783,7 @@ type source_repr = (string[@opaque]) Marked.pos
 type law_heading = {
   law_heading_name : (string[@opaque]) Marked.pos;
   law_heading_id : (string[@opaque]) option;
-  law_heading_expiration_date : (string[@opaque]) option;
+  law_heading_is_archive : bool; [@opaque]
   law_heading_precedence : (int[@opaque]);
 }
 [@@deriving

compiler/surface/lexer_common.ml

@@ -31,21 +31,16 @@ let calc_precedence (matched_regex : string) : int =
 (* Gets the [LAW_HEADING] token from the current {!val: lexbuf} *)
 let get_law_heading (lexbuf : lexbuf) : token =
   let extract_article_title =
-    R.regexp
-      "([#]+)\\s*([^\\|]+)(\\|([^\\|]+)|)(\\|\\s*([0-9]{4}\\-[0-9]{2}\\-[0-9]{2})|)"
+    R.regexp "([#]+)\\s*([^\\|]+)(\\|\\s*([^\\s]+)|)(\\s*(\\[archive\\])|)"
   in
-  let get_substring =
-    R.get_substring (R.exec ~rex:extract_article_title (Utf8.lexeme lexbuf))
-  in
-  let title = String.trim (get_substring 2) in
+  let rex = R.exec ~rex:extract_article_title (Utf8.lexeme lexbuf) in
+  let title = String.trim (R.get_substring rex 2) in
   let article_id =
-    try Some (String.trim (get_substring 4)) with Not_found -> None
+    try Some (String.trim (R.get_substring rex 4)) with Not_found -> None
   in
-  let article_expiration_date =
-    try Some (String.trim (get_substring 6)) with Not_found -> None
-  in
-  let precedence = calc_precedence (String.trim (get_substring 1)) in
-  LAW_HEADING (title, article_id, article_expiration_date, precedence)
+  let is_archive = Option.is_some (Re.Group.get_opt rex 6) in
+  let precedence = calc_precedence (String.trim (R.get_substring rex 1)) in
+  LAW_HEADING (title, article_id, is_archive, precedence)
 
 type lexing_context = Law | Code | Directive | Directive_args
 

compiler/surface/parser.mly

@@ -637,10 +637,10 @@ metadata_block:
 
 law_heading:
 | title = LAW_HEADING {
-  let (title, id, exp_date, precedence) = title in {
+  let (title, id, is_archive, precedence) = title in {
     law_heading_name = (title, Pos.from_lpos $sloc);
     law_heading_id = id;
-    law_heading_expiration_date = exp_date;
+    law_heading_is_archive = is_archive;
     law_heading_precedence = precedence;
   }
 }

compiler/surface/tokens.mly

@@ -22,7 +22,7 @@
 %}
 
 %token EOF
-%token<string * string option * string option * int> LAW_HEADING
+%token<string * string option * bool * int> LAW_HEADING
 
 %token BEGIN_DIRECTIVE END_DIRECTIVE LAW_INCLUDE
 %token<int> AT_PAGE

french_law/legifrance_checker/api.ml

@@ -106,9 +106,9 @@ let run_request (request : (string * string t) t) : Yojson.Basic.t =
     resp, body
   in
   let handle_once resp body =
-    if resp = "200 OK" then (
-      try body |> Yojson.Basic.from_string
-      with Yojson.Basic.Util.Type_error (msg, obj) ->
+    if resp = "200 OK" then
+      try body |> Yojson.Basic.from_string with
+      | Yojson.Basic.Util.Type_error (msg, obj) ->
         Utils.Cli.error_print
           "Error while parsing JSON answer from API: %s\n\
            Specific JSON:\n\
@@ -118,7 +118,8 @@ let run_request (request : (string * string t) t) : Yojson.Basic.t =
           msg
           (Yojson.Basic.to_string obj)
           body;
-        exit (-1))
+        exit (-1)
+      | _ -> raise (Failure "")
     else raise (Failure "")
   in
   let rec try_n_times (n : int) =
@@ -160,6 +161,7 @@ let parse_id (id : string) : article_id =
   { id; typ }
 
 let retrieve_article (access_token : string) (obj : article_id) : article =
+  Utils.Cli.debug_format "Accessing article %s" obj.id;
   {
     content =
       run_request
@@ -238,7 +240,7 @@ 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 "01/01/2999"
+    | CETATEXT -> Date.parse_expiration_date DDMMYYYY "01/01/2999"
     | LEGIARTI | JORFARTI ->
       article.content
       |> Yojson.Basic.Util.member "article"

french_law/legifrance_checker/cli.ml

@@ -45,7 +45,7 @@ let custom_date =
           "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 DD/MM/YYYY.")
+           custom date in the format YYYY-MM-DD.")
 
 let diff =
   Arg.(

french_law/legifrance_checker/date.ml

@@ -16,11 +16,17 @@
 
 (** Helper functions to interact with {!Unix.tm} dates *)
 
-(** Parses a date formatted as [DD/MM/YYYY] into an {!Unix.tm}*)
-let parse_expiration_date (expiration_date : string) : Unix.tm =
+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 "([0-9]{2})\\/([0-9]{2})\\/([0-9]{4})"
+      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
@@ -29,9 +35,16 @@ let parse_expiration_date (expiration_date : string) : Unix.tm =
     snd
       (Unix.mktime
          {
-           Unix.tm_mday = int_of_string (get_substring 1);
+           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 3) - 1900;
+           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;

french_law/legifrance_checker/main.ml

@@ -28,47 +28,15 @@ let check_article_expiration
     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 source_expiration_date =
-      Option.map Date.parse_expiration_date
-        law_heading.Surface.Ast.law_heading_expiration_date
-    in
-    (* At this point we have three dates. [C] the current date, [L] the
-       expiration date from LégiFrance, and [S] (optionnal) the expiration date
-       according to the source code.
-
-       First, if [S < L], we raise an error: the source code is wrong. Indeed
-       the [S] expiration date is only meant as an override that extends
-       LégiFrance expiration date, not shorten it.
-
-       Now, we take [D = max(S,L)] and if [C > D] then we throw an error saying
-       it is expired. *)
-    (match source_expiration_date with
-    | None -> ()
-    | Some source_expiration_date ->
-      if Date.date_compare source_expiration_date legifrance_expiration_date < 0
-      then
-        Utils.Cli.warning_print "%s %s expires on %s according to LégiFrance%s"
-          (Utils.Marked.unmark law_heading.Surface.Ast.law_heading_name)
-          (Utils.Pos.to_string
-             (Utils.Marked.get_mark law_heading.Surface.Ast.law_heading_name))
-          (Date.print_tm legifrance_expiration_date)
-          (match law_heading.Surface.Ast.law_heading_expiration_date with
-          | None -> assert false
-          | Some source_exp_date ->
-            ", but"
-            ^ source_exp_date
-            ^ " according to source code, which is more restrictive."));
-    let max_date =
-      match source_expiration_date with
-      | None -> legifrance_expiration_date
-      | Some source_expiration_date ->
-        if
-          Date.date_compare source_expiration_date legifrance_expiration_date
-          < 0
-        then legifrance_expiration_date
-        else source_expiration_date
-    in
-    if Date.date_compare current_date max_date > 0 then (
+    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
@@ -80,19 +48,15 @@ let check_article_expiration
       in
       Utils.Cli.warning_print
         "%s %s has expired! Its expiration date is %s according to \
-         LégiFrance%s.%s"
+         LégiFrance.%s"
         (Utils.Marked.unmark law_heading.Surface.Ast.law_heading_name)
         (Utils.Pos.to_string
            (Utils.Marked.get_mark law_heading.Surface.Ast.law_heading_name))
         (Date.print_tm legifrance_expiration_date)
-        (match law_heading.Surface.Ast.law_heading_expiration_date with
-        | None -> ""
-        | Some source_exp_date ->
-          "and " ^ source_exp_date ^ " according to source code")
         (match new_version with
         | None -> ""
         | Some new_version ->
-          Format.asprintf " New version of the article: %s." new_version);
+          Format.asprintf " New version of the article: \"%s\"." new_version);
       new_version)
     else None
 
@@ -292,7 +256,7 @@ let driver
     in
     let current_date =
       match custom_date with
-      | Some custom_date -> Date.parse_expiration_date custom_date
+      | Some custom_date -> Date.parse_expiration_date ISO custom_date
       | None -> Unix.localtime (Unix.time ())
     in
     List.iter