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 Big_int
  23 open Printf
  24
  25 module StringMap = struct
  26   include Map.Make (String)
  27   let keys m = fold (fun k _ ks -> k :: ks) m []
  28   let values m = fold (fun _ v vs -> v :: vs) m []
  29 end
  30
  31 module StringSet = Set.Make (String)
  32
  33 let rec filter_map f = function
  34   | [] -> []
  35   | x :: xs ->
  36     match f x with
  37     | Some y -> y :: filter_map f xs
  38     | None -> filter_map f xs
  39
  40 type whenexpr =
  41   | Expr_bool of bool
  42   | Expr_str of string
  43   | Expr_int of Big_int.big_int
  44   | Expr_float of float
  45   | Expr_var of string
  46   | Expr_and of whenexpr * whenexpr
  47   | Expr_or of whenexpr * whenexpr
  48   | Expr_eq of whenexpr * whenexpr
  49   | Expr_not of whenexpr
  50   | Expr_changes of string
  51
  52 (* This internal type is used during conversion of the OCaml AST
  53  * to the whenexpr type.
  54  *)
  55 type whenexpr_int =
  56   | IExpr_bool of bool
  57   | IExpr_str of string
  58   | IExpr_int of Big_int.big_int
  59   | IExpr_float of float
  60   | IExpr_var of string
  61   | IExpr_app of string * whenexpr_int list
  62
  63 (* Note that days are not necessarily expressible in seconds (because
  64  * of leap seconds), months are not expressible in days (because months
  65  * have different lengths), and years are not expressible in days
  66  * (because of leap days) although we could save a case here by
  67  * expressing years in months.
  68  *)
  69 type periodexpr =
  70   | Every_seconds of int
  71   | Every_days of int
  72   | Every_months of int
  73   | Every_years of int
  74
  75 type shell_script = {
  76   sh_loc : Loc.t;
  77   sh_script : string;
  78 }
  79
  80 type variable =
  81   | T_bool of bool
  82   | T_string of string
  83   | T_int of big_int
  84   | T_float of float
  85
  86 let variable_of_rpc = function
  87   | `bool_t b -> T_bool b
  88   | `string_t s -> T_string s
  89   | `int_t i -> T_int (big_int_of_string i)
  90   | `float_t f -> T_float f
  91
  92 let rpc_of_variable = function
  93   | T_bool b -> `bool_t b
  94   | T_string s -> `string_t s
  95   | T_int i -> `int_t (string_of_big_int i)
  96   | T_float f -> `float_t f
  97
  98 type variables = variable StringMap.t
  99
 100 type job_private = {
 101   (* The result of the previous evaluation.  This is used for
 102    * implementing edge-triggering, since we only trigger the job to run
 103    * when the state changes from false -> true.
 104    *)
 105   job_prev_eval_state : bool;
 106
 107   (* When the job {i ran} last time, we take a copy of the variables.
 108    * This allows us to implement the 'changes' operator.
 109    *)
 110   job_prev_variables : variables;
 111 }
 112
 113 let no_job_private =
 114   { job_prev_eval_state = false; job_prev_variables = StringMap.empty }
 115
 116 type job_cond =
 117   | When_job of whenexpr
 118   | Every_job of periodexpr
 119
 120 type job = {
 121   job_loc : Loc.t;
 122   job_name : string;
 123   job_cond : job_cond;
 124   job_script : shell_script;
 125   job_private : job_private;
 126 }
 127
 128 let rec expr_of_ast _loc ast =
 129   expr_of_iexpr _loc (iexpr_of_ast _loc ast)
 130
 131 and iexpr_of_ast _loc = function
 132   | ExId (_, IdLid (_, "true")) -> IExpr_bool true
 133   | ExId (_, IdLid (_, "false")) -> IExpr_bool false
 134   | ExStr (_, str) -> IExpr_str str
 135   | ExInt (_, i) -> IExpr_int (big_int_of_string i) (* XXX too large? *)
 136   | ExFlo (_, f) -> IExpr_float (float_of_string f)
 137   | ExId (_, IdLid (_, id)) -> IExpr_var id
 138
 139   (* In the OCaml AST, functions are curried right to left, so we
 140    * must uncurry to get the list of arguments.
 141    *)
 142   | ExApp (_, left_tree, right_arg) ->
 143     let f, left_args = uncurry_app_tree _loc left_tree in
 144     IExpr_app (f, List.rev_map (iexpr_of_ast _loc) (right_arg :: left_args))
 145
 146   | e ->
 147     (* https://groups.google.com/group/fa.caml/browse_thread/thread/f35452d085654bd6 *)
 148     eprintf "expr_of_ast: invalid expression: %!";
 149     let e = Ast.StExp (_loc, e) in
 150     Printers.OCaml.print_implem ~output_file:"/dev/stderr" e;
 151
 152     invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
 153
 154 and uncurry_app_tree _loc = function
 155   | ExId (_, IdLid (_, f)) -> f, []
 156   | ExApp (_, left_tree, right_arg) ->
 157     let f, left_args = uncurry_app_tree _loc left_tree in
 158     f, (right_arg :: left_args)
 159   | e ->
 160     eprintf "uncurry_app_tree: invalid expression: %!";
 161     let e = Ast.StExp (_loc, e) in
 162     Printers.OCaml.print_implem ~output_file:"/dev/stderr" e;
 163
 164     invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
 165
 166 and expr_of_iexpr _loc = function
 167   | IExpr_bool b -> Expr_bool b
 168   | IExpr_str s -> Expr_str s
 169   | IExpr_int i -> Expr_int i
 170   | IExpr_float f -> Expr_float f
 171   | IExpr_var v -> Expr_var v
 172
 173   | IExpr_app ("&&", exprs) ->
 174     (match exprs with
 175     | [e1; e2] -> Expr_and (expr_of_iexpr _loc e1, expr_of_iexpr _loc e2)
 176     | _ ->
 177       invalid_arg (sprintf "%s: && operator must be applied to two parameters"
 178                      (Loc.to_string _loc))
 179     )
 180
 181   | IExpr_app ("||", exprs) ->
 182     (match exprs with
 183     | [e1; e2] -> Expr_or (expr_of_iexpr _loc e1, expr_of_iexpr _loc e2)
 184     | _ ->
 185       invalid_arg (sprintf "%s: || operator must be applied to two parameters"
 186                       (Loc.to_string _loc))
 187     )
 188
 189   | IExpr_app (("="|"=="), exprs) ->
 190     (match exprs with
 191     | [e1; e2] -> Expr_eq (expr_of_iexpr _loc e1, expr_of_iexpr _loc e2)
 192     | _ ->
 193       invalid_arg (sprintf "%s: = operator must be applied to two parameters"
 194                       (Loc.to_string _loc))
 195     )
 196
 197   | IExpr_app ("!", exprs) ->
 198     (match exprs with
 199     | [e1] -> Expr_not (expr_of_iexpr _loc e1)
 200     | _ ->
 201       invalid_arg (sprintf "%s: ! operator must be applied to one parameter"
 202                       (Loc.to_string _loc))
 203     )
 204
 205   | IExpr_app (("change"|"changes"|"changed"), [IExpr_var v]) ->
 206     Expr_changes v
 207
 208   | IExpr_app (("change"|"changes"|"changed"), _) ->
 209     invalid_arg (sprintf "%s: 'changes' operator must be followed by a variable name"
 210                     (Loc.to_string _loc))
 211
 212   | IExpr_app (op, _) ->
 213     invalid_arg (sprintf "%s: unknown operator in expression: %s"
 214                    (Loc.to_string _loc) op)
 215
 216 let rec string_of_whenexpr = function
 217   | Expr_bool b -> sprintf "%b" b
 218   | Expr_str s -> sprintf "%S" s
 219   | Expr_int i -> sprintf "%s" (string_of_big_int i)
 220   | Expr_float f -> sprintf "%f" f
 221   | Expr_var v -> sprintf "%s" v
 222   | Expr_and (e1, e2) ->
 223     sprintf "%s && %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 224   | Expr_or (e1, e2) ->
 225     sprintf "%s || %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 226   | Expr_eq (e1, e2) ->
 227     sprintf "%s == %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 228   | Expr_not e -> sprintf "! %s" (string_of_whenexpr e)
 229   | Expr_changes v -> sprintf "changes %s" v
 230
 231 let string_of_periodexpr = function
 232   | Every_seconds 1 -> "1 second"
 233   | Every_seconds i -> sprintf "%d seconds" i
 234   | Every_days 1 -> "1 day"
 235   | Every_days i -> sprintf "%d days" i
 236   | Every_months 1 -> "1 month"
 237   | Every_months i -> sprintf "%d months" i
 238   | Every_years 1 -> "1 year"
 239   | Every_years i -> sprintf "%d years" i
 240
 241 let rec dependencies_of_whenexpr = function
 242   | Expr_bool _ -> []
 243   | Expr_str _ -> []
 244   | Expr_int _ -> []
 245   | Expr_float _ -> []
 246   | Expr_var v -> [v]
 247   | Expr_and (e1, e2) ->
 248     dependencies_of_whenexpr e1 @ dependencies_of_whenexpr e2
 249   | Expr_or (e1, e2) ->
 250     dependencies_of_whenexpr e1 @ dependencies_of_whenexpr e2
 251   | Expr_eq (e1, e2) ->
 252     dependencies_of_whenexpr e1 @ dependencies_of_whenexpr e2
 253   | Expr_not e -> dependencies_of_whenexpr e
 254   | Expr_changes v -> [v]
 255
 256 let dependencies_of_job = function
 257   | { job_cond = When_job whenexpr } -> dependencies_of_whenexpr whenexpr
 258   | { job_cond = Every_job _ } -> []
 259
 260 let rec eval_whenexpr job variables = function
 261   | Expr_bool b -> T_bool b
 262   | Expr_str s -> T_string s
 263   | Expr_int i -> T_int i
 264   | Expr_float f -> T_float f
 265
 266   | Expr_var v ->
 267     (try StringMap.find v variables with Not_found -> T_string "")
 268
 269   | Expr_and (e1, e2) ->
 270     if eval_whenexpr_as_bool job variables e1 &&
 271        eval_whenexpr_as_bool job variables e2 then
 272       T_bool true
 273     else
 274       T_bool false
 275
 276   | Expr_or (e1, e2) ->
 277     if eval_whenexpr_as_bool job variables e1 ||
 278        eval_whenexpr_as_bool job variables e2 then
 279       T_bool true
 280     else
 281       T_bool false
 282
 283   | Expr_eq (e1, e2) ->
 284     let e1 = eval_whenexpr job variables e1
 285     and e2 = eval_whenexpr job variables e2 in
 286     if 0 = compare_values e1 e2 then
 287       T_bool true
 288     else
 289       T_bool false
 290
 291   | Expr_not e ->
 292     if not (eval_whenexpr_as_bool job variables e) then
 293       T_bool true
 294     else
 295       T_bool false
 296
 297   | Expr_changes v ->
 298     let prev_value =
 299       try StringMap.find v job.job_private.job_prev_variables
 300       with Not_found -> T_string "" in
 301     let curr_value =
 302       try StringMap.find v variables
 303       with Not_found -> T_string "" in
 304
 305     if 0 <> compare_values prev_value curr_value then
 306       T_bool true
 307     else
 308       T_bool false
 309
 310 (* Call {!eval_whenexpr} and cast the result to a boolean. *)
 311 and eval_whenexpr_as_bool job variables expr =
 312   match eval_whenexpr job variables expr with
 313   | T_bool r -> r
 314   | T_string s -> s <> ""
 315   | T_int i -> sign_big_int i <> 0
 316   | T_float f -> f <> 0.
 317
 318 (* Do a comparison on two typed values and return -1/0/+1.  If the
 319  * types are different then we compare the values as strings.  The user
 320  * can avoid this by specifying types.
 321  *)
 322 and compare_values value1 value2 =
 323   match value1, value2 with
 324   | T_bool b1, T_bool b2 -> compare b1 b2
 325   | T_string s1, T_string s2 -> compare s1 s2
 326   | T_int i1, T_int i2 -> compare_big_int i1 i2
 327   | T_float f1, T_float f2 -> compare f1 f2
 328   | _ ->
 329     let value1 = value_as_string value1
 330     and value2 = value_as_string value2 in
 331     compare value1 value2
 332
 333 and value_as_string = function
 334   | T_bool b -> string_of_bool b
 335   | T_string s -> s
 336   | T_int i -> string_of_big_int i
 337   | T_float f -> string_of_float f
 338
 339 let job_evaluate job variables =
 340   match job with
 341   | { job_cond = Every_job _ } -> false, job
 342   | { job_cond = When_job whenexpr } ->
 343     let state = eval_whenexpr_as_bool job variables whenexpr in
 344
 345     (* Because jobs are edge-triggered, we're only interested in the
 346      * case where the evaluation state changes from false -> true.
 347      *)
 348     match job.job_private.job_prev_eval_state, state with
 349     | false, false
 350     | true, true
 351     | true, false ->
 352       let jobp = { job.job_private with job_prev_eval_state = state } in
 353       let job = { job with job_private = jobp } in
 354       false, job
 355
 356     | false, true ->
 357       let jobp = { job_prev_eval_state = true;
 358                    job_prev_variables = variables } in
 359       let job = { job with job_private = jobp } in
 360       true, job