lib/whenutils.ml

   1 (* whenjobs
   2  * Copyright (C) 2012 Red Hat Inc.
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation; either version 2 of the License, or
   7  * (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License along
  15  * with this program; if not, write to the Free Software Foundation, Inc.,
  16  * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  17  *)
  18
  19 open Camlp4.PreCast
  20 open Ast
  21
  22 open CalendarLib
  23
  24 open Big_int
  25 open Unix
  26 open Printf
  27
  28 module StringMap = struct
  29   include Map.Make (String)
  30   let keys m = fold (fun k _ ks -> k :: ks) m []
  31   let values m = fold (fun _ v vs -> v :: vs) m []
  32 end
  33
  34 module IntMap = struct
  35   include Map.Make (struct type t = int let compare = compare end)
  36   let keys m = fold (fun k _ ks -> k :: ks) m []
  37   let values m = fold (fun _ v vs -> v :: vs) m []
  38 end
  39
  40 module StringSet = Set.Make (String)
  41
  42 let (//) = Filename.concat
  43
  44 let rec filter_map f = function
  45   | [] -> []
  46   | x :: xs ->
  47     match f x with
  48     | Some y -> y :: filter_map f xs
  49     | None -> filter_map f xs
  50
  51 type whenexpr =
  52   | Expr_bool of bool
  53   | Expr_str of string
  54   | Expr_int of Big_int.big_int
  55   | Expr_float of float
  56   | Expr_var of string
  57   | Expr_and of whenexpr * whenexpr
  58   | Expr_or of whenexpr * whenexpr
  59   | Expr_eq of whenexpr * whenexpr
  60   | Expr_not of whenexpr
  61   | Expr_changes of string
  62
  63 (* This internal type is used during conversion of the OCaml AST
  64  * to the whenexpr type.
  65  *)
  66 type whenexpr_int =
  67   | IExpr_bool of bool
  68   | IExpr_str of string
  69   | IExpr_int of Big_int.big_int
  70   | IExpr_float of float
  71   | IExpr_var of string
  72   | IExpr_app of string * whenexpr_int list
  73
  74 (* Note that days are not necessarily expressible in seconds (because
  75  * of leap seconds), months are not expressible in days (because months
  76  * have different lengths), and years are not expressible in days
  77  * (because of leap days) although we could save a case here by
  78  * expressing years in months.
  79  *)
  80 type periodexpr =
  81   | Every_seconds of int
  82   | Every_days of int
  83   | Every_months of int
  84   | Every_years of int
  85
  86 type shell_script = {
  87   sh_loc : Loc.t;
  88   sh_script : string;
  89 }
  90
  91 type variable =
  92   | T_bool of bool
  93   | T_string of string
  94   | T_int of big_int
  95   | T_float of float
  96
  97 let variable_of_rpc = function
  98   | `bool_t b -> T_bool b
  99   | `string_t s -> T_string s
 100   | `int_t i -> T_int (big_int_of_string i)
 101   | `float_t f -> T_float f
 102
 103 let rpc_of_variable = function
 104   | T_bool b -> `bool_t b
 105   | T_string s -> `string_t s
 106   | T_int i -> `int_t (string_of_big_int i)
 107   | T_float f -> `float_t f
 108
 109 type variables = variable StringMap.t
 110
 111 type job_private = {
 112   (* The result of the previous evaluation.  This is used for
 113    * implementing edge-triggering, since we only trigger the job to run
 114    * when the state changes from false -> true.
 115    *)
 116   job_prev_eval_state : bool;
 117
 118   (* When the job {i ran} last time, we take a copy of the variables.
 119    * This allows us to implement the 'changes' operator.
 120    *)
 121   job_prev_variables : variables;
 122 }
 123
 124 let no_job_private =
 125   { job_prev_eval_state = false; job_prev_variables = StringMap.empty }
 126
 127 type job_cond =
 128   | When_job of whenexpr
 129   | Every_job of periodexpr
 130
 131 type job = {
 132   job_loc : Loc.t;
 133   job_name : string;
 134   job_cond : job_cond;
 135   job_script : shell_script;
 136   job_private : job_private;
 137 }
 138
 139 let rec expr_of_ast _loc ast =
 140   expr_of_iexpr _loc (iexpr_of_ast _loc ast)
 141
 142 and iexpr_of_ast _loc = function
 143   | ExId (_, IdUid (_, "True")) -> IExpr_bool true
 144   | ExId (_, IdUid (_, "False")) -> IExpr_bool false
 145   | ExStr (_, str) -> IExpr_str str
 146   | ExInt (_, i) -> IExpr_int (big_int_of_string i) (* XXX too large? *)
 147   | ExFlo (_, f) -> IExpr_float (float_of_string f)
 148   | ExId (_, IdLid (_, id)) -> IExpr_var id
 149
 150   (* In the OCaml AST, functions are curried right to left, so we
 151    * must uncurry to get the list of arguments.
 152    *)
 153   | ExApp (_, left_tree, right_arg) ->
 154     let f, left_args = uncurry_app_tree _loc left_tree in
 155     IExpr_app (f, List.rev_map (iexpr_of_ast _loc) (right_arg :: left_args))
 156
 157   | e ->
 158     (* https://groups.google.com/group/fa.caml/browse_thread/thread/f35452d085654bd6 *)
 159     eprintf "expr_of_ast: invalid expression: %!";
 160     let e = Ast.StExp (_loc, e) in
 161     Printers.OCaml.print_implem ~output_file:"/dev/stderr" e;
 162
 163     invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
 164
 165 and uncurry_app_tree _loc = function
 166   | ExId (_, IdLid (_, f)) -> f, []
 167   | ExApp (_, left_tree, right_arg) ->
 168     let f, left_args = uncurry_app_tree _loc left_tree in
 169     f, (right_arg :: left_args)
 170   | e ->
 171     eprintf "uncurry_app_tree: invalid expression: %!";
 172     let e = Ast.StExp (_loc, e) in
 173     Printers.OCaml.print_implem ~output_file:"/dev/stderr" e;
 174
 175     invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
 176
 177 and expr_of_iexpr _loc = function
 178   | IExpr_bool b -> Expr_bool b
 179   | IExpr_str s -> Expr_str s
 180   | IExpr_int i -> Expr_int i
 181   | IExpr_float f -> Expr_float f
 182   | IExpr_var v -> Expr_var v
 183
 184   | IExpr_app ("&&", exprs) ->
 185     (match exprs with
 186     | [e1; e2] -> Expr_and (expr_of_iexpr _loc e1, expr_of_iexpr _loc e2)
 187     | _ ->
 188       invalid_arg (sprintf "%s: && operator must be applied to two parameters"
 189                      (Loc.to_string _loc))
 190     )
 191
 192   | IExpr_app ("||", exprs) ->
 193     (match exprs with
 194     | [e1; e2] -> Expr_or (expr_of_iexpr _loc e1, expr_of_iexpr _loc e2)
 195     | _ ->
 196       invalid_arg (sprintf "%s: || operator must be applied to two parameters"
 197                       (Loc.to_string _loc))
 198     )
 199
 200   | IExpr_app (("="|"=="), exprs) ->
 201     (match exprs with
 202     | [e1; e2] -> Expr_eq (expr_of_iexpr _loc e1, expr_of_iexpr _loc e2)
 203     | _ ->
 204       invalid_arg (sprintf "%s: = operator must be applied to two parameters"
 205                       (Loc.to_string _loc))
 206     )
 207
 208   | IExpr_app ("!", exprs) ->
 209     (match exprs with
 210     | [e1] -> Expr_not (expr_of_iexpr _loc e1)
 211     | _ ->
 212       invalid_arg (sprintf "%s: ! operator must be applied to one parameter"
 213                       (Loc.to_string _loc))
 214     )
 215
 216   | IExpr_app (("change"|"changes"|"changed"), [IExpr_var v]) ->
 217     Expr_changes v
 218
 219   | IExpr_app (("change"|"changes"|"changed"), _) ->
 220     invalid_arg (sprintf "%s: 'changes' operator must be followed by a variable name"
 221                     (Loc.to_string _loc))
 222
 223   | IExpr_app (op, _) ->
 224     invalid_arg (sprintf "%s: unknown operator in expression: %s"
 225                    (Loc.to_string _loc) op)
 226
 227 let rec string_of_whenexpr = function
 228   | Expr_bool b -> sprintf "%b" b
 229   | Expr_str s -> sprintf "%S" s
 230   | Expr_int i -> sprintf "%s" (string_of_big_int i)
 231   | Expr_float f -> sprintf "%f" f
 232   | Expr_var v -> sprintf "%s" v
 233   | Expr_and (e1, e2) ->
 234     sprintf "%s && %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 235   | Expr_or (e1, e2) ->
 236     sprintf "%s || %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 237   | Expr_eq (e1, e2) ->
 238     sprintf "%s == %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 239   | Expr_not e -> sprintf "! %s" (string_of_whenexpr e)
 240   | Expr_changes v -> sprintf "changes %s" v
 241
 242 let string_of_periodexpr = function
 243   | Every_seconds 1 -> "1 second"
 244   | Every_seconds i -> sprintf "%d seconds" i
 245   | Every_days 1 -> "1 day"
 246   | Every_days i -> sprintf "%d days" i
 247   | Every_months 1 -> "1 month"
 248   | Every_months i -> sprintf "%d months" i
 249   | Every_years 1 -> "1 year"
 250   | Every_years i -> sprintf "%d years" i
 251
 252 let rec dependencies_of_whenexpr = function
 253   | Expr_bool _ -> []
 254   | Expr_str _ -> []
 255   | Expr_int _ -> []
 256   | Expr_float _ -> []
 257   | Expr_var v -> [v]
 258   | Expr_and (e1, e2) ->
 259     dependencies_of_whenexpr e1 @ dependencies_of_whenexpr e2
 260   | Expr_or (e1, e2) ->
 261     dependencies_of_whenexpr e1 @ dependencies_of_whenexpr e2
 262   | Expr_eq (e1, e2) ->
 263     dependencies_of_whenexpr e1 @ dependencies_of_whenexpr e2
 264   | Expr_not e -> dependencies_of_whenexpr e
 265   | Expr_changes v -> [v]
 266
 267 let dependencies_of_job = function
 268   | { job_cond = When_job whenexpr } -> dependencies_of_whenexpr whenexpr
 269   | { job_cond = Every_job _ } -> []
 270
 271 let rec eval_whenexpr job variables = function
 272   | Expr_bool b -> T_bool b
 273   | Expr_str s -> T_string s
 274   | Expr_int i -> T_int i
 275   | Expr_float f -> T_float f
 276
 277   | Expr_var v ->
 278     (try StringMap.find v variables with Not_found -> T_string "")
 279
 280   | Expr_and (e1, e2) ->
 281     if eval_whenexpr_as_bool job variables e1 &&
 282        eval_whenexpr_as_bool job variables e2 then
 283       T_bool true
 284     else
 285       T_bool false
 286
 287   | Expr_or (e1, e2) ->
 288     if eval_whenexpr_as_bool job variables e1 ||
 289        eval_whenexpr_as_bool job variables e2 then
 290       T_bool true
 291     else
 292       T_bool false
 293
 294   | Expr_eq (e1, e2) ->
 295     let e1 = eval_whenexpr job variables e1
 296     and e2 = eval_whenexpr job variables e2 in
 297     if 0 = compare_values e1 e2 then
 298       T_bool true
 299     else
 300       T_bool false
 301
 302   | Expr_not e ->
 303     if not (eval_whenexpr_as_bool job variables e) then
 304       T_bool true
 305     else
 306       T_bool false
 307
 308   | Expr_changes v ->
 309     let prev_value =
 310       try StringMap.find v job.job_private.job_prev_variables
 311       with Not_found -> T_string "" in
 312     let curr_value =
 313       try StringMap.find v variables
 314       with Not_found -> T_string "" in
 315
 316     if 0 <> compare_values prev_value curr_value then
 317       T_bool true
 318     else
 319       T_bool false
 320
 321 (* Call {!eval_whenexpr} and cast the result to a boolean. *)
 322 and eval_whenexpr_as_bool job variables expr =
 323   match eval_whenexpr job variables expr with
 324   | T_bool r -> r
 325   | T_string s -> s <> ""
 326   | T_int i -> sign_big_int i <> 0
 327   | T_float f -> f <> 0.
 328
 329 (* Do a comparison on two typed values and return -1/0/+1.  If the
 330  * types are different then we compare the values as strings.  The user
 331  * can avoid this by specifying types.
 332  *)
 333 and compare_values value1 value2 =
 334   match value1, value2 with
 335   | T_bool b1, T_bool b2 -> compare b1 b2
 336   | T_string s1, T_string s2 -> compare s1 s2
 337   | T_int i1, T_int i2 -> compare_big_int i1 i2
 338   | T_float f1, T_float f2 -> compare f1 f2
 339   | _ ->
 340     let value1 = value_as_string value1
 341     and value2 = value_as_string value2 in
 342     compare value1 value2
 343
 344 and value_as_string = function
 345   | T_bool b -> string_of_bool b
 346   | T_string s -> s
 347   | T_int i -> string_of_big_int i
 348   | T_float f -> string_of_float f
 349
 350 let job_evaluate job variables =
 351   match job with
 352   | { job_cond = Every_job _ } -> false, job
 353   | { job_cond = When_job whenexpr } ->
 354     let state = eval_whenexpr_as_bool job variables whenexpr in
 355
 356     (* Because jobs are edge-triggered, we're only interested in the
 357      * case where the evaluation state changes from false -> true.
 358      *)
 359     match job.job_private.job_prev_eval_state, state with
 360     | false, false
 361     | true, true
 362     | true, false ->
 363       let jobp = { job.job_private with job_prev_eval_state = state } in
 364       let job = { job with job_private = jobp } in
 365       false, job
 366
 367     | false, true ->
 368       let jobp = { job_prev_eval_state = true;
 369                    job_prev_variables = variables } in
 370       let job = { job with job_private = jobp } in
 371       true, job
 372
 373 let next_periodexpr =
 374   (* Round up 'a' to the next multiple of 'i'. *)
 375   let round_up_float a i =
 376     let r = mod_float a i in
 377     if r = 0. then a +. i else a +. (i -. r)
 378   and round_up a i =
 379     let r = a mod i in
 380     if r = 0 then a + i else a + (i - r)
 381   in
 382
 383   fun t -> function
 384   | Every_seconds i ->
 385     let i = float_of_int i in
 386     round_up_float t i
 387
 388   | Every_years i ->
 389     let tm = gmtime t in
 390
 391     (* Round 'tm' up to the first day of the next year. *)
 392     let year = round_up tm.tm_year i in
 393     let tm = { tm with tm_sec = 0; tm_min = 0; tm_hour = 0;
 394                        tm_mday = 1; tm_mon = 0; tm_year = year } in
 395     fst (mktime tm)
 396
 397   | Every_days i ->
 398     let t = Date.from_unixfloat t in
 399     let t0 = Date.make 1970 1 1 in
 400
 401     (* Number of whole days since Unix Epoch. *)
 402     let nb_days = Date.Period.safe_nb_days (Date.sub t t0) in
 403
 404     let nb_days = round_up nb_days i in
 405     let t' = Date.add t0 (Date.Period.day nb_days) in
 406     Date.to_unixfloat t'
 407
 408   | Every_months i ->
 409     (* Calculate number of whole months since Unix Epoch. *)
 410     let tm = gmtime t in
 411     let months = 12 * (tm.tm_year - 70) + tm.tm_mon in
 412
 413     let months = round_up months i in
 414     let t0 = Date.make 1970 1 1 in
 415     let t' = Date.add t0 (Date.Period.month months) in
 416     Date.to_unixfloat t'