*)
open Whenutils
+open Whenexpr
open Big_int
open Unix
SOURCES = \
config.ml \
config.mli \
+ whenexpr.ml \
+ whenexpr.mli \
whenfile.ml \
whenfile.mli \
whenlock.ml \
whenutils.mli \
whenutils.ml
+# In alphabetical order.
CMI_FILES = \
config.cmi \
+ whenexpr.cmi
whenfile.cmi \
whenlock.cmi \
whenproto_aux.cmi \
config.cmo \
whenproto_aux.cmo \
whenutils.cmo \
+ whenexpr.cmo \
whenfile.cmo \
whenlock.cmo
(* Convert ">\>" to ">>" in code. *)
let sh = replace_str sh ">\\>" ">>" in
- <:expr< { Whenutils.sh_loc = $loc$;
+ <:expr< { Whenexpr.sh_loc = $loc$;
sh_script = $str:sh$ } >>
in
Quotation.add "sh" Quotation.DynAst.expr_tag sh_quotation_expander;
Stream.junk stream;
(match Stream.next stream with
| KEYWORD ("sec"|"secs"|"second"|"seconds"), _ ->
- <:expr< Whenutils.Every_seconds $`int:i$ >>
+ <:expr< Whenexpr.Every_seconds $`int:i$ >>
| KEYWORD ("min"|"mins"|"minute"|"minutes"), _ ->
let i = 60 * i in
- <:expr< Whenutils.Every_seconds $`int:i$ >>
+ <:expr< Whenexpr.Every_seconds $`int:i$ >>
| KEYWORD ("hour"|"hours"), _ ->
let i = 3600 * i in
- <:expr< Whenutils.Every_seconds $`int:i$ >>
+ <:expr< Whenexpr.Every_seconds $`int:i$ >>
| KEYWORD ("day"|"days"), _ ->
- <:expr< Whenutils.Every_days $`int:i$ >>
+ <:expr< Whenexpr.Every_days $`int:i$ >>
| KEYWORD ("week"|"weeks"), _ ->
let i = 7 * i in
- <:expr< Whenutils.Every_days $`int:i$ >>
+ <:expr< Whenexpr.Every_days $`int:i$ >>
| KEYWORD ("month"|"months"), _ ->
- <:expr< Whenutils.Every_months $`int:i$ >>
+ <:expr< Whenexpr.Every_months $`int:i$ >>
| KEYWORD ("year"|"years"), _ ->
- <:expr< Whenutils.Every_years $`int:i$ >>
+ <:expr< Whenexpr.Every_years $`int:i$ >>
| KEYWORD ("decade"|"decades"), _ ->
let i = 10 * i in
- <:expr< Whenutils.Every_years $`int:i$ >>
+ <:expr< Whenexpr.Every_years $`int:i$ >>
| KEYWORD ("century"|"centuries"|"centurys"), _ ->
let i = 100 * i in
- <:expr< Whenutils.Every_years $`int:i$ >>
+ <:expr< Whenexpr.Every_years $`int:i$ >>
| KEYWORD ("millenium"|"millenia"|"milleniums"), _ ->
let i = 1000 * i in
- <:expr< Whenutils.Every_years $`int:i$ >>
+ <:expr< Whenexpr.Every_years $`int:i$ >>
| (KEYWORD s | LIDENT s), _ ->
eprintf "period: failed to parse %d %s\n%!" i s;
raise Stream.Failure
(* A period expression (used in "every"). *)
periodexpr: [
[ ["sec"|"secs"|"second"|"seconds"] ->
- <:expr< Whenutils.Every_seconds 1 >> ]
+ <:expr< Whenexpr.Every_seconds 1 >> ]
| [ ["min"|"mins"|"minute"|"minutes"] ->
- <:expr< Whenutils.Every_seconds 60 >> ]
- | [ ["hour"|"hours"] -> <:expr< Whenutils.Every_seconds 3600 >> ]
- | [ ["day"|"days"] -> <:expr< Whenutils.Every_days 1 >> ]
- | [ ["week"|"weeks"] -> <:expr< Whenutils.Every_days 7 >> ]
- | [ ["month"|"months"] -> <:expr< Whenutils.Every_months 1 >> ]
- | [ ["year"|"years"] -> <:expr< Whenutils.Every_years 1 >> ]
- | [ ["decade"|"decades"] -> <:expr< Whenutils.Every_years 10 >> ]
+ <:expr< Whenexpr.Every_seconds 60 >> ]
+ | [ ["hour"|"hours"] -> <:expr< Whenexpr.Every_seconds 3600 >> ]
+ | [ ["day"|"days"] -> <:expr< Whenexpr.Every_days 1 >> ]
+ | [ ["week"|"weeks"] -> <:expr< Whenexpr.Every_days 7 >> ]
+ | [ ["month"|"months"] -> <:expr< Whenexpr.Every_months 1 >> ]
+ | [ ["year"|"years"] -> <:expr< Whenexpr.Every_years 1 >> ]
+ | [ ["decade"|"decades"] -> <:expr< Whenexpr.Every_years 10 >> ]
| [ ["century"|"centuries"|"centurys"] ->
- <:expr< Whenutils.Every_years 100 >> ]
+ <:expr< Whenexpr.Every_years 100 >> ]
| [ ["millenium"|"millenia"|"milleniums"] ->
- <:expr< Whenutils.Every_years 1000 >> ]
+ <:expr< Whenexpr.Every_years 1000 >> ]
| [ e = period_parser -> e ]
];
--- /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 CalendarLib
+
+open Whenutils
+
+open Big_int
+open Unix
+open Printf
+
+type whenexpr =
+ | Expr_unit
+ | 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_lt of whenexpr * whenexpr
+ | Expr_le of whenexpr * whenexpr
+ | Expr_eq of whenexpr * whenexpr
+ | Expr_ge of whenexpr * whenexpr
+ | Expr_gt of whenexpr * whenexpr
+ | Expr_not of whenexpr
+ | Expr_add of whenexpr * whenexpr
+ | Expr_sub of whenexpr * whenexpr
+ | Expr_mul of whenexpr * whenexpr
+ | Expr_div of whenexpr * whenexpr
+ | Expr_mod of whenexpr * whenexpr
+ | Expr_changes of string
+ | Expr_increases of string
+ | Expr_decreases of string
+ | Expr_prev of string
+ | Expr_reloaded
+
+(* This internal type is used during conversion of the OCaml AST
+ * to the whenexpr type.
+ *)
+type whenexpr_int =
+ | IExpr_unit
+ | 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_unit
+ | T_bool of bool
+ | T_string of string
+ | T_int of big_int
+ | T_float of float
+
+let variable_of_rpc = function
+ | `unit_t -> T_unit
+ | `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_unit -> `unit_t
+ | 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.
+ *
+ * [None] means there has been no previous evaluation.
+ *)
+ job_prev_eval_state : bool option;
+
+ (* When the job {i ran} last time, we take a copy of the variables.
+ * This allows us to implement the 'changes' operator.
+ *
+ * [None] means there has been no previous run.
+ *)
+ job_prev_variables : variables option;
+}
+
+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 make_when_job _loc name e sh =
+ { job_loc = _loc; job_name = name;
+ job_cond = When_job e; job_script = sh;
+ job_private = { job_prev_eval_state = None;
+ job_prev_variables = None } }
+
+let make_every_job _loc name e sh =
+ { job_loc = _loc; job_name = name;
+ job_cond = Every_job e; job_script = sh;
+ job_private = { job_prev_eval_state = None;
+ job_prev_variables = None } }
+
+let rec expr_of_ast _loc ast =
+ expr_of_iexpr _loc (iexpr_of_ast _loc ast)
+
+and iexpr_of_ast _loc = function
+ | ExId (_, IdUid (_, "()")) -> IExpr_unit
+ | ExId (_, IdUid (_, "True")) -> IExpr_bool true
+ | ExId (_, IdUid (_, "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_unit -> Expr_unit
+ | 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) ->
+ two_params _loc "&&" exprs (fun e1 e2 -> Expr_and (e1, e2))
+
+ | IExpr_app ("||", exprs) ->
+ two_params _loc "||" exprs (fun e1 e2 -> Expr_or (e1, e2))
+
+ | IExpr_app ("<", exprs) ->
+ two_params _loc "<" exprs (fun e1 e2 -> Expr_lt (e1, e2))
+
+ | IExpr_app ("<=", exprs) ->
+ two_params _loc "<=" exprs (fun e1 e2 -> Expr_le (e1, e2))
+
+ | IExpr_app (("="|"=="), exprs) ->
+ two_params _loc "=" exprs (fun e1 e2 -> Expr_eq (e1, e2))
+
+ | IExpr_app (">=", exprs) ->
+ two_params _loc ">=" exprs (fun e1 e2 -> Expr_ge (e1, e2))
+
+ | IExpr_app (">", exprs) ->
+ two_params _loc ">" exprs (fun e1 e2 -> Expr_gt (e1, e2))
+
+ | IExpr_app ("!", exprs) ->
+ one_param _loc "!" exprs (fun e1 -> Expr_not e1)
+
+ | IExpr_app ("+", exprs) ->
+ two_params _loc "+" exprs (fun e1 e2 -> Expr_add (e1, e2))
+
+ | IExpr_app ("-", exprs) ->
+ two_params _loc "+" exprs (fun e1 e2 -> Expr_sub (e1, e2))
+
+ | IExpr_app ("*", exprs) ->
+ two_params _loc "+" exprs (fun e1 e2 -> Expr_mul (e1, e2))
+
+ | IExpr_app ("/", exprs) ->
+ two_params _loc "+" exprs (fun e1 e2 -> Expr_div (e1, e2))
+
+ | IExpr_app ("mod", exprs) ->
+ two_params _loc "+" exprs (fun e1 e2 -> Expr_mod (e1, e2))
+
+ | IExpr_app (("change"|"changes"|"changed"), [IExpr_var v]) ->
+ Expr_changes v
+
+ | IExpr_app (("inc"|"increase"|"increases"|"increased"), [IExpr_var v]) ->
+ Expr_increases v
+
+ | IExpr_app (("dec"|"decrease"|"decreases"|"decreased"), [IExpr_var v]) ->
+ Expr_decreases v
+
+ | IExpr_app (("prev"|"previous"), [IExpr_var v]) ->
+ Expr_prev v
+
+ | IExpr_app (("change"|"changes"|"changed"|"inc"|"increase"|"increases"|"increased"|"dec"|"decrease"|"decreases"|"decreased"|"prev"|"previous") as op, _) ->
+ invalid_arg (sprintf "%s: '%s' operator must be followed by a variable name"
+ (Loc.to_string _loc) op)
+
+ | IExpr_app ("reloaded", [IExpr_unit]) ->
+ Expr_reloaded
+
+ | IExpr_app ("reloaded", _) ->
+ invalid_arg (sprintf "%s: you must use 'reloaded ()'" (Loc.to_string _loc))
+
+ | IExpr_app (op, _) ->
+ invalid_arg (sprintf "%s: unknown operator in expression: %s"
+ (Loc.to_string _loc) op)
+
+and two_params _loc op exprs f =
+ match exprs with
+ | [e1; e2] -> f (expr_of_iexpr _loc e1) (expr_of_iexpr _loc e2)
+ | _ ->
+ invalid_arg (sprintf "%s: %s operator must be applied to two parameters"
+ op (Loc.to_string _loc))
+
+and one_param _loc op exprs f =
+ match exprs with
+ | [e1] -> f (expr_of_iexpr _loc e1)
+ | _ ->
+ invalid_arg (sprintf "%s: %s operator must be applied to one parameter"
+ op (Loc.to_string _loc))
+
+let rec string_of_whenexpr = function
+ | Expr_unit -> "()"
+ | 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_lt (e1, e2) ->
+ sprintf "%s < %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+ | Expr_le (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_ge (e1, e2) ->
+ sprintf "%s >= %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+ | Expr_gt (e1, e2) ->
+ sprintf "%s > %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+ | Expr_not e -> sprintf "! %s" (string_of_whenexpr e)
+ | Expr_add (e1, e2) ->
+ sprintf "%s + %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+ | Expr_sub (e1, e2) ->
+ sprintf "%s - %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+ | Expr_mul (e1, e2) ->
+ sprintf "%s * %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+ | Expr_div (e1, e2) ->
+ sprintf "%s / %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+ | Expr_mod (e1, e2) ->
+ sprintf "%s mod %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+ | Expr_changes v -> sprintf "changes %s" v
+ | Expr_increases v -> sprintf "increases %s" v
+ | Expr_decreases v -> sprintf "decreases %s" v
+ | Expr_prev v -> sprintf "prev %s" v
+ | Expr_reloaded -> "reloaded ()"
+
+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_unit -> []
+ | Expr_bool _ -> []
+ | Expr_str _ -> []
+ | Expr_int _ -> []
+ | Expr_float _ -> []
+ | Expr_var v -> [v]
+ | Expr_and (e1, e2)
+ | Expr_or (e1, e2)
+ | Expr_lt (e1, e2)
+ | Expr_le (e1, e2)
+ | Expr_eq (e1, e2)
+ | Expr_ge (e1, e2)
+ | Expr_gt (e1, e2)
+ | Expr_add (e1, e2)
+ | Expr_sub (e1, e2)
+ | Expr_mul (e1, e2)
+ | Expr_div (e1, e2)
+ | Expr_mod (e1, e2) ->
+ dependencies_of_whenexpr e1 @ dependencies_of_whenexpr e2
+ | Expr_not e ->
+ dependencies_of_whenexpr e
+ | Expr_changes v
+ | Expr_increases v
+ | Expr_decreases v
+ | Expr_prev v -> [v]
+ | Expr_reloaded -> []
+
+let dependencies_of_job = function
+ | { job_cond = When_job whenexpr } -> dependencies_of_whenexpr whenexpr
+ | { job_cond = Every_job _ } -> []
+
+let rec eval_whenexpr job variables onload = function
+ | Expr_unit -> T_unit
+ | 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 ->
+ get_variable variables v
+
+ | Expr_and (e1, e2) ->
+ if eval_whenexpr_as_bool job variables onload e1 &&
+ eval_whenexpr_as_bool job variables onload e2 then
+ T_bool true
+ else
+ T_bool false
+
+ | Expr_or (e1, e2) ->
+ if eval_whenexpr_as_bool job variables onload e1 ||
+ eval_whenexpr_as_bool job variables onload e2 then
+ T_bool true
+ else
+ T_bool false
+
+ | Expr_lt (e1, e2) ->
+ let e1 = eval_whenexpr job variables onload e1
+ and e2 = eval_whenexpr job variables onload e2 in
+ if compare_values e1 e2 < 0 then
+ T_bool true
+ else
+ T_bool false
+
+ | Expr_le (e1, e2) ->
+ let e1 = eval_whenexpr job variables onload e1
+ and e2 = eval_whenexpr job variables onload e2 in
+ if compare_values e1 e2 <= 0 then
+ T_bool true
+ else
+ T_bool false
+
+ | Expr_eq (e1, e2) ->
+ let e1 = eval_whenexpr job variables onload e1
+ and e2 = eval_whenexpr job variables onload e2 in
+ if compare_values e1 e2 = 0 then
+ T_bool true
+ else
+ T_bool false
+
+ | Expr_ge (e1, e2) ->
+ let e1 = eval_whenexpr job variables onload e1
+ and e2 = eval_whenexpr job variables onload e2 in
+ if compare_values e1 e2 >= 0 then
+ T_bool true
+ else
+ T_bool false
+
+ | Expr_gt (e1, e2) ->
+ let e1 = eval_whenexpr job variables onload e1
+ and e2 = eval_whenexpr job variables onload e2 in
+ if compare_values e1 e2 > 0 then
+ T_bool true
+ else
+ T_bool false
+
+ | Expr_not e ->
+ if not (eval_whenexpr_as_bool job variables onload e) then
+ T_bool true
+ else
+ T_bool false
+
+ | Expr_add (e1, e2) ->
+ let e1 = eval_whenexpr job variables onload e1
+ and e2 = eval_whenexpr job variables onload e2 in
+ add_values e1 e2
+
+ | Expr_sub (e1, e2) ->
+ let e1 = eval_whenexpr job variables onload e1
+ and e2 = eval_whenexpr job variables onload e2 in
+ sub_values e1 e2
+
+ | Expr_mul (e1, e2) ->
+ let e1 = eval_whenexpr job variables onload e1
+ and e2 = eval_whenexpr job variables onload e2 in
+ mul_values e1 e2
+
+ | Expr_div (e1, e2) ->
+ let e1 = eval_whenexpr job variables onload e1
+ and e2 = eval_whenexpr job variables onload e2 in
+ div_values e1 e2
+
+ | Expr_mod (e1, e2) ->
+ let e1 = eval_whenexpr job variables onload e1
+ and e2 = eval_whenexpr job variables onload e2 in
+ mod_values e1 e2
+
+ | Expr_changes v ->
+ let prev_value, curr_value = get_prev_curr_value job variables v in
+ if compare_values prev_value curr_value <> 0 then
+ T_bool true
+ else
+ T_bool false
+
+ | Expr_increases v ->
+ let prev_value, curr_value = get_prev_curr_value job variables v in
+ if compare_values prev_value curr_value < 0 then
+ T_bool true
+ else
+ T_bool false
+
+ | Expr_decreases v ->
+ let prev_value, curr_value = get_prev_curr_value job variables v in
+ if compare_values prev_value curr_value > 0 then
+ T_bool true
+ else
+ T_bool false
+
+ | Expr_prev v ->
+ get_prev_variable job v
+
+ | Expr_reloaded ->
+ T_bool onload
+
+and get_prev_curr_value job variables v =
+ let prev_value = get_prev_variable job v in
+ let curr_value = get_variable variables v in
+ prev_value, curr_value
+
+and get_variable variables v =
+ try StringMap.find v variables with Not_found -> T_string ""
+
+and get_prev_variable job v =
+ match job.job_private.job_prev_variables with
+ | None ->
+ (* Job has never run. XXX Should do better here. *)
+ T_string ""
+ | Some prev_variables ->
+ get_variable prev_variables v
+
+(* Call {!eval_whenexpr} and cast the result to a boolean. *)
+and eval_whenexpr_as_bool job variables onload expr =
+ match eval_whenexpr job variables onload expr with
+ | T_unit -> false
+ | 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
+ (* XXX BUG: int should be promoted to float in mixed numeric comparison *)
+ | _ ->
+ let value1 = string_of_variable value1
+ and value2 = string_of_variable value2 in
+ compare value1 value2
+
+(* + operator is addition or string concatenation. *)
+and add_values value1 value2 =
+ match value1, value2 with
+ | T_int i1, T_int i2 -> T_int (add_big_int i1 i2)
+ | T_float i1, T_float i2 -> T_float (i1 +. i2)
+ | T_int i1, T_float i2 -> T_float (float_of_big_int i1 +. i2)
+ | T_float i1, T_int i2 -> T_float (i1 +. float_of_big_int i2)
+ | T_string i1, T_string i2 -> T_string (i1 ^ i2)
+ | _ ->
+ invalid_arg
+ (sprintf "incompatible types in addition: %s + %s"
+ (printable_string_of_variable value1)
+ (printable_string_of_variable value2))
+
+and sub_values value1 value2 =
+ match value1, value2 with
+ | T_int i1, T_int i2 -> T_int (sub_big_int i1 i2)
+ | T_float i1, T_float i2 -> T_float (i1 -. i2)
+ | T_int i1, T_float i2 -> T_float (float_of_big_int i1 -. i2)
+ | T_float i1, T_int i2 -> T_float (i1 -. float_of_big_int i2)
+ | _ ->
+ invalid_arg
+ (sprintf "incompatible types in subtraction: %s - %s"
+ (printable_string_of_variable value1)
+ (printable_string_of_variable value2))
+
+and mul_values value1 value2 =
+ match value1, value2 with
+ | T_int i1, T_int i2 -> T_int (mult_big_int i1 i2)
+ | T_float i1, T_float i2 -> T_float (i1 *. i2)
+ | T_int i1, T_float i2 -> T_float (float_of_big_int i1 *. i2)
+ | T_float i1, T_int i2 -> T_float (i1 *. float_of_big_int i2)
+ | _ ->
+ invalid_arg
+ (sprintf "incompatible types in multiplication: %s * %s"
+ (printable_string_of_variable value1)
+ (printable_string_of_variable value2))
+
+and div_values value1 value2 =
+ match value1, value2 with
+ | T_int i1, T_int i2 -> T_int (div_big_int i1 i2)
+ | T_float i1, T_float i2 -> T_float (i1 /. i2)
+ | T_int i1, T_float i2 -> T_float (float_of_big_int i1 /. i2)
+ | T_float i1, T_int i2 -> T_float (i1 /. float_of_big_int i2)
+ | _ ->
+ invalid_arg
+ (sprintf "incompatible types in division: %s / %s"
+ (printable_string_of_variable value1)
+ (printable_string_of_variable value2))
+
+and mod_values value1 value2 =
+ match value1, value2 with
+ | T_int i1, T_int i2 -> T_int (mod_big_int i1 i2)
+ | T_float i1, T_float i2 -> T_float (mod_float i1 i2)
+ | T_int i1, T_float i2 -> T_float (mod_float (float_of_big_int i1) i2)
+ | T_float i1, T_int i2 -> T_float (mod_float i1 (float_of_big_int i2))
+ | _ ->
+ invalid_arg
+ (sprintf "incompatible types in modulo: %s mod %s"
+ (printable_string_of_variable value1)
+ (printable_string_of_variable value2))
+
+and string_of_variable = function
+ | T_unit -> "" (* for string_of_variable, we don't want () here *)
+ | 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
+
+and printable_string_of_variable = function
+ | T_unit -> "()"
+ | T_bool b -> string_of_bool b
+ | T_string s -> sprintf "%S" s
+ | T_int i -> string_of_big_int i
+ | T_float f -> string_of_float f
+
+let job_evaluate job variables onload =
+ match job with
+ | { job_cond = Every_job _ } -> false, job
+ | { job_cond = When_job whenexpr } ->
+ let state = eval_whenexpr_as_bool job variables onload 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
+ | None, false
+ | Some false, false
+ | Some true, true
+ | Some true, false ->
+ let jobp = { job.job_private with job_prev_eval_state = Some state } in
+ let job = { job with job_private = jobp } in
+ false, job
+
+ | None, true
+ | Some false, true ->
+ let jobp = { job_prev_eval_state = Some true;
+ job_prev_variables = Some variables } in
+ let job = { job with job_private = jobp } in
+ true, job
+
+let next_periodexpr =
+ (* Round up 'a' to the next multiple of 'i'. *)
+ let round_up_float a i =
+ let r = mod_float a i in
+ if r = 0. then a +. i else a +. (i -. r)
+ and round_up a i =
+ let r = a mod i in
+ if r = 0 then a + i else a + (i - r)
+ in
+
+ fun t -> function
+ | Every_seconds i ->
+ let i = float_of_int i in
+ round_up_float t i
+
+ | Every_years i ->
+ let tm = gmtime t in
+
+ (* Round 'tm' up to the first day of the next year. *)
+ let year = round_up tm.tm_year i in
+ let tm = { tm with tm_sec = 0; tm_min = 0; tm_hour = 0;
+ tm_mday = 1; tm_mon = 0; tm_year = year } in
+ fst (mktime tm)
+
+ | Every_days i ->
+ let t = Date.from_unixfloat t in
+ let t0 = Date.make 1970 1 1 in
+
+ (* Number of whole days since Unix Epoch. *)
+ let nb_days = Date.Period.safe_nb_days (Date.sub t t0) in
+
+ let nb_days = round_up nb_days i in
+ let t' = Date.add t0 (Date.Period.day nb_days) in
+ Date.to_unixfloat t'
+
+ | Every_months i ->
+ (* Calculate number of whole months since Unix Epoch. *)
+ let tm = gmtime t in
+ let months = 12 * (tm.tm_year - 70) + tm.tm_mon in
+
+ let months = round_up months i in
+ let t0 = Date.make 1970 1 1 in
+ let t' = Date.add t0 (Date.Period.month months) in
+ Date.to_unixfloat t'
--- /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.
+ *)
+
+(** When- and every-expression definition and evaluation, variables
+ and jobs. *)
+
+type whenexpr =
+ | Expr_unit (** Unit constant. *)
+ | Expr_bool of bool (** A boolean constant. *)
+ | Expr_str of string (** A string constant. *)
+ | Expr_int of Big_int.big_int (** An integer constant. *)
+ | Expr_float of float (** A float constant. *)
+ | Expr_var of string (** A variable name. *)
+ | Expr_and of whenexpr * whenexpr (** && *)
+ | Expr_or of whenexpr * whenexpr (** || *)
+ | Expr_lt of whenexpr * whenexpr (** < *)
+ | Expr_le of whenexpr * whenexpr (** <= *)
+ | Expr_eq of whenexpr * whenexpr (** == *)
+ | Expr_ge of whenexpr * whenexpr (** >= *)
+ | Expr_gt of whenexpr * whenexpr (** > *)
+ | Expr_not of whenexpr (** boolean not *)
+ | Expr_add of whenexpr * whenexpr (** arithmetic addition or string cat *)
+ | Expr_sub of whenexpr * whenexpr (** arithmetic subtraction *)
+ | Expr_mul of whenexpr * whenexpr (** arithmetic multiplication *)
+ | Expr_div of whenexpr * whenexpr (** arithmetic division *)
+ | Expr_mod of whenexpr * whenexpr (** arithmetic modulo *)
+ | Expr_changes of string (** changes var *)
+ | Expr_increases of string (** increases var *)
+ | Expr_decreases of string (** decreases var *)
+ | Expr_prev of string (** prev var *)
+ | Expr_reloaded (** reloaded () *)
+(** Internal type used to represent 'when' expressions. *)
+
+type periodexpr =
+ | Every_seconds of int
+ | Every_days of int
+ | Every_months of int
+ | Every_years of int
+(** Internal type used to represent 'every' expressions. *)
+
+type shell_script = {
+ sh_loc : Camlp4.PreCast.Loc.t;
+ sh_script : string;
+}
+(** A shell script. *)
+
+type variable =
+ | T_unit
+ | T_bool of bool
+ | T_string of string
+ | T_int of Big_int.big_int
+ | T_float of float
+(** Typed variable (see also [whenproto.x]) *)
+
+val string_of_variable : variable -> string
+
+val variable_of_rpc : Whenproto_aux.variable -> variable
+val rpc_of_variable : variable -> Whenproto_aux.variable
+
+type variables = variable Whenutils.StringMap.t
+(** A set of variables. *)
+
+type job_private
+(** Private state associated with a job, used for evaluation. *)
+
+type job_cond =
+ | When_job of whenexpr (** when ... : << >> *)
+ | Every_job of periodexpr (** every ... : << >> *)
+
+type job = {
+ job_loc : Camlp4.PreCast.Loc.t;
+ job_name : string;
+ job_cond : job_cond;
+ job_script : shell_script;
+ job_private : job_private;
+}
+(** A job. Note that because of the [job_private] field, these cannot
+ be constructed directly. Use {!make_when_job} or {!make_every_job}
+ to construct one. *)
+
+val make_when_job : Camlp4.PreCast.Loc.t -> string -> whenexpr -> shell_script -> job
+(** Make a when-statement job. *)
+
+val make_every_job : Camlp4.PreCast.Loc.t -> string -> periodexpr -> shell_script -> job
+(** Make an every-statement job. *)
+
+val expr_of_ast : Camlp4.PreCast.Ast.Loc.t -> Camlp4.PreCast.Ast.expr -> whenexpr
+(** Convert OCaml AST to an expression. Since OCaml ASTs are much
+ more general than the expressions we can use, this can raise
+ [Invalid_argument] in many different situations. *)
+
+val string_of_whenexpr : whenexpr -> string
+(** Pretty-print an expression to a string. *)
+
+val string_of_periodexpr : periodexpr -> string
+(** Pretty-print a period expression to a string. *)
+
+val dependencies_of_whenexpr : whenexpr -> string list
+(** Return list of variables that an expression depends on. This is
+ used to work out when an expression needs to be reevaluated. *)
+
+val dependencies_of_job : job -> string list
+(** Which variables does this job depend on? *)
+
+val job_evaluate : job -> variables -> bool -> bool * job
+(** [job_evaluate job variables onload] evaluates [job]'s condition in
+ the context of the [variables], and return [true] iff it should be
+ run now.
+
+ Note that this returns a possibly-updated [job] structure.
+
+ This is a no-op for 'every' jobs. *)
+
+val next_periodexpr : float -> periodexpr -> float
+(** [next_periodexpr t period] returns the earliest event of [period]
+ strictly after time [t].
+
+ Visualising periods as repeated events on a timeline, this
+ returns [t']:
+
+ {v
+ events: ---+---------+---------+---------+---------+---------+-----
+ times: t t'
+ }
+
+ Note that [periodexpr] events are not necessarily regular.
+ eg. The start of a month is not a fixed number of seconds
+ after the start of the previous month. 'Epoch' refers
+ to the Unix Epoch (ie. 1970-01-01 00:00:00 UTC).
+
+ If [period = Every_seconds i] then events are when
+ [t' mod i == 0] when t' is the number of seconds since
+ the Epoch. This returns the next t' > t.
+
+ If [period = Every_days i] then events happen at
+ midnight UTC every [i] days since the Epoch.
+ This returns the next midnight > t.
+
+ If [period = Every_months i] then events happen at
+ midnight UTC on the 1st day of the month every [i] months
+ since the Epoch. This returns midnight on the
+ 1st day of the next month > t.
+
+ If [period = Every_years i] then events happen at
+ midnight UTC on the 1st day of the year when
+ [(y - 1970) mod i == 0]. This returns midnight on the
+ 1st day of the next year > t. *)
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
-open Whenutils
+open Whenexpr
open Printf
(** "Initialize" the module. Clear the list of jobs and other
internal variables so we are ready to parse a new file. *)
-val get_jobs : unit -> Whenutils.job list
+val get_jobs : unit -> Whenexpr.job list
(** Get the jobs added since {!init} was called. *)
-val add_when_job : Camlp4.PreCast.Loc.t -> string -> Camlp4.PreCast.Ast.expr -> Whenutils.shell_script -> unit
+val add_when_job : Camlp4.PreCast.Loc.t -> string -> Camlp4.PreCast.Ast.expr -> Whenexpr.shell_script -> unit
(** When a 'when' macro appears as a toplevel statement in an
input file, it causes this function to be called.
[sh] is the shell script fragment (basically location + a big string). *)
-val add_every_job : Camlp4.PreCast.Loc.t -> string -> Whenutils.periodexpr -> Whenutils.shell_script -> unit
+val add_every_job : Camlp4.PreCast.Loc.t -> string -> Whenexpr.periodexpr -> Whenexpr.shell_script -> unit
(** When an 'every' macro appears as a toplevel statement in an
input file, it causes this function to be called.
match f x with
| Some y -> y :: filter_map f xs
| None -> filter_map f xs
-
-type whenexpr =
- | Expr_unit
- | 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_lt of whenexpr * whenexpr
- | Expr_le of whenexpr * whenexpr
- | Expr_eq of whenexpr * whenexpr
- | Expr_ge of whenexpr * whenexpr
- | Expr_gt of whenexpr * whenexpr
- | Expr_not of whenexpr
- | Expr_add of whenexpr * whenexpr
- | Expr_sub of whenexpr * whenexpr
- | Expr_mul of whenexpr * whenexpr
- | Expr_div of whenexpr * whenexpr
- | Expr_mod of whenexpr * whenexpr
- | Expr_changes of string
- | Expr_increases of string
- | Expr_decreases of string
- | Expr_prev of string
- | Expr_reloaded
-
-(* This internal type is used during conversion of the OCaml AST
- * to the whenexpr type.
- *)
-type whenexpr_int =
- | IExpr_unit
- | 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_unit
- | T_bool of bool
- | T_string of string
- | T_int of big_int
- | T_float of float
-
-let variable_of_rpc = function
- | `unit_t -> T_unit
- | `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_unit -> `unit_t
- | 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.
- *
- * [None] means there has been no previous evaluation.
- *)
- job_prev_eval_state : bool option;
-
- (* When the job {i ran} last time, we take a copy of the variables.
- * This allows us to implement the 'changes' operator.
- *
- * [None] means there has been no previous run.
- *)
- job_prev_variables : variables option;
-}
-
-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 make_when_job _loc name e sh =
- { job_loc = _loc; job_name = name;
- job_cond = When_job e; job_script = sh;
- job_private = { job_prev_eval_state = None;
- job_prev_variables = None } }
-
-let make_every_job _loc name e sh =
- { job_loc = _loc; job_name = name;
- job_cond = Every_job e; job_script = sh;
- job_private = { job_prev_eval_state = None;
- job_prev_variables = None } }
-
-let rec expr_of_ast _loc ast =
- expr_of_iexpr _loc (iexpr_of_ast _loc ast)
-
-and iexpr_of_ast _loc = function
- | ExId (_, IdUid (_, "()")) -> IExpr_unit
- | ExId (_, IdUid (_, "True")) -> IExpr_bool true
- | ExId (_, IdUid (_, "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_unit -> Expr_unit
- | 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) ->
- two_params _loc "&&" exprs (fun e1 e2 -> Expr_and (e1, e2))
-
- | IExpr_app ("||", exprs) ->
- two_params _loc "||" exprs (fun e1 e2 -> Expr_or (e1, e2))
-
- | IExpr_app ("<", exprs) ->
- two_params _loc "<" exprs (fun e1 e2 -> Expr_lt (e1, e2))
-
- | IExpr_app ("<=", exprs) ->
- two_params _loc "<=" exprs (fun e1 e2 -> Expr_le (e1, e2))
-
- | IExpr_app (("="|"=="), exprs) ->
- two_params _loc "=" exprs (fun e1 e2 -> Expr_eq (e1, e2))
-
- | IExpr_app (">=", exprs) ->
- two_params _loc ">=" exprs (fun e1 e2 -> Expr_ge (e1, e2))
-
- | IExpr_app (">", exprs) ->
- two_params _loc ">" exprs (fun e1 e2 -> Expr_gt (e1, e2))
-
- | IExpr_app ("!", exprs) ->
- one_param _loc "!" exprs (fun e1 -> Expr_not e1)
-
- | IExpr_app ("+", exprs) ->
- two_params _loc "+" exprs (fun e1 e2 -> Expr_add (e1, e2))
-
- | IExpr_app ("-", exprs) ->
- two_params _loc "+" exprs (fun e1 e2 -> Expr_sub (e1, e2))
-
- | IExpr_app ("*", exprs) ->
- two_params _loc "+" exprs (fun e1 e2 -> Expr_mul (e1, e2))
-
- | IExpr_app ("/", exprs) ->
- two_params _loc "+" exprs (fun e1 e2 -> Expr_div (e1, e2))
-
- | IExpr_app ("mod", exprs) ->
- two_params _loc "+" exprs (fun e1 e2 -> Expr_mod (e1, e2))
-
- | IExpr_app (("change"|"changes"|"changed"), [IExpr_var v]) ->
- Expr_changes v
-
- | IExpr_app (("inc"|"increase"|"increases"|"increased"), [IExpr_var v]) ->
- Expr_increases v
-
- | IExpr_app (("dec"|"decrease"|"decreases"|"decreased"), [IExpr_var v]) ->
- Expr_decreases v
-
- | IExpr_app (("prev"|"previous"), [IExpr_var v]) ->
- Expr_prev v
-
- | IExpr_app (("change"|"changes"|"changed"|"inc"|"increase"|"increases"|"increased"|"dec"|"decrease"|"decreases"|"decreased"|"prev"|"previous") as op, _) ->
- invalid_arg (sprintf "%s: '%s' operator must be followed by a variable name"
- (Loc.to_string _loc) op)
-
- | IExpr_app ("reloaded", [IExpr_unit]) ->
- Expr_reloaded
-
- | IExpr_app ("reloaded", _) ->
- invalid_arg (sprintf "%s: you must use 'reloaded ()'" (Loc.to_string _loc))
-
- | IExpr_app (op, _) ->
- invalid_arg (sprintf "%s: unknown operator in expression: %s"
- (Loc.to_string _loc) op)
-
-and two_params _loc op exprs f =
- match exprs with
- | [e1; e2] -> f (expr_of_iexpr _loc e1) (expr_of_iexpr _loc e2)
- | _ ->
- invalid_arg (sprintf "%s: %s operator must be applied to two parameters"
- op (Loc.to_string _loc))
-
-and one_param _loc op exprs f =
- match exprs with
- | [e1] -> f (expr_of_iexpr _loc e1)
- | _ ->
- invalid_arg (sprintf "%s: %s operator must be applied to one parameter"
- op (Loc.to_string _loc))
-
-let rec string_of_whenexpr = function
- | Expr_unit -> "()"
- | 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_lt (e1, e2) ->
- sprintf "%s < %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
- | Expr_le (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_ge (e1, e2) ->
- sprintf "%s >= %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
- | Expr_gt (e1, e2) ->
- sprintf "%s > %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
- | Expr_not e -> sprintf "! %s" (string_of_whenexpr e)
- | Expr_add (e1, e2) ->
- sprintf "%s + %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
- | Expr_sub (e1, e2) ->
- sprintf "%s - %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
- | Expr_mul (e1, e2) ->
- sprintf "%s * %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
- | Expr_div (e1, e2) ->
- sprintf "%s / %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
- | Expr_mod (e1, e2) ->
- sprintf "%s mod %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
- | Expr_changes v -> sprintf "changes %s" v
- | Expr_increases v -> sprintf "increases %s" v
- | Expr_decreases v -> sprintf "decreases %s" v
- | Expr_prev v -> sprintf "prev %s" v
- | Expr_reloaded -> "reloaded ()"
-
-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_unit -> []
- | Expr_bool _ -> []
- | Expr_str _ -> []
- | Expr_int _ -> []
- | Expr_float _ -> []
- | Expr_var v -> [v]
- | Expr_and (e1, e2)
- | Expr_or (e1, e2)
- | Expr_lt (e1, e2)
- | Expr_le (e1, e2)
- | Expr_eq (e1, e2)
- | Expr_ge (e1, e2)
- | Expr_gt (e1, e2)
- | Expr_add (e1, e2)
- | Expr_sub (e1, e2)
- | Expr_mul (e1, e2)
- | Expr_div (e1, e2)
- | Expr_mod (e1, e2) ->
- dependencies_of_whenexpr e1 @ dependencies_of_whenexpr e2
- | Expr_not e ->
- dependencies_of_whenexpr e
- | Expr_changes v
- | Expr_increases v
- | Expr_decreases v
- | Expr_prev v -> [v]
- | Expr_reloaded -> []
-
-let dependencies_of_job = function
- | { job_cond = When_job whenexpr } -> dependencies_of_whenexpr whenexpr
- | { job_cond = Every_job _ } -> []
-
-let rec eval_whenexpr job variables onload = function
- | Expr_unit -> T_unit
- | 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 ->
- get_variable variables v
-
- | Expr_and (e1, e2) ->
- if eval_whenexpr_as_bool job variables onload e1 &&
- eval_whenexpr_as_bool job variables onload e2 then
- T_bool true
- else
- T_bool false
-
- | Expr_or (e1, e2) ->
- if eval_whenexpr_as_bool job variables onload e1 ||
- eval_whenexpr_as_bool job variables onload e2 then
- T_bool true
- else
- T_bool false
-
- | Expr_lt (e1, e2) ->
- let e1 = eval_whenexpr job variables onload e1
- and e2 = eval_whenexpr job variables onload e2 in
- if compare_values e1 e2 < 0 then
- T_bool true
- else
- T_bool false
-
- | Expr_le (e1, e2) ->
- let e1 = eval_whenexpr job variables onload e1
- and e2 = eval_whenexpr job variables onload e2 in
- if compare_values e1 e2 <= 0 then
- T_bool true
- else
- T_bool false
-
- | Expr_eq (e1, e2) ->
- let e1 = eval_whenexpr job variables onload e1
- and e2 = eval_whenexpr job variables onload e2 in
- if compare_values e1 e2 = 0 then
- T_bool true
- else
- T_bool false
-
- | Expr_ge (e1, e2) ->
- let e1 = eval_whenexpr job variables onload e1
- and e2 = eval_whenexpr job variables onload e2 in
- if compare_values e1 e2 >= 0 then
- T_bool true
- else
- T_bool false
-
- | Expr_gt (e1, e2) ->
- let e1 = eval_whenexpr job variables onload e1
- and e2 = eval_whenexpr job variables onload e2 in
- if compare_values e1 e2 > 0 then
- T_bool true
- else
- T_bool false
-
- | Expr_not e ->
- if not (eval_whenexpr_as_bool job variables onload e) then
- T_bool true
- else
- T_bool false
-
- | Expr_add (e1, e2) ->
- let e1 = eval_whenexpr job variables onload e1
- and e2 = eval_whenexpr job variables onload e2 in
- add_values e1 e2
-
- | Expr_sub (e1, e2) ->
- let e1 = eval_whenexpr job variables onload e1
- and e2 = eval_whenexpr job variables onload e2 in
- sub_values e1 e2
-
- | Expr_mul (e1, e2) ->
- let e1 = eval_whenexpr job variables onload e1
- and e2 = eval_whenexpr job variables onload e2 in
- mul_values e1 e2
-
- | Expr_div (e1, e2) ->
- let e1 = eval_whenexpr job variables onload e1
- and e2 = eval_whenexpr job variables onload e2 in
- div_values e1 e2
-
- | Expr_mod (e1, e2) ->
- let e1 = eval_whenexpr job variables onload e1
- and e2 = eval_whenexpr job variables onload e2 in
- mod_values e1 e2
-
- | Expr_changes v ->
- let prev_value, curr_value = get_prev_curr_value job variables v in
- if compare_values prev_value curr_value <> 0 then
- T_bool true
- else
- T_bool false
-
- | Expr_increases v ->
- let prev_value, curr_value = get_prev_curr_value job variables v in
- if compare_values prev_value curr_value < 0 then
- T_bool true
- else
- T_bool false
-
- | Expr_decreases v ->
- let prev_value, curr_value = get_prev_curr_value job variables v in
- if compare_values prev_value curr_value > 0 then
- T_bool true
- else
- T_bool false
-
- | Expr_prev v ->
- get_prev_variable job v
-
- | Expr_reloaded ->
- T_bool onload
-
-and get_prev_curr_value job variables v =
- let prev_value = get_prev_variable job v in
- let curr_value = get_variable variables v in
- prev_value, curr_value
-
-and get_variable variables v =
- try StringMap.find v variables with Not_found -> T_string ""
-
-and get_prev_variable job v =
- match job.job_private.job_prev_variables with
- | None ->
- (* Job has never run. XXX Should do better here. *)
- T_string ""
- | Some prev_variables ->
- get_variable prev_variables v
-
-(* Call {!eval_whenexpr} and cast the result to a boolean. *)
-and eval_whenexpr_as_bool job variables onload expr =
- match eval_whenexpr job variables onload expr with
- | T_unit -> false
- | 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
- (* XXX BUG: int should be promoted to float in mixed numeric comparison *)
- | _ ->
- let value1 = string_of_variable value1
- and value2 = string_of_variable value2 in
- compare value1 value2
-
-(* + operator is addition or string concatenation. *)
-and add_values value1 value2 =
- match value1, value2 with
- | T_int i1, T_int i2 -> T_int (add_big_int i1 i2)
- | T_float i1, T_float i2 -> T_float (i1 +. i2)
- | T_int i1, T_float i2 -> T_float (float_of_big_int i1 +. i2)
- | T_float i1, T_int i2 -> T_float (i1 +. float_of_big_int i2)
- | T_string i1, T_string i2 -> T_string (i1 ^ i2)
- | _ ->
- invalid_arg
- (sprintf "incompatible types in addition: %s + %s"
- (printable_string_of_variable value1)
- (printable_string_of_variable value2))
-
-and sub_values value1 value2 =
- match value1, value2 with
- | T_int i1, T_int i2 -> T_int (sub_big_int i1 i2)
- | T_float i1, T_float i2 -> T_float (i1 -. i2)
- | T_int i1, T_float i2 -> T_float (float_of_big_int i1 -. i2)
- | T_float i1, T_int i2 -> T_float (i1 -. float_of_big_int i2)
- | _ ->
- invalid_arg
- (sprintf "incompatible types in subtraction: %s - %s"
- (printable_string_of_variable value1)
- (printable_string_of_variable value2))
-
-and mul_values value1 value2 =
- match value1, value2 with
- | T_int i1, T_int i2 -> T_int (mult_big_int i1 i2)
- | T_float i1, T_float i2 -> T_float (i1 *. i2)
- | T_int i1, T_float i2 -> T_float (float_of_big_int i1 *. i2)
- | T_float i1, T_int i2 -> T_float (i1 *. float_of_big_int i2)
- | _ ->
- invalid_arg
- (sprintf "incompatible types in multiplication: %s * %s"
- (printable_string_of_variable value1)
- (printable_string_of_variable value2))
-
-and div_values value1 value2 =
- match value1, value2 with
- | T_int i1, T_int i2 -> T_int (div_big_int i1 i2)
- | T_float i1, T_float i2 -> T_float (i1 /. i2)
- | T_int i1, T_float i2 -> T_float (float_of_big_int i1 /. i2)
- | T_float i1, T_int i2 -> T_float (i1 /. float_of_big_int i2)
- | _ ->
- invalid_arg
- (sprintf "incompatible types in division: %s / %s"
- (printable_string_of_variable value1)
- (printable_string_of_variable value2))
-
-and mod_values value1 value2 =
- match value1, value2 with
- | T_int i1, T_int i2 -> T_int (mod_big_int i1 i2)
- | T_float i1, T_float i2 -> T_float (mod_float i1 i2)
- | T_int i1, T_float i2 -> T_float (mod_float (float_of_big_int i1) i2)
- | T_float i1, T_int i2 -> T_float (mod_float i1 (float_of_big_int i2))
- | _ ->
- invalid_arg
- (sprintf "incompatible types in modulo: %s mod %s"
- (printable_string_of_variable value1)
- (printable_string_of_variable value2))
-
-and string_of_variable = function
- | T_unit -> "" (* for string_of_variable, we don't want () here *)
- | 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
-
-and printable_string_of_variable = function
- | T_unit -> "()"
- | T_bool b -> string_of_bool b
- | T_string s -> sprintf "%S" s
- | T_int i -> string_of_big_int i
- | T_float f -> string_of_float f
-
-let job_evaluate job variables onload =
- match job with
- | { job_cond = Every_job _ } -> false, job
- | { job_cond = When_job whenexpr } ->
- let state = eval_whenexpr_as_bool job variables onload 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
- | None, false
- | Some false, false
- | Some true, true
- | Some true, false ->
- let jobp = { job.job_private with job_prev_eval_state = Some state } in
- let job = { job with job_private = jobp } in
- false, job
-
- | None, true
- | Some false, true ->
- let jobp = { job_prev_eval_state = Some true;
- job_prev_variables = Some variables } in
- let job = { job with job_private = jobp } in
- true, job
-
-let next_periodexpr =
- (* Round up 'a' to the next multiple of 'i'. *)
- let round_up_float a i =
- let r = mod_float a i in
- if r = 0. then a +. i else a +. (i -. r)
- and round_up a i =
- let r = a mod i in
- if r = 0 then a + i else a + (i - r)
- in
-
- fun t -> function
- | Every_seconds i ->
- let i = float_of_int i in
- round_up_float t i
-
- | Every_years i ->
- let tm = gmtime t in
-
- (* Round 'tm' up to the first day of the next year. *)
- let year = round_up tm.tm_year i in
- let tm = { tm with tm_sec = 0; tm_min = 0; tm_hour = 0;
- tm_mday = 1; tm_mon = 0; tm_year = year } in
- fst (mktime tm)
-
- | Every_days i ->
- let t = Date.from_unixfloat t in
- let t0 = Date.make 1970 1 1 in
-
- (* Number of whole days since Unix Epoch. *)
- let nb_days = Date.Period.safe_nb_days (Date.sub t t0) in
-
- let nb_days = round_up nb_days i in
- let t' = Date.add t0 (Date.Period.day nb_days) in
- Date.to_unixfloat t'
-
- | Every_months i ->
- (* Calculate number of whole months since Unix Epoch. *)
- let tm = gmtime t in
- let months = 12 * (tm.tm_year - 70) + tm.tm_mon in
-
- let months = round_up months i in
- let t0 = Date.make 1970 1 1 in
- let t' = Date.add t0 (Date.Period.month months) in
- Date.to_unixfloat t'
val filter_map : ('a -> 'b option) -> 'a list -> 'b list
(** Filter + map. *)
-
-type whenexpr =
- | Expr_unit (** Unit constant. *)
- | Expr_bool of bool (** A boolean constant. *)
- | Expr_str of string (** A string constant. *)
- | Expr_int of Big_int.big_int (** An integer constant. *)
- | Expr_float of float (** A float constant. *)
- | Expr_var of string (** A variable name. *)
- | Expr_and of whenexpr * whenexpr (** && *)
- | Expr_or of whenexpr * whenexpr (** || *)
- | Expr_lt of whenexpr * whenexpr (** < *)
- | Expr_le of whenexpr * whenexpr (** <= *)
- | Expr_eq of whenexpr * whenexpr (** == *)
- | Expr_ge of whenexpr * whenexpr (** >= *)
- | Expr_gt of whenexpr * whenexpr (** > *)
- | Expr_not of whenexpr (** boolean not *)
- | Expr_add of whenexpr * whenexpr (** arithmetic addition or string cat *)
- | Expr_sub of whenexpr * whenexpr (** arithmetic subtraction *)
- | Expr_mul of whenexpr * whenexpr (** arithmetic multiplication *)
- | Expr_div of whenexpr * whenexpr (** arithmetic division *)
- | Expr_mod of whenexpr * whenexpr (** arithmetic modulo *)
- | Expr_changes of string (** changes var *)
- | Expr_increases of string (** increases var *)
- | Expr_decreases of string (** decreases var *)
- | Expr_prev of string (** prev var *)
- | Expr_reloaded (** reloaded () *)
-(** Internal type used to represent 'when' expressions. *)
-
-type periodexpr =
- | Every_seconds of int
- | Every_days of int
- | Every_months of int
- | Every_years of int
-(** Internal type used to represent 'every' expressions. *)
-
-type shell_script = {
- sh_loc : Camlp4.PreCast.Loc.t;
- sh_script : string;
-}
-(** A shell script. *)
-
-type variable =
- | T_unit
- | T_bool of bool
- | T_string of string
- | T_int of Big_int.big_int
- | T_float of float
-(** Typed variable (see also [whenproto.x]) *)
-
-val string_of_variable : variable -> string
-
-val variable_of_rpc : Whenproto_aux.variable -> variable
-val rpc_of_variable : variable -> Whenproto_aux.variable
-
-type variables = variable StringMap.t
-(** A set of variables. *)
-
-type job_private
-(** Private state associated with a job, used for evaluation. *)
-
-type job_cond =
- | When_job of whenexpr (** when ... : << >> *)
- | Every_job of periodexpr (** every ... : << >> *)
-
-type job = {
- job_loc : Camlp4.PreCast.Loc.t;
- job_name : string;
- job_cond : job_cond;
- job_script : shell_script;
- job_private : job_private;
-}
-(** A job. Note that because of the [job_private] field, these cannot
- be constructed directly. Use {!make_when_job} or {!make_every_job}
- to construct one. *)
-
-val make_when_job : Camlp4.PreCast.Loc.t -> string -> whenexpr -> shell_script -> job
-(** Make a when-statement job. *)
-
-val make_every_job : Camlp4.PreCast.Loc.t -> string -> periodexpr -> shell_script -> job
-(** Make an every-statement job. *)
-
-val expr_of_ast : Camlp4.PreCast.Ast.Loc.t -> Camlp4.PreCast.Ast.expr -> whenexpr
-(** Convert OCaml AST to an expression. Since OCaml ASTs are much
- more general than the expressions we can use, this can raise
- [Invalid_argument] in many different situations. *)
-
-val string_of_whenexpr : whenexpr -> string
-(** Pretty-print an expression to a string. *)
-
-val string_of_periodexpr : periodexpr -> string
-(** Pretty-print a period expression to a string. *)
-
-val dependencies_of_whenexpr : whenexpr -> string list
-(** Return list of variables that an expression depends on. This is
- used to work out when an expression needs to be reevaluated. *)
-
-val dependencies_of_job : job -> string list
-(** Which variables does this job depend on? *)
-
-val job_evaluate : job -> variables -> bool -> bool * job
-(** [job_evaluate job variables onload] evaluates [job]'s condition in
- the context of the [variables], and return [true] iff it should be
- run now.
-
- Note that this returns a possibly-updated [job] structure.
-
- This is a no-op for 'every' jobs. *)
-
-val next_periodexpr : float -> periodexpr -> float
-(** [next_periodexpr t period] returns the earliest event of [period]
- strictly after time [t].
-
- Visualising periods as repeated events on a timeline, this
- returns [t']:
-
- {v
- events: ---+---------+---------+---------+---------+---------+-----
- times: t t'
- }
-
- Note that [periodexpr] events are not necessarily regular.
- eg. The start of a month is not a fixed number of seconds
- after the start of the previous month. 'Epoch' refers
- to the Unix Epoch (ie. 1970-01-01 00:00:00 UTC).
-
- If [period = Every_seconds i] then events are when
- [t' mod i == 0] when t' is the number of seconds since
- the Epoch. This returns the next t' > t.
-
- If [period = Every_days i] then events happen at
- midnight UTC every [i] days since the Epoch.
- This returns the next midnight > t.
-
- If [period = Every_months i] then events happen at
- midnight UTC on the 1st day of the month every [i] months
- since the Epoch. This returns midnight on the
- 1st day of the next month > t.
-
- If [period = Every_years i] then events happen at
- midnight UTC on the 1st day of the year when
- [(y - 1970) mod i == 0]. This returns midnight on the
- 1st day of the next year > t. *)
git.annexia.org / whenjobs.git / commitdiff