From ef9788127064d40717c4fc2e5f334e5378b9b78e Mon Sep 17 00:00:00 2001 From: "bparodi@lezzo.org" Date: Sat, 26 Oct 2024 12:15:44 +0200 Subject: [PATCH] first --- .gitignore | 110 +++++++++++++++++++++ Makefile | 10 ++ bidello.sln | 14 +++ entrypoint/Program.cs | 39 ++++++++ entrypoint/entrypoint.csproj | 20 ++++ entrypoint/script.gnuplot | 21 ++++ src/Cron.fs | 161 ++++++++++++++++++++++++++++++ src/Database.fs | 89 +++++++++++++++++ src/DatabaseMigrations.fs | 186 +++++++++++++++++++++++++++++++++++ src/Datatypes.fs | 28 ++++++ src/Environment.fs | 31 ++++++ src/Grains.fs | 22 +++++ src/Jobs.fs | 5 + src/Library.fs | 127 ++++++++++++++++++++++++ src/LoggingHelpers.fs | 118 ++++++++++++++++++++++ src/Result.fs | 25 +++++ src/String.fs | 7 ++ src/src.fsproj | 42 ++++++++ 18 files changed, 1055 insertions(+) create mode 100644 .gitignore create mode 100644 Makefile create mode 100644 bidello.sln create mode 100644 entrypoint/Program.cs create mode 100644 entrypoint/entrypoint.csproj create mode 100644 entrypoint/script.gnuplot create mode 100644 src/Cron.fs create mode 100644 src/Database.fs create mode 100644 src/DatabaseMigrations.fs create mode 100644 src/Datatypes.fs create mode 100644 src/Environment.fs create mode 100644 src/Grains.fs create mode 100644 src/Jobs.fs create mode 100644 src/Library.fs create mode 100644 src/LoggingHelpers.fs create mode 100644 src/Result.fs create mode 100644 src/String.fs create mode 100644 src/src.fsproj diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..d1984a3 --- /dev/null +++ b/.gitignore @@ -0,0 +1,110 @@ +*.secret + +## Ignore Visual Studio temporary files, build results, and +## files generated by popular Visual Studio add-ons. +## +## Get latest from https://github.com/github/gitignore/blob/master/VisualStudio.gitignore + +# User-specific files +*.suo +*.user +*.userosscache +*.sln.docstates + +# Build results +[Dd]ebug/ +[Dd]ebugPublic/ +[Rr]elease/ +x64/ +x86/ +bld/ +[Bb]in/ +[Oo]bj/ +[Ll]og/ + +# .NET Core +project.lock.json +project.fragment.lock.json +artifacts/ +**/Properties/launchSettings.json + +*_i.c +*_p.c +*_i.h +*.ilk +*.meta +*.obj +*.pch +*.pdb +*.pgc +*.pgd +*.rsp +*.sbr +*.tlb +*.tli +*.tlh +*.tmp +*.tmp_proj +*.log +*.vspscc +*.vssscc +.builds +*.pidb +*.svclog +*.scc + +# Chutzpah Test files +_Chutzpah* + +# Visual C++ cache files +ipch/ +*.aps +*.ncb +*.opendb +*.opensdf +*.sdf +*.cachefile +*.VC.db +*.VC.VC.opendb + +# Visual Studio profiler +*.psess +*.vsp +*.vspx +*.sap + +# TFS 2012 Local Workspace +$tf/ + +# Guidance Automation Toolkit +*.gpState + +# ReSharper is a .NET coding add-in +_ReSharper*/ +*.[Rr]e[Ss]harper +*.DotSettings.user + + +publish/ + +*.[Pp]ublish.xml +*.azurePubxml +# TODO: Comment the next line if you want to checkin your web deploy settings +# but database connection strings (with potential passwords) will be unencrypted +*.pubxml +*.publishproj + +# Microsoft Azure Web App publish settings. Comment the next line if you want to +# checkin your Azure Web App publish settings, but sensitive information contained +# in these scripts will be unencrypted +PublishScripts/ + +# NuGet Packages +*.nupkg +# The packages folder can be ignored because of Package Restore +**/packages/* +# except build/, which is used as an MSBuild target. +!**/packages/build/ +# Python Tools for Visual Studio (PTVS) +__pycache__/ +*.pyc diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..7c9382d --- /dev/null +++ b/Makefile @@ -0,0 +1,10 @@ +USER := $(shell cat user.secret) +PASSWORD := $(shell cat password.secret) +HOST := $(shell cat host.secret) + +build: + cd src && dotnet build +run: + cd entrypoint && dotnet run -- --user ${USER} --password ${PASSWORD} -H ${HOST} +test: + dotnet test diff --git a/bidello.sln b/bidello.sln new file mode 100644 index 0000000..bb32f59 --- /dev/null +++ b/bidello.sln @@ -0,0 +1,14 @@ + +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio Version 17 +VisualStudioVersion = 17.0.31903.59 +MinimumVisualStudioVersion = 10.0.40219.1 +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|Any CPU = Debug|Any CPU + Release|Any CPU = Release|Any CPU + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection +EndGlobal diff --git a/entrypoint/Program.cs b/entrypoint/Program.cs new file mode 100644 index 0000000..3abc98f --- /dev/null +++ b/entrypoint/Program.cs @@ -0,0 +1,39 @@ + +using Microsoft.Extensions.DependencyInjection; +using Microsoft.Extensions.Hosting; +using Microsoft.Extensions.Logging; +using Orleans; +using Orleans.Hosting; +using Serilog; +using Orleans.Serialization; +using Orleans.Serialization.Buffers; +using Orleans.Serialization.Cloning; +using Orleans.Serialization.Serializers; +using Orleans.Serialization.WireProtocol; + +using static Bidello.Grains; +[assembly: GenerateCodeForDeclaringAssembly(typeof(Bidello.Grains.ShellGrain))] +namespace Bidello.Entrypoint; + +// [assembly: KnownType(typeof(Verbale.Grains.LoggingGrain))] [assembly: KnownAssembly(typeof(Verbale.Grains.LoggingGrain))] + + +class Entrypoint { + static void Main(string[] args) { + var logger = new LoggerConfiguration() + .MinimumLevel.Debug() + .WriteTo.Console() + .CreateLogger(); + var host = new HostBuilder() + .UseOrleans(builder => + { + builder.UseLocalhostClustering() + .ConfigureLogging(s => s.AddSerilog().AddConsole()) + ; + }) + .UseConsoleLifetime(); + + Bidello.Main.main(args, host); + + } +} diff --git a/entrypoint/entrypoint.csproj b/entrypoint/entrypoint.csproj new file mode 100644 index 0000000..2318cb6 --- /dev/null +++ b/entrypoint/entrypoint.csproj @@ -0,0 +1,20 @@ + + + + + + + + + + + + + + Exe + net8.0 + enable + enable + + + diff --git a/entrypoint/script.gnuplot b/entrypoint/script.gnuplot new file mode 100644 index 0000000..18b6789 --- /dev/null +++ b/entrypoint/script.gnuplot @@ -0,0 +1,21 @@ +# set terminal pngcairo transparent enhanced font "arial,10" fontscale 1.0 size 600, 400 +# set output 'scatter.5.png' +set dgrid3d 10,10 qnorm 16 +set dummy u, v +set key fixed right top vertical Right noreverse enhanced autotitle box lt black linewidth 1.000 dashtype solid +set parametric +set contour base +set style data lines +set title "Simple demo of scatter data conversion to grid data" +set xlabel "data style lines, dgrid3d qnorm 16, contour" +set xrange [ * : * ] noreverse writeback +set x2range [ * : * ] noreverse writeback +set yrange [ * : * ] noreverse writeback +set y2range [ * : * ] noreverse writeback +set zrange [ * : * ] noreverse writeback +set cbrange [ * : * ] noreverse writeback +set rrange [ * : * ] noreverse writeback +set colorbox vertical origin screen 0.9, 0.2 size screen 0.05, 0.6 front noinvert bdefault +NO_ANIMATION = 1 +## Last datafile plotted: "hemisphr.dat" +splot "hemisphr.dat" diff --git a/src/Cron.fs b/src/Cron.fs new file mode 100644 index 0000000..fc31318 --- /dev/null +++ b/src/Cron.fs @@ -0,0 +1,161 @@ +module Bidello.Cron + +open NodaTime +open Cronos + +open Pentole.Path +open Pentole +open Datatypes + +open Pentole.String + +type User = string + +let rnd = new System.Random 2 +let local_tz = DateTimeZoneProviders.Tzdb.GetSystemDefault () +let local_tz_net = System.TimeZoneInfo.Local + +let private rand_int incl_ excl_ = rnd.NextInt64 (incl_, excl_) + +let private parse_expr (now: Instant) text = + let to_cron text = + let mutable c: CronExpression = Unchecked.defaultof + match CronExpression.TryParse (text, &c) with + | true -> Ok c + | false -> Error $"Can't parse cron expression: {text}" + + let to_pattern text = + match Pentole.String.split " " text |> List.head with + | Prefix "@after" job -> After job |> Ok + | Prefix "@before" job -> Before job |> Ok + | _ -> Error $"Can't parse as pattern: {text}" + + match to_cron text, to_pattern text with + | Error e, Error _ -> Error e + | _, Ok p -> Ok (Pattern p) + | Ok cron_expr, _ -> + (now.ToDateTimeOffset(), local_tz_net) + |> Result.protect (cron_expr.GetNextOccurrence) + |> Result.mapError (_.Message) + |> Result.bind (fun i -> + if not i.HasValue then Error $"invalid cron expression: {text}" + else Instant.FromDateTimeOffset i.Value |> Cron |> Ok) +(* +let private schedule (pt: PatternType) (now: Instant) (done_at: Instant option) = + let now' = now.InZone local_tz + if done_at.IsNone then + let last_possible_moment = + match pt with + | After _ | Before _ -> + "CronJobs with patterns should be in a different partition" + |> System.InvalidOperationException |> raise + | Hourly -> + now'.Minute + (60 - now'.Minute) |> int64 |> Duration.FromMinutes + | Daily -> + now'.Hour + (24 - now'.Hour) |> Duration.FromHours + | Weekly -> + let sunday = now'.LocalDateTime.With(DateAdjusters.NextOrSame(IsoDayOfWeek.Sunday)) + sunday + | Monthly -> + let end_of_the_month = now'.LocalDateTime.With DateAdjusters.EndOfMonth + end_of_the_month + let ts = dur.TotalSeconds |> int + rand_int 0 ts + + else failwith "" + + +let make (now: Instant) (env: Database.EnvVarsEntry list) (src: Database.CronTableEntry) = + let resolve_ path = + Path.of_string path + |> Result.bind (FileSystem.resolve) + |> Result.mapError (fun e -> $"{e} for path {path}") + + let get_env (job_name: string) = + env + |> List.filter (fun e -> e.job_name = job_name) + |> List.map (fun e -> (e.value, e.variable)) + + + (src.executable, src.workdir) + |> Result.pairwise_map resolve_ + |> Result.bind (fun (what, where) -> + parse_expr now src.``when`` |> Result.map (fun when_ -> (what, where, when_))) + |> Result.map (fun (what, where, when_) -> { + job_name = src.job_name + user = src.user + when_ = when_ + executable = what + args = src.args |> List.ofArray + environment = get_env src.job_name + workdir = where + hostname = src.hostname }) + |> Result.mapError (fun e -> (src.job_name, e)) + + +let build_sorted_jobs_table (logger: Serilog.ILogger) (hostname: string) (now: Instant) + (requirements: Database.Requirements) = + let cronjobs = + requirements.cron + |> List.map (Cron.make now requirements.environment) + |> List.choose (function + | Ok cj when cj.hostname <> hostname -> None + | Ok cronjob -> Some cronjob + | Error (j, e) -> + logger.Warning $"Invalid job definition {j}, reason: {e}" + None) + + let has_deps = function + | {when_=Pattern (After _ | Before _)} -> true + | {when_=Cron _} -> false + | {when_=Pattern (Hourly | Daily | Weekly | Monthly)} -> false + + let resolve_ts = function + | {when_=Pattern (After _ | Before _)} -> + "CronJobs with patterns should be in a different partition" + |> System.InvalidOperationException |> raise + + | {when_=Cron x} as cj -> (x, cj) + | {when_=Pattern pt} as cj -> + cj.job_name + |> requirements.backlog.TryFind + |> schedule pt now + + + + + let standalone, with_deps = + cronjobs + |> List.partition has_deps + + let standalone = + standalone + |> List.map resolve_ts + + let children = + with_deps + |> List.choose (function + | {when_=Pattern (Before _child)} as parent -> Some parent + | _ -> None) + |> List.groupBy (function | {when_=Pattern (After child)} -> child) + |> Map.ofList + + let parents = + with_deps + |> List.choose (function + | {when_=Pattern (After _parent)} as child -> Some child + | _ -> None) + |> List.groupBy (function | {when_=Pattern (After parent)} -> parent) + |> Map.ofList +(* + let rec sort acc : CronJob list -> CronJob list = function + | [] -> acc + | x::rest -> + let parents_of_x = parents |> Map.tryFind x.hostname |> Option.defaultValue [] + let children_of_x = children |> Map.tryFind x.hostname |> Option.defaultValue [] + let current = parents_of_x @ [x] @ children_of_x + + let acc' = System.Diagnostics.Trace.Assert +*) + parents +*) diff --git a/src/Database.fs b/src/Database.fs new file mode 100644 index 0000000..cae6962 --- /dev/null +++ b/src/Database.fs @@ -0,0 +1,89 @@ +module Bidello.Database + +open System.Reflection +open System.Threading + +open Microsoft.Extensions.DependencyInjection +open FluentMigrator.Runner +open Serilog +open Npgsql +open Dapper + +let private connstring = + let c = Environment.Environment() + $"Server={c.pg_host};Database={c.pg_dbname};" + + $"UserId={c.pg_user};Password={c.pg_password};" + + "Tcp Keepalive=true" + +type t = { + connection: NpgsqlConnection +} + +let run_migrations (logger: ILogger) = + + let assembly = + Assembly.GetAssembly(typeof) + + + let s = + ServiceCollection() + .AddFluentMigratorCore() + .ConfigureRunner(fun c -> + c + .AddPostgres().WithGlobalConnectionString(connstring) + .ScanIn([|assembly|]).For.Migrations() |> ignore) + // .Configure(fun (opts: RunnerOptions) -> opts.Tags <- [| tag |]) + .BuildServiceProvider false + let runner = s.GetRequiredService() + logger.Information "Running database migrations" + runner.MigrateUp() + + +let make (logger: ILogger) = + let conn = new NpgsqlConnection (connstring) + conn.Open() + let n: NotificationEventHandler = + new NotificationEventHandler(fun (_o: obj) -> ignore) + + conn.Notification.AddHandler(n) + + use listen = new NpgsqlCommand ("LISTEN bidello_database_update;", conn) + listen.ExecuteNonQuery () |> ignore + + {connection = conn} + + +let wait_notification (ct: CancellationToken) (db: t) = + db.connection.WaitAsync ct + +type Requirements_ = { + job_name: string + ``when``: string + executable: string + user: string + workdir: string + hostname: string + args: string array + environment: string + done_at: System.DateTime option +} + +let gather_requirements (hostname: string) (ct: CancellationToken) (db: t) = + let query = """select + c.job_name, c."when", c.executable, c.user, c.workdir, c.args, h.hostname, + STRING_AGG(e.variable || '=' || e.value, '|') AS environment_variables, + max(b.done_at) as done_at + from cron c +left join environment e on c.job_name = e.job_name +left join backlog b on b.job_name = c.job_name and b.hostname = @hostname +join hosts h on h.job_name = c.job_name +where h.hostname = @hostname +group by c.job_name, h.hostname """ + + let nl = System.Nullable () + let cl = System.Nullable () + let param = {|hostname = hostname|} + new CommandDefinition (query, parameters=param, transaction=null, + commandTimeout=nl, commandType=cl, + flags=CommandFlags.Buffered, cancellationToken=ct) + |> db.connection.QueryAsync diff --git a/src/DatabaseMigrations.fs b/src/DatabaseMigrations.fs new file mode 100644 index 0000000..f1c25d8 --- /dev/null +++ b/src/DatabaseMigrations.fs @@ -0,0 +1,186 @@ +module Bidello.DatabaseMigrations + +open FluentMigrator + +[] +type OnlyUp () = + inherit Migration () + override _.Down () = failwith "Down is not implemented in this migration" + +[] +type Init () = + inherit OnlyUp () + override x.Up() = + let table_notify = """ + +-- DROP FUNCTION public.notify_table_update(); + +CREATE OR REPLACE FUNCTION public.notify_table_update() + RETURNS trigger + LANGUAGE plpgsql +AS $function$ + DECLARE + row RECORD; + output TEXT; + + BEGIN + -- Checking the Operation Type + IF (TG_OP = 'DELETE') THEN + row = OLD; + ELSE + row = NEW; + END IF; + + -- Forming the Output as notification. You can choose you own notification. + output = 'Update on bidello database'; + + -- Calling the pg_notify for table_update event with output as payload + + PERFORM pg_notify('bidello_database_update', output); + + -- Returning null because it is an after trigger. + RETURN NULL; + END; + $function$ +; + """ + let cron_table = """ +CREATE TABLE public.cron ( + job_name varchar(24) NOT NULL primary key, + "when" text NOT NULL, + executable text NOT NULL, + "user" text NOT NULL, + workdir text NOT NULL, + comment text, + args text[] +);""" + + let ownership0 = """ALTER TABLE public.cron OWNER TO pico;""" + + let hosts_table = """ +CREATE TABLE public.hosts ( + id SERIAL, + hostname text NOT NULL, + job_name varchar(24) NOT NULL references cron(job_name), + comment text +);""" + let ownership1 = """ALTER TABLE public.hosts OWNER TO pico;""" + + let triggers = [ + """CREATE TRIGGER bidello_hosts_notify_delete + AFTER DELETE ON public.hosts FOR EACH STATEMENT EXECUTE FUNCTION public.notify_table_update();""" + + """CREATE TRIGGER bidello_hosts_notify_insert + AFTER INSERT ON public.hosts FOR EACH STATEMENT EXECUTE FUNCTION public.notify_table_update();""" + + """CREATE TRIGGER bidello_hosts_notify_update + AFTER UPDATE ON public.hosts FOR EACH STATEMENT EXECUTE FUNCTION public.notify_table_update();""" + + """CREATE TRIGGER bidello_cron_notify_delete + AFTER DELETE ON public.cron FOR EACH STATEMENT EXECUTE FUNCTION public.notify_table_update();""" + """CREATE TRIGGER bidello_cron_notify_insert + AFTER INSERT ON public.cron FOR EACH STATEMENT EXECUTE FUNCTION public.notify_table_update();""" + + """CREATE TRIGGER bidello_cron_notify_update + AFTER UPDATE ON public.cron FOR EACH STATEMENT EXECUTE FUNCTION public.notify_table_update();""" + + ] + + let env_table = """ +CREATE TABLE public.environment ( + id SERIAL, + variable text NOT NULL, + value text NOT NULL, + job_name varchar(24) NOT NULL references cron(job_name), + comment text +);""" + let ownership2 = """ALTER TABLE public.environment OWNER TO pico;""" + + x.Execute.Sql table_notify + x.Execute.Sql cron_table + x.Execute.Sql ownership0 + x.Execute.Sql hosts_table + x.Execute.Sql ownership1 + x.Execute.Sql env_table + x.Execute.Sql ownership2 + triggers |> List.iter (fun s -> s |> x.Execute.Sql |> ignore) + +[] +type JobTable () = + inherit OnlyUp () + override x.Up() = + + let job_table = """ +CREATE TABLE public.current_jobs ( + job_name varchar(24) NOT NULL references cron(job_name), + hostname text NOT NULL, + exact_ts timestamptz NOT NULL, +);""" + let ownership = """ALTER TABLE public.current_jobs OWNER TO pico;""" + + x.Execute.Sql job_table + x.Execute.Sql ownership + + +[] +type UpdatedAt () = + inherit OnlyUp () + override x.Up() = + let tables = ["cron"; "current_jobs"; "hosts"; "environment"] + tables + |> List.iter (fun table -> + x.Execute.Sql $"""ALTER TABLE {table} + ADD updated_at timestamptz + DEFAULT current_timestamp NOT NULL;""") + +[] +type AddHostnameToEnv () = + inherit OnlyUp () + override x.Up() = + x.Alter.Table("environment") + .AddColumn("hostname").AsString().NotNullable() + .SetExistingRowsTo("edi") + |> ignore + +[] +type AddBacklog () = + inherit OnlyUp () + override x.Up() = + "ALTER TABLE environment ALTER COLUMN hostname SET NOT NULL;" + |> x.Execute.Sql + + """ALTER TABLE current_jobs DROP COLUMN args;""" + |> x.Execute.Sql + """ALTER TABLE current_jobs DROP COLUMN env;""" + |> x.Execute.Sql + + let backlog = + """CREATE TABLE backlog ( + job_name varchar(24) NOT NULL references cron(job_name), + hostname text NOT NULL , + done_at timestamptz NOT NULL, + + executable text NOT NULL, + "user" text NOT NULL, + workdir text NOT NULL, + args text[], + env text -- format: "key=value|key=value" + );""" + x.Execute.Sql backlog + +[] +type ChangeBacklogDrop () = + inherit OnlyUp () + override x.Up() = + x.Delete.Column("executable").FromTable "backlog" |> ignore + x.Delete.Column("user").FromTable "backlog" |> ignore + x.Delete.Column("workdir").FromTable "backlog" |> ignore + x.Delete.Column("args").FromTable "backlog" |> ignore + x.Delete.Column("env").FromTable "backlog" |> ignore + x.Alter.Table("backlog") + .AddColumn("cmd").AsString().NotNullable() + .AddColumn("stdout").AsString().Nullable() + .AddColumn("stderr").AsString().Nullable() + .AddColumn("exit_code").AsCustom("smallint").NotNullable() + |> ignore + diff --git a/src/Datatypes.fs b/src/Datatypes.fs new file mode 100644 index 0000000..5ff70b1 --- /dev/null +++ b/src/Datatypes.fs @@ -0,0 +1,28 @@ +module Bidello.Datatypes + +open Orleans +open NodaTime + +open Pentole.Path + +[] +type Notification = | Time | Database + +[] +type PatternType = | Hourly | Daily | Weekly | Monthly | After of string | Before of string + +[] +type WhenExpr = | Cron of Instant | Pattern of PatternType + +[] +[] +type CronJob = { + job_name: string + user: string + when_: WhenExpr + executable: Path + args: string list + environment: (string * string) list + workdir: Path + hostname: string +} diff --git a/src/Environment.fs b/src/Environment.fs new file mode 100644 index 0000000..a8fbd02 --- /dev/null +++ b/src/Environment.fs @@ -0,0 +1,31 @@ +module Bidello.Environment +open CommandLine + +type Environment = { + pg_user: string + pg_password: string + pg_dbname: string + pg_host: string +} +let mutable private _env: Environment option = None + +let Environment () = + match _env with + | None -> invalidOp "Configuration not initialized" + | Some c -> c + + +type options = { + [] user: string + [] pass: string + [] host: string + [] dbname: string option +} + +let parse_cli (parsed: Parsed) = + let env = + { pg_user = parsed.Value.user; + pg_password = parsed.Value.pass + pg_host = parsed.Value.host + pg_dbname = parsed.Value.dbname |> Option.defaultValue "bidello" } + _env <- Some env diff --git a/src/Grains.fs b/src/Grains.fs new file mode 100644 index 0000000..cfd42b3 --- /dev/null +++ b/src/Grains.fs @@ -0,0 +1,22 @@ +module Bidello.Grains + +open Orleans +open System.Collections.Concurrent +open System.Threading +open System.Threading.Tasks + +open Bidello.Datatypes + + +type IShellGrain = + inherit IGrainWithIntegerKey + abstract schedule: CancellationToken -> CronJob -> Task + + +type ShellGrain() = + inherit Orleans.Grain () + + interface IShellGrain with + member _.schedule (ct) (job: CronJob) = task { + printfn "Grain view: %A" job + } diff --git a/src/Jobs.fs b/src/Jobs.fs new file mode 100644 index 0000000..86bc152 --- /dev/null +++ b/src/Jobs.fs @@ -0,0 +1,5 @@ +module Bidello.Jobs + +open Bidello.Datatypes + +open NodaTime diff --git a/src/Library.fs b/src/Library.fs new file mode 100644 index 0000000..5f7e70d --- /dev/null +++ b/src/Library.fs @@ -0,0 +1,127 @@ +module Bidello.Main + +open System.Threading +open System + +open NodaTime +open CommandLine +open Orleans +open Microsoft.Extensions.Hosting +open Microsoft.Extensions.DependencyInjection +open Serilog + +open Grains + +open Pentole + +open Bidello.Datatypes +open Bidello.Environment + +let logger_config: LoggingHelpers.Configuration = { + files = [] + template = LoggingHelpers.Default.debug_template + theme = LoggingHelpers.Default.theme + overrides = LoggingHelpers.Default.overrides +} + +let logger = LoggingHelpers.from_config logger_config + +(* Features: +- per user cron jobs +- environment variables +- output management (email, syslog) +- special time specs: @weekly +- randomized execution times +- conditional cron jobs: check something, then run +- concurrency management +- job dependency +- custom working directory +- backlog: MY_VAR='Hello' ANOTHER_VAR='World!!!' say_hello_world.sh + *) + +type Bidello(client: IClusterClient) = + inherit BackgroundService() + + override _this.ExecuteAsync(ct: CancellationToken) = + let rnd = new Random (2) + let db = Database.make logger + + let schedule_jobs (job: CronJob) = + let runner = rnd.Next () |> client.GetGrain + runner.schedule ct job |> ignore + + task { + while not ct.IsCancellationRequested do + + let hostname = System.Environment.MachineName + + let! requirements = + Database.gather_requirements hostname ct db + + let now = SystemClock.Instance.GetCurrentInstant () + + // let cronjobs = + // Cron.build_sorted_jobs_table logger hostname now requirements + + // cronjobs |> Seq.iter schedule_jobs + printfn "%A" requirements + + + let! _wake_up = db |> Database.wait_notification ct + () + } + +let private graceful() = + let x = ref true + + let swap () = + lock x (fun () -> + let old = x.Value + x.Value <- false + old) + + swap + +let graceful_shutdown (should_exit: unit -> bool) (host: IHost) (_sender: obj) (e: ConsoleCancelEventArgs) = + + if should_exit () then + e.Cancel <- true + logger.Warning "Requested SIGINT, shutting down cleanly. You can request an immediate shutdown now." + host.StopAsync () |> ignore + else + e.Cancel <- false + logger.Fatal "Exiting immediately" + System.Environment.Exit 2 + +let private main_ (host_builder: IHostBuilder) = + Database.run_migrations logger + + let host = + host_builder + .ConfigureServices(fun service -> + service.AddHostedService() |> ignore) + .UseSerilog(logger) + .Build() + + let g = graceful() + Console.CancelKeyPress.AddHandler (graceful_shutdown g host) + host.Run () + +let main (args: string array, host_builder: IHostBuilder) = + + let r = CommandLine.Parser.Default.ParseArguments args + + match r with + | :? Parsed as parsed -> + Bidello.Environment.parse_cli parsed + main_ host_builder + 0 + | :? NotParsed as _ -> 2 + | _ -> 1 + + + +(* Man page + - spiega cron expressions + - spiega due tavole: cron e hosts +*) diff --git a/src/LoggingHelpers.fs b/src/LoggingHelpers.fs new file mode 100644 index 0000000..fd2ab27 --- /dev/null +++ b/src/LoggingHelpers.fs @@ -0,0 +1,118 @@ +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 new file mode 100644 index 0000000..fb45750 --- /dev/null +++ b/src/Result.fs @@ -0,0 +1,25 @@ +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 () + + + type ToStringWrapper(toString) = + override this.ToString() = toString () + + let Result l = ToStringWrapper(fun _ -> + match l with + | Ok o -> sprintf "Ok %O" o + | _ -> failwith "") + diff --git a/src/String.fs b/src/String.fs new file mode 100644 index 0000000..924d4d0 --- /dev/null +++ b/src/String.fs @@ -0,0 +1,7 @@ +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 new file mode 100644 index 0000000..d0436bf --- /dev/null +++ b/src/src.fsproj @@ -0,0 +1,42 @@ + + + + net8.0 + true + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +