--- /dev/null
+(* whenjobs
+ * Copyright (C) 2012 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Camlp4.PreCast
+open Ast
+
+open Big_int
+open Printf
+
+module StringMap = struct
+ include Map.Make (String)
+ let keys m = fold (fun k _ ks -> k :: ks) m []
+ let values m = fold (fun _ v vs -> v :: vs) m []
+end
+
+module StringSet = Set.Make (String)
+
+type whenexpr =
+ | Expr_bool of bool
+ | Expr_str of string
+ | Expr_int of Big_int.big_int
+ | Expr_float of float
+ | Expr_var of string
+ | Expr_and of whenexpr * whenexpr
+ | Expr_or of whenexpr * whenexpr
+ | Expr_eq of whenexpr * whenexpr
+ | Expr_not of whenexpr
+ | Expr_changes of string
+
+(* This internal type is used during conversion of the OCaml AST
+ * to the whenexpr type.
+ *)
+type whenexpr_int =
+ | IExpr_bool of bool
+ | IExpr_str of string
+ | IExpr_int of Big_int.big_int
+ | IExpr_float of float
+ | IExpr_var of string
+ | IExpr_app of string * whenexpr_int list
+
+(* Note that days are not necessarily expressible in seconds (because
+ * of leap seconds), months are not expressible in days (because months
+ * have different lengths), and years are not expressible in days
+ * (because of leap days) although we could save a case here by
+ * expressing years in months.
+ *)
+type periodexpr =
+ | Every_seconds of int
+ | Every_days of int
+ | Every_months of int
+ | Every_years of int
+
+type shell_script = {
+ sh_loc : Loc.t;
+ sh_script : string;
+}
+
+type variable =
+ | T_bool of bool
+ | T_string of string
+ | T_int of big_int
+ | T_float of float
+
+let variable_of_rpc = function
+ | `bool_t b -> T_bool b
+ | `string_t s -> T_string s
+ | `int_t i -> T_int (big_int_of_string i)
+ | `float_t f -> T_float f
+
+let rpc_of_variable = function
+ | T_bool b -> `bool_t b
+ | T_string s -> `string_t s
+ | T_int i -> `int_t (string_of_big_int i)
+ | T_float f -> `float_t f
+
+type variables = variable StringMap.t
+
+type job_private = {
+ (* The result of the previous evaluation. This is used for
+ * implementing edge-triggering, since we only trigger the job to run
+ * when the state changes from false -> true.
+ *)
+ job_prev_eval_state : bool;
+
+ (* When the job {i ran} last time, we take a copy of the variables.
+ * This allows us to implement the 'changes' operator.
+ *)
+ job_prev_variables : variables;
+}
+
+let no_job_private =
+ { job_prev_eval_state = false; job_prev_variables = StringMap.empty }
+
+type job_cond =
+ | When_job of whenexpr
+ | Every_job of periodexpr
+
+type job = {
+ job_loc : Loc.t;
+ job_name : string;
+ job_cond : job_cond;
+ job_script : shell_script;
+ job_private : job_private;
+}
+
+let rec expr_of_ast _loc ast =
+ expr_of_iexpr _loc (iexpr_of_ast _loc ast)
+
+and iexpr_of_ast _loc = function
+ | ExId (_, IdLid (_, "true")) -> IExpr_bool true
+ | ExId (_, IdLid (_, "false")) -> IExpr_bool false
+ | ExStr (_, str) -> IExpr_str str
+ | ExInt (_, i) -> IExpr_int (big_int_of_string i) (* XXX too large? *)
+ | ExFlo (_, f) -> IExpr_float (float_of_string f)
+ | ExId (_, IdLid (_, id)) -> IExpr_var id
+
+ (* In the OCaml AST, functions are curried right to left, so we
+ * must uncurry to get the list of arguments.
+ *)
+ | ExApp (_, left_tree, right_arg) ->
+ let f, left_args = uncurry_app_tree _loc left_tree in
+ IExpr_app (f, List.rev_map (iexpr_of_ast _loc) (right_arg :: left_args))
+
+ | e ->
+ (* https://groups.google.com/group/fa.caml/browse_thread/thread/f35452d085654bd6 *)
+ eprintf "expr_of_ast: invalid expression: %!";
+ let e = Ast.StExp (_loc, e) in
+ Printers.OCaml.print_implem ~output_file:"/dev/stderr" e;
+
+ invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
+
+and uncurry_app_tree _loc = function
+ | ExId (_, IdLid (_, f)) -> f, []
+ | ExApp (_, left_tree, right_arg) ->
+ let f, left_args = uncurry_app_tree _loc left_tree in
+ f, (right_arg :: left_args)
+ | e ->
+ eprintf "uncurry_app_tree: invalid expression: %!";
+ let e = Ast.StExp (_loc, e) in
+ Printers.OCaml.print_implem ~output_file:"/dev/stderr" e;
+
+ invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
+
+and expr_of_iexpr _loc = function
+ | IExpr_bool b -> Expr_bool b
+ | IExpr_str s -> Expr_str s
+ | IExpr_int i -> Expr_int i
+ | IExpr_float f -> Expr_float f
+ | IExpr_var v -> Expr_var v
+
+ | IExpr_app ("&&", exprs) ->
+ (match exprs with
+ | [e1; e2] -> Expr_and (expr_of_iexpr _loc e1, expr_of_iexpr _loc e2)
+ | _ ->
+ invalid_arg (sprintf "%s: && operator must be applied to two parameters"
+ (Loc.to_string _loc))
+ )
+
+ | IExpr_app ("||", exprs) ->
+ (match exprs with
+ | [e1; e2] -> Expr_or (expr_of_iexpr _loc e1, expr_of_iexpr _loc e2)
+ | _ ->
+ invalid_arg (sprintf "%s: || operator must be applied to two parameters"
+ (Loc.to_string _loc))
+ )
+
+ | IExpr_app (("="|"=="), exprs) ->
+ (match exprs with
+ | [e1; e2] -> Expr_eq (expr_of_iexpr _loc e1, expr_of_iexpr _loc e2)
+ | _ ->
+ invalid_arg (sprintf "%s: = operator must be applied to two parameters"
+ (Loc.to_string _loc))
+ )
+
+ | IExpr_app ("!", exprs) ->
+ (match exprs with
+ | [e1] -> Expr_not (expr_of_iexpr _loc e1)
+ | _ ->
+ invalid_arg (sprintf "%s: ! operator must be applied to one parameter"
+ (Loc.to_string _loc))
+ )
+
+ | IExpr_app (("change"|"changes"|"changed"), [IExpr_var v]) ->
+ Expr_changes v
+
+ | IExpr_app (("change"|"changes"|"changed"), _) ->
+ invalid_arg (sprintf "%s: 'changes' operator must be followed by a variable name"
+ (Loc.to_string _loc))
+
+ | IExpr_app (op, _) ->
+ invalid_arg (sprintf "%s: unknown operator in expression: %s"
+ (Loc.to_string _loc) op)
+
+let rec string_of_whenexpr = function
+ | Expr_bool b -> sprintf "%b" b
+ | Expr_str s -> sprintf "%S" s
+ | Expr_int i -> sprintf "%s" (string_of_big_int i)
+ | Expr_float f -> sprintf "%f" f
+ | Expr_var v -> sprintf "%s" v
+ | Expr_and (e1, e2) ->
+ sprintf "%s && %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+ | Expr_or (e1, e2) ->
+ sprintf "%s || %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+ | Expr_eq (e1, e2) ->
+ sprintf "%s == %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+ | Expr_not e -> sprintf "! %s" (string_of_whenexpr e)
+ | Expr_changes v -> sprintf "changes %s" v
+
+let string_of_periodexpr = function
+ | Every_seconds 1 -> "1 second"
+ | Every_seconds i -> sprintf "%d seconds" i
+ | Every_days 1 -> "1 day"
+ | Every_days i -> sprintf "%d days" i
+ | Every_months 1 -> "1 month"
+ | Every_months i -> sprintf "%d months" i
+ | Every_years 1 -> "1 year"
+ | Every_years i -> sprintf "%d years" i
+
+let rec dependencies_of_whenexpr = function
+ | Expr_bool _ -> []
+ | Expr_str _ -> []
+ | Expr_int _ -> []
+ | Expr_float _ -> []
+ | Expr_var v -> [v]
+ | Expr_and (e1, e2) ->
+ dependencies_of_whenexpr e1 @ dependencies_of_whenexpr e2
+ | Expr_or (e1, e2) ->
+ dependencies_of_whenexpr e1 @ dependencies_of_whenexpr e2
+ | Expr_eq (e1, e2) ->
+ dependencies_of_whenexpr e1 @ dependencies_of_whenexpr e2
+ | Expr_not e -> dependencies_of_whenexpr e
+ | Expr_changes v -> [v]
+
+let dependencies_of_job = function
+ | { job_cond = When_job whenexpr } -> dependencies_of_whenexpr whenexpr
+ | { job_cond = Every_job _ } -> []
+
+let rec eval_whenexpr job variables = function
+ | Expr_bool b -> T_bool b
+ | Expr_str s -> T_string s
+ | Expr_int i -> T_int i
+ | Expr_float f -> T_float f
+
+ | Expr_var v ->
+ (try StringMap.find v variables with Not_found -> T_string "")
+
+ | Expr_and (e1, e2) ->
+ if eval_whenexpr_as_bool job variables e1 &&
+ eval_whenexpr_as_bool job variables e2 then
+ T_bool true
+ else
+ T_bool false
+
+ | Expr_or (e1, e2) ->
+ if eval_whenexpr_as_bool job variables e1 ||
+ eval_whenexpr_as_bool job variables e2 then
+ T_bool true
+ else
+ T_bool false
+
+ | Expr_eq (e1, e2) ->
+ let e1 = eval_whenexpr job variables e1
+ and e2 = eval_whenexpr job variables e2 in
+ if 0 = compare_values e1 e2 then
+ T_bool true
+ else
+ T_bool false
+
+ | Expr_not e ->
+ if not (eval_whenexpr_as_bool job variables e) then
+ T_bool true
+ else
+ T_bool false
+
+ | Expr_changes v ->
+ let prev_value =
+ try StringMap.find v job.job_private.job_prev_variables
+ with Not_found -> T_string "" in
+ let curr_value =
+ try StringMap.find v variables
+ with Not_found -> T_string "" in
+
+ if 0 <> compare_values prev_value curr_value then
+ T_bool true
+ else
+ T_bool false
+
+(* Call {!eval_whenexpr} and cast the result to a boolean. *)
+and eval_whenexpr_as_bool job variables expr =
+ match eval_whenexpr job variables expr with
+ | T_bool r -> r
+ | T_string s -> s <> ""
+ | T_int i -> sign_big_int i <> 0
+ | T_float f -> f <> 0.
+
+(* Do a comparison on two typed values and return -1/0/+1. If the
+ * types are different then we compare the values as strings. The user
+ * can avoid this by specifying types.
+ *)
+and compare_values value1 value2 =
+ match value1, value2 with
+ | T_bool b1, T_bool b2 -> compare b1 b2
+ | T_string s1, T_string s2 -> compare s1 s2
+ | T_int i1, T_int i2 -> compare_big_int i1 i2
+ | T_float f1, T_float f2 -> compare f1 f2
+ | _ ->
+ let value1 = value_as_string value1
+ and value2 = value_as_string value2 in
+ compare value1 value2
+
+and value_as_string = function
+ | T_bool b -> string_of_bool b
+ | T_string s -> s
+ | T_int i -> string_of_big_int i
+ | T_float f -> string_of_float f
+
+let job_evaluate job variables =
+ match job with
+ | { job_cond = Every_job _ } -> false, job
+ | { job_cond = When_job whenexpr } ->
+ let state = eval_whenexpr_as_bool job variables whenexpr in
+
+ (* Because jobs are edge-triggered, we're only interested in the
+ * case where the evaluation state changes from false -> true.
+ *)
+ match job.job_private.job_prev_eval_state, state with
+ | false, false
+ | true, true
+ | true, false ->
+ let jobp = { job.job_private with job_prev_eval_state = state } in
+ let job = { job with job_private = jobp } in
+ false, job
+
+ | false, true ->
+ let jobp = { job_prev_eval_state = true;
+ job_prev_variables = variables } in
+ let job = { job with job_private = jobp } in
+ true, job
git.annexia.org / whenjobs.git / blobdiff