diff --git a/src/Cron.fs b/src/Cron.fs index b0bea80..e25af51 100644 --- a/src/Cron.fs +++ b/src/Cron.fs @@ -6,10 +6,6 @@ open Cronos open Pentole open Datatypes -open Pentole.String -open Pentole.Map -open Pentole - type PatternType = After of string type WhenExpr = | Cron of Instant | Pattern of PatternType diff --git a/src/Grains.fs b/src/Grains.fs index 0f56eb2..c4bbfb9 100644 --- a/src/Grains.fs +++ b/src/Grains.fs @@ -5,117 +5,140 @@ open System.Threading open System.Threading.Tasks open NodaTime open System +open Serilog.Events open Bidello.Datatypes open Bidello.Shell +let try_ (lambda: (unit -> ValueTask)) (prefix: string) (level: LogEventLevel) = + try + lambda () + with exn -> + let logger = Logging.logger + let msg = sprintf "%s - %s" prefix exn.Message + + match level with + | LogEventLevel.Verbose -> logger.Debug msg + | LogEventLevel.Debug -> logger.Debug msg + | LogEventLevel.Information -> logger.Information msg + | LogEventLevel.Warning -> logger.Warning msg + | LogEventLevel.Error -> logger.Error msg + | LogEventLevel.Fatal -> logger.Fatal msg + | _ -> logger.Fatal msg + + ValueTask () + type IShellGrain = inherit IGrainWithIntegerKey abstract schedule: CancellationToken -> ChainOfJobs -> ValueTask - type IDbGrain = inherit IGrainWithGuidKey abstract save_backlog: CancellationToken -> Instant * Instant -> CronJob -> RunResult -> ValueTask type DbGrain () = inherit Orleans.Grain () + member _.save_backlog_ ct (start_: Instant, end_: Instant) (job: CronJob) rc = + let stdout = match rc with | Success stdout -> Some stdout | _ -> None + + let code, stderr = + match rc with + | Failure (c, s) -> (Some c, Some s) + | Success _ -> (Some 0, None) + | _ -> (None, None) + + let fmsg = + match rc with + | NoPermissionOnFolder -> Some "No permission on folder" + | NoPrivilegeToUser -> Some "No privilege to switch user" + | Unknown u -> Some $"Unknown failure '{u}'" + | _ -> None + + + let entry = { + started_at = start_.ToDateTimeUtc() + done_at = end_.ToDateTimeUtc() + + stdout = stdout + stderr = stderr + exit_code = code + failure_msg = fmsg + + job = job.info_string () + hostname = job.hostname + job_name = job.job_name + } + + let tsk = async { + use! db = Database.make_from_grain ct |> Async.AwaitTask + let! res = Database.write_to_backlog entry ct db |> Async.AwaitTask + + return + match res with + | Ok () -> () + | Error msg -> Logging.logger.Fatal msg + } + tsk |> Async.StartAsTask |> ValueTask + interface IDbGrain with - override _.save_backlog ct (start_, end_) (job: CronJob) rc = - try - let stdout = match rc with | Success stdout -> Some stdout | _ -> None - - let code, stderr = - match rc with - | Failure (c, s) -> (Some c, Some s) - | Success _ -> (Some 0, None) - | _ -> (None, None) - - let fmsg = - match rc with - | NoPermissionOnFolder -> Some "No permission on folder" - | NoPrivilegeToUser -> Some "No privilege to switch user" - | Unknown u -> Some $"Unknown failure '{u}'" - | _ -> None - - - let entry = { - started_at = start_.ToDateTimeUtc() - done_at = end_.ToDateTimeUtc() - - stdout = stdout - stderr = stderr - exit_code = code - failure_msg = fmsg - - job = job.info_string () - hostname = job.hostname - job_name = job.job_name - } - - let tsk = async { - use! db = Database.make_from_grain ct |> Async.AwaitTask - let! res = Database.write_to_backlog entry ct db |> Async.AwaitTask - - return - match res with - | Ok () -> () - | Error msg -> Logging.logger.Fatal msg - } - tsk |> Async.StartAsTask |> ValueTask - - with exn -> printfn "%A" exn; ValueTask () + override x.save_backlog ct (start_, end_) (job: CronJob) rc = + let lambda = fun () -> + x.save_backlog_ ct (start_, end_) job rc + try_ lambda "DatabaseGrain" LogEventLevel.Fatal + +let log (job: CronJob) = function + | Success _stdout -> + $"Action: {job.info_string()}, returned code = 0" + |> Logging.logger.Information + | Failure (rc, _stderr) -> + $"Action: {job.info_string()}, returned code = {rc}" + |> Logging.logger.Error + | NoShell reason -> + $"Can't call shell: {reason}" + |> Logging.logger.Fatal + | Unknown reason -> + $"Unknown exception in job runner: {reason}" + |> Logging.logger.Error + | NoPermissionOnFolder -> + $"Action: {job.info_string()}, failed because of insufficient permission on folder" + |> Logging.logger.Fatal + | NoPrivilegeToUser -> + $"Action: {job.info_string()}, failed because insufficient permissions to run command as user" + |> Logging.logger.Fatal + type ShellGrain() = inherit Orleans.Grain () + member x.schedule_ (ct) (jobs: ChainOfJobs) = + + let db_actor = x.GrainFactory.GetGrain(Guid.NewGuid()) + + let rec run_ (hd: CronJob) (tl: CronJob list) = async { + let start_time = SystemClock.Instance.GetCurrentInstant () + let! rc = run_job ct hd |> Async.AwaitTask + let end_time = SystemClock.Instance.GetCurrentInstant () + + log hd rc + db_actor.save_backlog ct (start_time, end_time) hd rc |> ignore + + match tl with + | hd'::tl'-> return! run_ hd' tl' + | [] -> return () + } + + jobs.jobs + |> function | [] -> None | hd::tl -> Some (hd, tl) + |> Option.map (fun jobs -> + let tsk = jobs ||> run_ + Async.StartAsTask (tsk, TaskCreationOptions.None, ct) + |> ValueTask) + |> Option.defaultValue (ValueTask ()) interface IShellGrain with member x.schedule (ct) (jobs: ChainOfJobs) = - - let db_actor = x.GrainFactory.GetGrain(Guid.NewGuid()) - - let log (job: CronJob) = function - | Success _stdout -> - $"Action: {job.info_string()}, returned code = 0" - |> Logging.logger.Information - | Failure (rc, _stderr) -> - $"Action: {job.info_string()}, returned code = {rc}" - |> Logging.logger.Error - | NoShell reason -> - $"Can't call shell: {reason}" - |> Logging.logger.Fatal - | Unknown reason -> - $"Unknown exception in job runner: {reason}" - |> Logging.logger.Error - | NoPermissionOnFolder -> - $"Action: {job.info_string()}, failed because of insufficient permission on folder" - |> Logging.logger.Fatal - | NoPrivilegeToUser -> - $"Action: {job.info_string()}, failed because insufficient permissions to run command as user" - |> Logging.logger.Fatal - - let rec run_ (hd: CronJob) (tl: CronJob list) = async { - let start_time = SystemClock.Instance.GetCurrentInstant () - let! rc = run_job ct hd |> Async.AwaitTask - let end_time = SystemClock.Instance.GetCurrentInstant () - - log hd rc - db_actor.save_backlog ct (start_time, end_time) hd rc |> ignore - - match tl with - | hd'::tl'-> return! run_ hd' tl' - | [] -> return () - } - - jobs.jobs - |> function | [] -> None | hd::tl -> Some (hd, tl) - |> Option.map (fun jobs -> - let tsk = jobs ||> run_ - Async.StartAsTask (tsk, TaskCreationOptions.None, ct) - |> ValueTask) - |> Option.defaultValue (ValueTask ()) -(*TODO: try block?*) + let lambda = fun () -> x.schedule_ ct jobs + try_ lambda "ShellGrain" LogEventLevel.Error diff --git a/src/LoggingHelpers.fs b/src/LoggingHelpers.fs deleted file mode 100644 index fd2ab27..0000000 --- a/src/LoggingHelpers.fs +++ /dev/null @@ -1,118 +0,0 @@ -module Pentole.LoggingHelpers - -open System - -open Serilog -open Serilog.Events -open Serilog.Sinks.SystemConsole.Themes -open Serilog.Sinks.File - - -type Override = - | Verbose of string - | Debug of string - | Information of string - | Warning of string - | Error of string - | Fatal of string - -type Buffered = Yes | No -type Shared = Yes | No -type RollOnSizeLimit = Yes | No - - -type FileConfiguration = { - path: string - level: LogEventLevel - template: string - format_provider: System.IFormatProvider - file_size_bytes_limit: uint64 - level_switch: Core.LoggingLevelSwitch option - buffered: Buffered - shared: Shared - flush_interval: TimeSpan option - rolling_interval: RollingInterval - roll_on_size_limit: RollOnSizeLimit - retained_files: uint - lifecycle_hooks: FileLifecycleHooks option -} - -type Configuration = { - theme: SystemConsoleTheme - overrides: Override list - template: string - files: FileConfiguration list -} - -let from_config (c: Configuration) = - - let override_ (lc: LoggerConfiguration) = function - | Verbose namespace_ -> - lc.MinimumLevel.Override (namespace_, LogEventLevel.Verbose) - | Debug namespace_ -> - lc.MinimumLevel.Override (namespace_, LogEventLevel.Debug) - | Information namespace_ -> - lc.MinimumLevel.Override (namespace_, LogEventLevel.Information) - | Warning namespace_ -> - lc.MinimumLevel.Override (namespace_, LogEventLevel.Warning) - | Error namespace_ -> - lc.MinimumLevel.Override (namespace_, LogEventLevel.Error) - | Fatal namespace_ -> - lc.MinimumLevel.Override (namespace_, LogEventLevel.Fatal) - - let lc = - c.overrides - |> List.fold (fun lc target -> override_ lc target) (LoggerConfiguration()) - - let null_or = function | Some a -> a | None -> null - let buffered = function | Buffered.Yes -> true | Buffered.No -> false - let shared = function | Shared.Yes -> true | Shared.No -> false - let roll = function | RollOnSizeLimit.Yes -> true | RollOnSizeLimit.No -> false - - let flush_interval = function Some ts -> Nullable ts | None -> Nullable () - - let lc = - c.files - |> List.fold (fun (lc: LoggerConfiguration) (fc: FileConfiguration) -> - lc.WriteTo.File( - path = fc.path, - restrictedToMinimumLevel = fc.level, - outputTemplate = fc.template, - formatProvider = fc.format_provider, - fileSizeLimitBytes = Nullable (int64 fc.file_size_bytes_limit), - levelSwitch = null_or fc.level_switch, - buffered = buffered fc.buffered, - shared = shared fc.shared, - flushToDiskInterval = flush_interval fc.flush_interval, - rollingInterval = fc.rolling_interval, - rollOnFileSizeLimit = roll fc.roll_on_size_limit, - retainedFileCountLimit = Nullable (int fc.retained_files), - encoding = System.Text.Encoding.UTF8, - hooks = null_or fc.lifecycle_hooks, - retainedFileTimeLimit = TimeSpan.Zero)) - lc - - lc - .WriteTo.Console(theme=c.theme, outputTemplate=c.template) - .CreateLogger() - -module Default = - let retained_files = 31 (* one month *) - let file_size_bytes = 1 * 1024 * 1024 * 1024 (* 1GB *) - let size_limit = 1 * 1024 * 1024 * 1024 (* 1GB *) - let template = "{Timestamp:yyyy-MM-dd HH:mm:ss.fff zzz} [{Level:u3}] {Message:lj}{NewLine}{Exception}"; - let debug_template = "[{Timestamp:HH:mm:ss} {Level:u3}] |{SourceContext}| {Message:lj}{NewLine}{Exception}" - let theme = Serilog.Sinks.SystemConsole.Themes.SystemConsoleTheme.Literate - - let overrides = [ - Warning "Orleans.Runtime" - Warning "Orleans.Hosting" - Warning "Microsoft" - // Warning "Microsoft.AspNetCore" - // Warning "Microsoft.AspNetCore.Hosting" - // Warning "Microsoft.AspNetCore.Mvc" - // Warning "Microsoft.AspNetCore.Routing" - // Warning "Orleans.Runtime.Silo" -// Warning "Orleans.Runtime.SiloOptionsLogger" - // Warning "Orleans.Runtime.SiloHostedService" - ] diff --git a/src/Result.fs b/src/Result.fs deleted file mode 100644 index 03cefa8..0000000 --- a/src/Result.fs +++ /dev/null @@ -1,50 +0,0 @@ -namespace Pentole - -module Result = - - let inline protect ([]f) x = - try - Ok (f x) - with e -> Error e - - let inline pairwise_map fun_ (x: 'a, y: 'a) = - match fun_ x with - | Error e -> Error e - | Ok o -> - match fun_ y with | Ok o' -> Ok (o, o') | Error e -> Error e - - let of_option = function | Some s -> Ok s | None -> Error () - - let zip a b = - match (a, b) with - | Ok a, Ok b -> Ok (a, b) - | Error e, _ -> Error e - | _, Error e -> Error e - - let inline get r = - match r with - | Ok o -> o - | Error e -> - $"Tried to access value from Result r, error={e}" - |> System.ArgumentException - |> raise - - - type ToStringWrapper(toString) = - override _.ToString() = toString () - - let Result l = ToStringWrapper(fun _ -> - match l with - | Ok o -> sprintf "Ok %O" o - | _ -> failwith "") - -module ResultList = - let collect (lambda: 'a -> Result<'ok, 'err>) (seq_: 'a seq) = - let rec iter_ acc seq_ = - match Seq.tryHead seq_ with - | None -> Ok acc - | Some x -> - match lambda x with - | Error e -> Error e - | Ok o -> iter_ (o::acc) (Seq.tail seq_) - iter_ [] seq_ diff --git a/src/String.fs b/src/String.fs deleted file mode 100644 index 924d4d0..0000000 --- a/src/String.fs +++ /dev/null @@ -1,7 +0,0 @@ -module Pentole.String - -let (|Prefix|_|) (p: string) (s: string) = - if s.StartsWith p then - s.Substring p.Length |> Some - else - None diff --git a/src/src.fsproj b/src/src.fsproj index e43cc44..7dd7d3e 100644 --- a/src/src.fsproj +++ b/src/src.fsproj @@ -8,11 +8,8 @@ - - - @@ -38,7 +35,7 @@ - + diff --git a/tests/UnitTest1.fs b/tests/UnitTest1.fs index 66aad8a..4564347 100644 --- a/tests/UnitTest1.fs +++ b/tests/UnitTest1.fs @@ -1,12 +1,10 @@ module tests open NUnit.Framework -open Pentole.TestsExtensions +open Pentole open Bidello.Datatypes open Bidello -open Pentole.String - let now = NodaTime.SystemClock.Instance.GetCurrentInstant () [] @@ -34,7 +32,7 @@ let run_function x = Cron.sort_jobs now x |> Result.map (List.map reduce) - |> Pentole.Result.get + |> Result.Unsafe.get [] let job_deps_simple () = @@ -46,7 +44,7 @@ let job_deps_simple () = let expected = [[("h1", "j1")]] - setEqual expected cjs + Assert.setEqual expected cjs [] let job_deps () = @@ -61,7 +59,7 @@ let job_deps () = let cjs = run_function requirements let expected = [[("h1", "j1"); ("h1", "j1_after")]; [("h2", "j1")]; [("h1", "j2")]] - setEqual expected cjs + Assert.setEqual expected cjs [] let job_deps2 () = @@ -79,7 +77,7 @@ let job_deps2 () = let expected = [[("h1", "j1"); ("h1", "j1_after")]; [("h1", "j2"); ("h1", "j2_after")]; [("h2", "j1")]] - setEqual expected cjs + Assert.setEqual expected cjs [] let should_fail_no_host () = @@ -95,7 +93,7 @@ let should_fail_no_host () = Cron.sort_jobs now requirements |> Result.isError - |> isTrue + |> Assert.isTrue [] let job_deps_chain0 () = @@ -108,11 +106,10 @@ let job_deps_chain0 () = ] let cjs = run_function requirements - printfn "GOT: %A" cjs let expected = [[("h1", "j1"); ("h1", "j2_after_j1"); ("h1", "j3_after_j2")]; [("h2", "j1")]] - setEqual expected cjs + Assert.setEqual expected cjs [] let job_deps_chain1 () = @@ -131,7 +128,7 @@ let job_deps_chain1 () = ("h1", "j2_after_j1"); ("h1", "j3_after_j2")]; [("h2", "j1")]] - setEqual expected cjs + Assert.setEqual expected cjs [] let job_deps_chain_failure () = @@ -142,4 +139,4 @@ let job_deps_chain_failure () = Cron.sort_jobs now requirements |> Result.isError - |> isTrue + |> Assert.isTrue diff --git a/tests/tests.fsproj b/tests/tests.fsproj index 780d58d..1845a75 100644 --- a/tests/tests.fsproj +++ b/tests/tests.fsproj @@ -19,7 +19,7 @@ - +