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_eq of whenexpr * whenexpr
60 | Expr_not of whenexpr
61 | Expr_changes of string
63 (* This internal type is used during conversion of the OCaml AST
64 * to the whenexpr type.
69 | IExpr_int of Big_int.big_int
70 | IExpr_float of float
72 | IExpr_app of string * whenexpr_int list
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.
81 | Every_seconds of int
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
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
109 type variables = variable StringMap.t
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.
116 job_prev_eval_state : bool;
118 (* When the job {i ran} last time, we take a copy of the variables.
119 * This allows us to implement the 'changes' operator.
121 job_prev_variables : variables;
125 { job_prev_eval_state = false; job_prev_variables = StringMap.empty }
128 | When_job of whenexpr
129 | Every_job of periodexpr
135 job_script : shell_script;
136 job_private : job_private;
139 let rec expr_of_ast _loc ast =
140 expr_of_iexpr _loc (iexpr_of_ast _loc ast)
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
150 (* In the OCaml AST, functions are curried right to left, so we
151 * must uncurry to get the list of arguments.
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))
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;
163 invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
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)
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;
175 invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
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
184 | IExpr_app ("&&", exprs) ->
186 | [e1; e2] -> Expr_and (expr_of_iexpr _loc e1, expr_of_iexpr _loc e2)
188 invalid_arg (sprintf "%s: && operator must be applied to two parameters"
189 (Loc.to_string _loc))
192 | IExpr_app ("||", exprs) ->
194 | [e1; e2] -> Expr_or (expr_of_iexpr _loc e1, expr_of_iexpr _loc e2)
196 invalid_arg (sprintf "%s: || operator must be applied to two parameters"
197 (Loc.to_string _loc))
200 | IExpr_app (("="|"=="), exprs) ->
202 | [e1; e2] -> Expr_eq (expr_of_iexpr _loc e1, expr_of_iexpr _loc e2)
204 invalid_arg (sprintf "%s: = operator must be applied to two parameters"
205 (Loc.to_string _loc))
208 | IExpr_app ("!", exprs) ->
210 | [e1] -> Expr_not (expr_of_iexpr _loc e1)
212 invalid_arg (sprintf "%s: ! operator must be applied to one parameter"
213 (Loc.to_string _loc))
216 | IExpr_app (("change"|"changes"|"changed"), [IExpr_var v]) ->
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))
223 | IExpr_app (op, _) ->
224 invalid_arg (sprintf "%s: unknown operator in expression: %s"
225 (Loc.to_string _loc) op)
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
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
252 let rec dependencies_of_whenexpr = function
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]
267 let dependencies_of_job = function
268 | { job_cond = When_job whenexpr } -> dependencies_of_whenexpr whenexpr
269 | { job_cond = Every_job _ } -> []
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
278 (try StringMap.find v variables with Not_found -> T_string "")
280 | Expr_and (e1, e2) ->
281 if eval_whenexpr_as_bool job variables e1 &&
282 eval_whenexpr_as_bool job variables e2 then
287 | Expr_or (e1, e2) ->
288 if eval_whenexpr_as_bool job variables e1 ||
289 eval_whenexpr_as_bool job variables e2 then
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
303 if not (eval_whenexpr_as_bool job variables e) then
310 try StringMap.find v job.job_private.job_prev_variables
311 with Not_found -> T_string "" in
313 try StringMap.find v variables
314 with Not_found -> T_string "" in
316 if 0 <> compare_values prev_value curr_value then
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
325 | T_string s -> s <> ""
326 | T_int i -> sign_big_int i <> 0
327 | T_float f -> f <> 0.
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.
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
340 let value1 = value_as_string value1
341 and value2 = value_as_string value2 in
342 compare value1 value2
344 and value_as_string = function
345 | T_bool b -> string_of_bool b
347 | T_int i -> string_of_big_int i
348 | T_float f -> string_of_float f
350 let job_evaluate job variables =
352 | { job_cond = Every_job _ } -> false, job
353 | { job_cond = When_job whenexpr } ->
354 let state = eval_whenexpr_as_bool job variables whenexpr in
356 (* Because jobs are edge-triggered, we're only interested in the
357 * case where the evaluation state changes from false -> true.
359 match job.job_private.job_prev_eval_state, state with
363 let jobp = { job.job_private with job_prev_eval_state = state } in
364 let job = { job with job_private = jobp } in
368 let jobp = { job_prev_eval_state = true;
369 job_prev_variables = variables } in
370 let job = { job with job_private = jobp } in
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)
380 if r = 0 then a + i else a + (i - r)
385 let i = float_of_int i in
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
398 let t = Date.from_unixfloat t in
399 let t0 = Date.make 1970 1 1 in
401 (* Number of whole days since Unix Epoch. *)
402 let nb_days = Date.Period.safe_nb_days (Date.sub t t0) in
404 let nb_days = round_up nb_days i in
405 let t' = Date.add t0 (Date.Period.day nb_days) in
409 (* Calculate number of whole months since Unix Epoch. *)
411 let months = 12 * (tm.tm_year - 70) + tm.tm_mon in
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