(* 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_len of 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 preinfo = { pi_job_name : string; pi_serial : Big_int.big_int; pi_variables : (string * variable) list; pi_running : preinfo_running_job list; } and preinfo_running_job = { pirun_job_name : string; pirun_serial : Big_int.big_int; pirun_start_time : float; pirun_pid : int; } type result = { res_job_name : string; res_serial : Big_int.big_int; res_code : int; res_tmpdir : string; res_output : string; res_start_time : float; } type pre = preinfo -> bool type post = result -> unit type job_cond = | When_job of whenexpr | Every_job of periodexpr type job = { job_loc : Loc.t; job_name : string; job_pre : pre option; job_post : post option; job_cond : job_cond; job_script : shell_script; } 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 (("len"|"length"|"size"), exprs) -> one_param _loc "len" exprs (fun e1 -> Expr_len e1) | 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_len e -> sprintf "len %s" (string_of_whenexpr e) | 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 | Expr_len 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 variables prev_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 variables prev_variables onload e1 && eval_whenexpr_as_bool variables prev_variables onload e2 then T_bool true else T_bool false | Expr_or (e1, e2) -> if eval_whenexpr_as_bool variables prev_variables onload e1 || eval_whenexpr_as_bool variables prev_variables onload e2 then T_bool true else T_bool false | Expr_lt (e1, e2) -> let e1 = eval_whenexpr variables prev_variables onload e1 and e2 = eval_whenexpr variables prev_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 variables prev_variables onload e1 and e2 = eval_whenexpr variables prev_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 variables prev_variables onload e1 and e2 = eval_whenexpr variables prev_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 variables prev_variables onload e1 and e2 = eval_whenexpr variables prev_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 variables prev_variables onload e1 and e2 = eval_whenexpr variables prev_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 variables prev_variables onload e) then T_bool true else T_bool false | Expr_add (e1, e2) -> let e1 = eval_whenexpr variables prev_variables onload e1 and e2 = eval_whenexpr variables prev_variables onload e2 in add_values e1 e2 | Expr_sub (e1, e2) -> let e1 = eval_whenexpr variables prev_variables onload e1 and e2 = eval_whenexpr variables prev_variables onload e2 in sub_values e1 e2 | Expr_mul (e1, e2) -> let e1 = eval_whenexpr variables prev_variables onload e1 and e2 = eval_whenexpr variables prev_variables onload e2 in mul_values e1 e2 | Expr_div (e1, e2) -> let e1 = eval_whenexpr variables prev_variables onload e1 and e2 = eval_whenexpr variables prev_variables onload e2 in div_values e1 e2 | Expr_mod (e1, e2) -> let e1 = eval_whenexpr variables prev_variables onload e1 and e2 = eval_whenexpr variables prev_variables onload e2 in mod_values e1 e2 | Expr_len e -> let e = eval_whenexpr variables prev_variables onload e in let e = string_of_variable e in T_int (big_int_of_int (String.length e)) | Expr_changes v -> let prev_value, curr_value = get_prev_curr_value variables prev_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 variables prev_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 variables prev_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 prev_variables v | Expr_reloaded -> T_bool onload and get_prev_curr_value variables prev_variables v = let prev_value = get_prev_variable prev_variables 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 prev_variables v = match 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 variables prev_variables onload expr = match eval_whenexpr variables prev_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 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' let check_valid_variable_name name = (* Don't permit certain names. *) if name = "JOBSERIAL" then failwith "JOBSERIAL variable cannot be set"; let len = String.length name in if len = 0 then failwith "variable name is an empty string"; if name.[0] <> '_' && not (isalpha name.[0]) then failwith "variable name must start with alphabetic character or underscore"; let rec loop i = if i >= len then () else if name.[i] <> '_' && not (isalnum name.[i]) then failwith "variable name contains non-alphanumeric non-underscore character" else loop (i+1) in loop 1