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.
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 []
31 module StringSet = Set.Make (String)
33 let rec filter_map f = function
37 | Some y -> y :: filter_map f xs
38 | None -> filter_map f xs
43 | Expr_int of Big_int.big_int
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
52 (* This internal type is used during conversion of the OCaml AST
53 * to the whenexpr type.
58 | IExpr_int of Big_int.big_int
59 | IExpr_float of float
61 | IExpr_app of string * whenexpr_int list
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.
70 | Every_seconds of int
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
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
98 type variables = variable StringMap.t
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.
105 job_prev_eval_state : bool;
107 (* When the job {i ran} last time, we take a copy of the variables.
108 * This allows us to implement the 'changes' operator.
110 job_prev_variables : variables;
114 { job_prev_eval_state = false; job_prev_variables = StringMap.empty }
117 | When_job of whenexpr
118 | Every_job of periodexpr
124 job_script : shell_script;
125 job_private : job_private;
128 let rec expr_of_ast _loc ast =
129 expr_of_iexpr _loc (iexpr_of_ast _loc ast)
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
139 (* In the OCaml AST, functions are curried right to left, so we
140 * must uncurry to get the list of arguments.
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))
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;
152 invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
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)
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;
164 invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
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
173 | IExpr_app ("&&", exprs) ->
175 | [e1; e2] -> Expr_and (expr_of_iexpr _loc e1, expr_of_iexpr _loc e2)
177 invalid_arg (sprintf "%s: && operator must be applied to two parameters"
178 (Loc.to_string _loc))
181 | IExpr_app ("||", exprs) ->
183 | [e1; e2] -> Expr_or (expr_of_iexpr _loc e1, expr_of_iexpr _loc e2)
185 invalid_arg (sprintf "%s: || operator must be applied to two parameters"
186 (Loc.to_string _loc))
189 | IExpr_app (("="|"=="), exprs) ->
191 | [e1; e2] -> Expr_eq (expr_of_iexpr _loc e1, expr_of_iexpr _loc e2)
193 invalid_arg (sprintf "%s: = operator must be applied to two parameters"
194 (Loc.to_string _loc))
197 | IExpr_app ("!", exprs) ->
199 | [e1] -> Expr_not (expr_of_iexpr _loc e1)
201 invalid_arg (sprintf "%s: ! operator must be applied to one parameter"
202 (Loc.to_string _loc))
205 | IExpr_app (("change"|"changes"|"changed"), [IExpr_var v]) ->
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))
212 | IExpr_app (op, _) ->
213 invalid_arg (sprintf "%s: unknown operator in expression: %s"
214 (Loc.to_string _loc) op)
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
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
241 let rec dependencies_of_whenexpr = function
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]
256 let dependencies_of_job = function
257 | { job_cond = When_job whenexpr } -> dependencies_of_whenexpr whenexpr
258 | { job_cond = Every_job _ } -> []
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
267 (try StringMap.find v variables with Not_found -> T_string "")
269 | Expr_and (e1, e2) ->
270 if eval_whenexpr_as_bool job variables e1 &&
271 eval_whenexpr_as_bool job variables e2 then
276 | Expr_or (e1, e2) ->
277 if eval_whenexpr_as_bool job variables e1 ||
278 eval_whenexpr_as_bool job variables e2 then
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
292 if not (eval_whenexpr_as_bool job variables e) then
299 try StringMap.find v job.job_private.job_prev_variables
300 with Not_found -> T_string "" in
302 try StringMap.find v variables
303 with Not_found -> T_string "" in
305 if 0 <> compare_values prev_value curr_value then
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
314 | T_string s -> s <> ""
315 | T_int i -> sign_big_int i <> 0
316 | T_float f -> f <> 0.
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.
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
329 let value1 = value_as_string value1
330 and value2 = value_as_string value2 in
331 compare value1 value2
333 and value_as_string = function
334 | T_bool b -> string_of_bool b
336 | T_int i -> string_of_big_int i
337 | T_float f -> string_of_float f
339 let job_evaluate job variables =
341 | { job_cond = Every_job _ } -> false, job
342 | { job_cond = When_job whenexpr } ->
343 let state = eval_whenexpr_as_bool job variables whenexpr in
345 (* Because jobs are edge-triggered, we're only interested in the
346 * case where the evaluation state changes from false -> true.
348 match job.job_private.job_prev_eval_state, state with
352 let jobp = { job.job_private with job_prev_eval_state = state } in
353 let job = { job with job_private = jobp } in
357 let jobp = { job_prev_eval_state = true;
358 job_prev_variables = variables } in
359 let job = { job with job_private = jobp } in