2 * Copyright (C) 2012 Red Hat Inc.
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.
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.
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.
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 []
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 []
40 module StringSet = Set.Make (String)
42 let (//) = Filename.concat
44 let rec filter_map f = function
48 | Some y -> y :: filter_map f xs
49 | None -> filter_map f xs
54 | Expr_int of Big_int.big_int
57 | Expr_and of whenexpr * whenexpr
58 | Expr_or of whenexpr * whenexpr
59 | Expr_lt of whenexpr * whenexpr
60 | Expr_le of whenexpr * whenexpr
61 | Expr_eq of whenexpr * whenexpr
62 | Expr_ge of whenexpr * whenexpr
63 | Expr_gt of whenexpr * whenexpr
64 | Expr_not of whenexpr
65 | Expr_add of whenexpr * whenexpr
66 | Expr_sub of whenexpr * whenexpr
67 | Expr_mul of whenexpr * whenexpr
68 | Expr_div of whenexpr * whenexpr
69 | Expr_mod of whenexpr * whenexpr
70 | Expr_changes of string
71 | Expr_increases of string
72 | Expr_decreases of string
75 (* This internal type is used during conversion of the OCaml AST
76 * to the whenexpr type.
81 | IExpr_int of Big_int.big_int
82 | IExpr_float of float
84 | IExpr_app of string * whenexpr_int list
86 (* Note that days are not necessarily expressible in seconds (because
87 * of leap seconds), months are not expressible in days (because months
88 * have different lengths), and years are not expressible in days
89 * (because of leap days) although we could save a case here by
90 * expressing years in months.
93 | Every_seconds of int
109 let variable_of_rpc = function
110 | `bool_t b -> T_bool b
111 | `string_t s -> T_string s
112 | `int_t i -> T_int (big_int_of_string i)
113 | `float_t f -> T_float f
115 let rpc_of_variable = function
116 | T_bool b -> `bool_t b
117 | T_string s -> `string_t s
118 | T_int i -> `int_t (string_of_big_int i)
119 | T_float f -> `float_t f
121 type variables = variable StringMap.t
124 (* The result of the previous evaluation. This is used for
125 * implementing edge-triggering, since we only trigger the job to run
126 * when the state changes from false -> true.
128 job_prev_eval_state : bool;
130 (* When the job {i ran} last time, we take a copy of the variables.
131 * This allows us to implement the 'changes' operator.
133 job_prev_variables : variables;
137 { job_prev_eval_state = false; job_prev_variables = StringMap.empty }
140 | When_job of whenexpr
141 | Every_job of periodexpr
147 job_script : shell_script;
148 job_private : job_private;
151 let rec expr_of_ast _loc ast =
152 expr_of_iexpr _loc (iexpr_of_ast _loc ast)
154 and iexpr_of_ast _loc = function
155 | ExId (_, IdUid (_, "True")) -> IExpr_bool true
156 | ExId (_, IdUid (_, "False")) -> IExpr_bool false
157 | ExStr (_, str) -> IExpr_str str
158 | ExInt (_, i) -> IExpr_int (big_int_of_string i) (* XXX too large? *)
159 | ExFlo (_, f) -> IExpr_float (float_of_string f)
160 | ExId (_, IdLid (_, id)) -> IExpr_var id
162 (* In the OCaml AST, functions are curried right to left, so we
163 * must uncurry to get the list of arguments.
165 | ExApp (_, left_tree, right_arg) ->
166 let f, left_args = uncurry_app_tree _loc left_tree in
167 IExpr_app (f, List.rev_map (iexpr_of_ast _loc) (right_arg :: left_args))
170 (* https://groups.google.com/group/fa.caml/browse_thread/thread/f35452d085654bd6 *)
171 eprintf "expr_of_ast: invalid expression: %!";
172 let e = Ast.StExp (_loc, e) in
173 Printers.OCaml.print_implem ~output_file:"/dev/stderr" e;
175 invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
177 and uncurry_app_tree _loc = function
178 | ExId (_, IdLid (_, f)) -> f, []
179 | ExApp (_, left_tree, right_arg) ->
180 let f, left_args = uncurry_app_tree _loc left_tree in
181 f, (right_arg :: left_args)
183 eprintf "uncurry_app_tree: invalid expression: %!";
184 let e = Ast.StExp (_loc, e) in
185 Printers.OCaml.print_implem ~output_file:"/dev/stderr" e;
187 invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
189 and expr_of_iexpr _loc = function
190 | IExpr_bool b -> Expr_bool b
191 | IExpr_str s -> Expr_str s
192 | IExpr_int i -> Expr_int i
193 | IExpr_float f -> Expr_float f
194 | IExpr_var v -> Expr_var v
196 | IExpr_app ("&&", exprs) ->
197 two_params _loc "&&" exprs (fun e1 e2 -> Expr_and (e1, e2))
199 | IExpr_app ("||", exprs) ->
200 two_params _loc "||" exprs (fun e1 e2 -> Expr_or (e1, e2))
202 | IExpr_app ("<", exprs) ->
203 two_params _loc "<" exprs (fun e1 e2 -> Expr_lt (e1, e2))
205 | IExpr_app ("<=", exprs) ->
206 two_params _loc "<=" exprs (fun e1 e2 -> Expr_le (e1, e2))
208 | IExpr_app (("="|"=="), exprs) ->
209 two_params _loc "=" exprs (fun e1 e2 -> Expr_eq (e1, e2))
211 | IExpr_app (">=", exprs) ->
212 two_params _loc ">=" exprs (fun e1 e2 -> Expr_ge (e1, e2))
214 | IExpr_app (">", exprs) ->
215 two_params _loc ">" exprs (fun e1 e2 -> Expr_gt (e1, e2))
217 | IExpr_app ("!", exprs) ->
218 one_param _loc "!" exprs (fun e1 -> Expr_not e1)
220 | IExpr_app ("+", exprs) ->
221 two_params _loc "+" exprs (fun e1 e2 -> Expr_add (e1, e2))
223 | IExpr_app ("-", exprs) ->
224 two_params _loc "+" exprs (fun e1 e2 -> Expr_sub (e1, e2))
226 | IExpr_app ("*", exprs) ->
227 two_params _loc "+" exprs (fun e1 e2 -> Expr_mul (e1, e2))
229 | IExpr_app ("/", exprs) ->
230 two_params _loc "+" exprs (fun e1 e2 -> Expr_div (e1, e2))
232 | IExpr_app ("mod", exprs) ->
233 two_params _loc "+" exprs (fun e1 e2 -> Expr_mod (e1, e2))
235 | IExpr_app (("change"|"changes"|"changed"), [IExpr_var v]) ->
238 | IExpr_app (("inc"|"increase"|"increases"|"increased"), [IExpr_var v]) ->
241 | IExpr_app (("dec"|"decrease"|"decreases"|"decreased"), [IExpr_var v]) ->
244 | IExpr_app (("prev"|"previous"), [IExpr_var v]) ->
247 | IExpr_app (("change"|"changes"|"changed"|"inc"|"increase"|"increases"|"increased"|"dec"|"decrease"|"decreases"|"decreased"|"prev"|"previous") as op, _) ->
248 invalid_arg (sprintf "%s: '%s' operator must be followed by a variable name"
249 op (Loc.to_string _loc))
251 | IExpr_app (op, _) ->
252 invalid_arg (sprintf "%s: unknown operator in expression: %s"
253 (Loc.to_string _loc) op)
255 and two_params _loc op exprs f =
257 | [e1; e2] -> f (expr_of_iexpr _loc e1) (expr_of_iexpr _loc e2)
259 invalid_arg (sprintf "%s: %s operator must be applied to two parameters"
260 op (Loc.to_string _loc))
262 and one_param _loc op exprs f =
264 | [e1] -> f (expr_of_iexpr _loc e1)
266 invalid_arg (sprintf "%s: %s operator must be applied to one parameter"
267 op (Loc.to_string _loc))
269 let rec string_of_whenexpr = function
270 | Expr_bool b -> sprintf "%b" b
271 | Expr_str s -> sprintf "%S" s
272 | Expr_int i -> sprintf "%s" (string_of_big_int i)
273 | Expr_float f -> sprintf "%f" f
274 | Expr_var v -> sprintf "%s" v
275 | Expr_and (e1, e2) ->
276 sprintf "%s && %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
277 | Expr_or (e1, e2) ->
278 sprintf "%s || %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
279 | Expr_lt (e1, e2) ->
280 sprintf "%s < %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
281 | Expr_le (e1, e2) ->
282 sprintf "%s <= %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
283 | Expr_eq (e1, e2) ->
284 sprintf "%s == %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
285 | Expr_ge (e1, e2) ->
286 sprintf "%s >= %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
287 | Expr_gt (e1, e2) ->
288 sprintf "%s > %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
289 | Expr_not e -> sprintf "! %s" (string_of_whenexpr e)
290 | Expr_add (e1, e2) ->
291 sprintf "%s + %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
292 | Expr_sub (e1, e2) ->
293 sprintf "%s - %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
294 | Expr_mul (e1, e2) ->
295 sprintf "%s * %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
296 | Expr_div (e1, e2) ->
297 sprintf "%s / %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
298 | Expr_mod (e1, e2) ->
299 sprintf "%s mod %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
300 | Expr_changes v -> sprintf "changes %s" v
301 | Expr_increases v -> sprintf "increases %s" v
302 | Expr_decreases v -> sprintf "decreases %s" v
303 | Expr_prev v -> sprintf "prev %s" v
305 let string_of_periodexpr = function
306 | Every_seconds 1 -> "1 second"
307 | Every_seconds i -> sprintf "%d seconds" i
308 | Every_days 1 -> "1 day"
309 | Every_days i -> sprintf "%d days" i
310 | Every_months 1 -> "1 month"
311 | Every_months i -> sprintf "%d months" i
312 | Every_years 1 -> "1 year"
313 | Every_years i -> sprintf "%d years" i
315 let rec dependencies_of_whenexpr = function
332 | Expr_mod (e1, e2) ->
333 dependencies_of_whenexpr e1 @ dependencies_of_whenexpr e2
335 dependencies_of_whenexpr e
341 let dependencies_of_job = function
342 | { job_cond = When_job whenexpr } -> dependencies_of_whenexpr whenexpr
343 | { job_cond = Every_job _ } -> []
345 let rec eval_whenexpr job variables = function
346 | Expr_bool b -> T_bool b
347 | Expr_str s -> T_string s
348 | Expr_int i -> T_int i
349 | Expr_float f -> T_float f
352 (try StringMap.find v variables with Not_found -> T_string "")
354 | Expr_and (e1, e2) ->
355 if eval_whenexpr_as_bool job variables e1 &&
356 eval_whenexpr_as_bool job variables e2 then
361 | Expr_or (e1, e2) ->
362 if eval_whenexpr_as_bool job variables e1 ||
363 eval_whenexpr_as_bool job variables e2 then
368 | Expr_lt (e1, e2) ->
369 let e1 = eval_whenexpr job variables e1
370 and e2 = eval_whenexpr job variables e2 in
371 if compare_values e1 e2 < 0 then
376 | Expr_le (e1, e2) ->
377 let e1 = eval_whenexpr job variables e1
378 and e2 = eval_whenexpr job variables e2 in
379 if compare_values e1 e2 <= 0 then
384 | Expr_eq (e1, e2) ->
385 let e1 = eval_whenexpr job variables e1
386 and e2 = eval_whenexpr job variables e2 in
387 if compare_values e1 e2 = 0 then
392 | Expr_ge (e1, e2) ->
393 let e1 = eval_whenexpr job variables e1
394 and e2 = eval_whenexpr job variables e2 in
395 if compare_values e1 e2 >= 0 then
400 | Expr_gt (e1, e2) ->
401 let e1 = eval_whenexpr job variables e1
402 and e2 = eval_whenexpr job variables e2 in
403 if compare_values e1 e2 > 0 then
409 if not (eval_whenexpr_as_bool job variables e) then
414 | Expr_add (e1, e2) ->
415 let e1 = eval_whenexpr job variables e1
416 and e2 = eval_whenexpr job variables e2 in
419 | Expr_sub (e1, e2) ->
420 let e1 = eval_whenexpr job variables e1
421 and e2 = eval_whenexpr job variables e2 in
424 | Expr_mul (e1, e2) ->
425 let e1 = eval_whenexpr job variables e1
426 and e2 = eval_whenexpr job variables e2 in
429 | Expr_div (e1, e2) ->
430 let e1 = eval_whenexpr job variables e1
431 and e2 = eval_whenexpr job variables e2 in
434 | Expr_mod (e1, e2) ->
435 let e1 = eval_whenexpr job variables e1
436 and e2 = eval_whenexpr job variables e2 in
440 let prev_value, curr_value = get_prev_curr_value job variables v in
441 if compare_values prev_value curr_value <> 0 then
446 | Expr_increases v ->
447 let prev_value, curr_value = get_prev_curr_value job variables v in
448 if compare_values prev_value curr_value > 0 then
453 | Expr_decreases v ->
454 let prev_value, curr_value = get_prev_curr_value job variables v in
455 if compare_values prev_value curr_value < 0 then
461 try StringMap.find v job.job_private.job_prev_variables
462 with Not_found -> T_string ""
464 and get_prev_curr_value job variables v =
466 try StringMap.find v job.job_private.job_prev_variables
467 with Not_found -> T_string "" in
469 try StringMap.find v variables
470 with Not_found -> T_string "" in
471 prev_value, curr_value
473 (* Call {!eval_whenexpr} and cast the result to a boolean. *)
474 and eval_whenexpr_as_bool job variables expr =
475 match eval_whenexpr job variables expr with
477 | T_string s -> s <> ""
478 | T_int i -> sign_big_int i <> 0
479 | T_float f -> f <> 0.
481 (* Do a comparison on two typed values and return -1/0/+1. If the
482 * types are different then we compare the values as strings. The user
483 * can avoid this by specifying types.
485 and compare_values value1 value2 =
486 match value1, value2 with
487 | T_bool b1, T_bool b2 -> compare b1 b2
488 | T_string s1, T_string s2 -> compare s1 s2
489 | T_int i1, T_int i2 -> compare_big_int i1 i2
490 | T_float f1, T_float f2 -> compare f1 f2
492 let value1 = string_of_variable value1
493 and value2 = string_of_variable value2 in
494 compare value1 value2
496 (* + operator is addition or string concatenation. *)
497 and add_values value1 value2 =
498 match value1, value2 with
499 | T_int i1, T_int i2 -> T_int (add_big_int i1 i2)
500 | T_float i1, T_float i2 -> T_float (i1 +. i2)
501 | T_int i1, T_float i2 -> T_float (float_of_big_int i1 +. i2)
502 | T_float i1, T_int i2 -> T_float (i1 +. float_of_big_int i2)
503 | T_string i1, T_string i2 -> T_string (i1 ^ i2)
506 (sprintf "incompatible types in addition: %s + %s"
507 (printable_string_of_variable value1)
508 (printable_string_of_variable value2))
510 and sub_values value1 value2 =
511 match value1, value2 with
512 | T_int i1, T_int i2 -> T_int (sub_big_int i1 i2)
513 | T_float i1, T_float i2 -> T_float (i1 -. i2)
514 | T_int i1, T_float i2 -> T_float (float_of_big_int i1 -. i2)
515 | T_float i1, T_int i2 -> T_float (i1 -. float_of_big_int i2)
518 (sprintf "incompatible types in subtraction: %s - %s"
519 (printable_string_of_variable value1)
520 (printable_string_of_variable value2))
522 and mul_values value1 value2 =
523 match value1, value2 with
524 | T_int i1, T_int i2 -> T_int (mult_big_int i1 i2)
525 | T_float i1, T_float i2 -> T_float (i1 *. i2)
526 | T_int i1, T_float i2 -> T_float (float_of_big_int i1 *. i2)
527 | T_float i1, T_int i2 -> T_float (i1 *. float_of_big_int i2)
530 (sprintf "incompatible types in multiplication: %s * %s"
531 (printable_string_of_variable value1)
532 (printable_string_of_variable value2))
534 and div_values value1 value2 =
535 match value1, value2 with
536 | T_int i1, T_int i2 -> T_int (div_big_int i1 i2)
537 | T_float i1, T_float i2 -> T_float (i1 /. i2)
538 | T_int i1, T_float i2 -> T_float (float_of_big_int i1 /. i2)
539 | T_float i1, T_int i2 -> T_float (i1 /. float_of_big_int i2)
542 (sprintf "incompatible types in division: %s / %s"
543 (printable_string_of_variable value1)
544 (printable_string_of_variable value2))
546 and mod_values value1 value2 =
547 match value1, value2 with
548 | T_int i1, T_int i2 -> T_int (mod_big_int i1 i2)
549 | T_float i1, T_float i2 -> T_float (mod_float i1 i2)
550 | T_int i1, T_float i2 -> T_float (mod_float (float_of_big_int i1) i2)
551 | T_float i1, T_int i2 -> T_float (mod_float i1 (float_of_big_int i2))
554 (sprintf "incompatible types in modulo: %s mod %s"
555 (printable_string_of_variable value1)
556 (printable_string_of_variable value2))
558 and string_of_variable = function
559 | T_bool b -> string_of_bool b
561 | T_int i -> string_of_big_int i
562 | T_float f -> string_of_float f
564 and printable_string_of_variable = function
565 | T_bool b -> string_of_bool b
566 | T_string s -> sprintf "%S" s
567 | T_int i -> string_of_big_int i
568 | T_float f -> string_of_float f
570 let job_evaluate job variables =
572 | { job_cond = Every_job _ } -> false, job
573 | { job_cond = When_job whenexpr } ->
574 let state = eval_whenexpr_as_bool job variables whenexpr in
576 (* Because jobs are edge-triggered, we're only interested in the
577 * case where the evaluation state changes from false -> true.
579 match job.job_private.job_prev_eval_state, state with
583 let jobp = { job.job_private with job_prev_eval_state = state } in
584 let job = { job with job_private = jobp } in
588 let jobp = { job_prev_eval_state = true;
589 job_prev_variables = variables } in
590 let job = { job with job_private = jobp } in
593 let next_periodexpr =
594 (* Round up 'a' to the next multiple of 'i'. *)
595 let round_up_float a i =
596 let r = mod_float a i in
597 if r = 0. then a +. i else a +. (i -. r)
600 if r = 0 then a + i else a + (i - r)
605 let i = float_of_int i in
611 (* Round 'tm' up to the first day of the next year. *)
612 let year = round_up tm.tm_year i in
613 let tm = { tm with tm_sec = 0; tm_min = 0; tm_hour = 0;
614 tm_mday = 1; tm_mon = 0; tm_year = year } in
618 let t = Date.from_unixfloat t in
619 let t0 = Date.make 1970 1 1 in
621 (* Number of whole days since Unix Epoch. *)
622 let nb_days = Date.Period.safe_nb_days (Date.sub t t0) in
624 let nb_days = round_up nb_days i in
625 let t' = Date.add t0 (Date.Period.day nb_days) in
629 (* Calculate number of whole months since Unix Epoch. *)
631 let months = 12 * (tm.tm_year - 70) + tm.tm_mon in
633 let months = round_up months i in
634 let t0 = Date.make 1970 1 1 in
635 let t' = Date.add t0 (Date.Period.month months) in