Initial commit

PureGym.App/ArgsCrate.fs

@@ -0,0 +1,21 @@
+namespace PureGym.App
+
+open System.Threading.Tasks
+open Argu
+
+type ArgsEvaluator<'ret> =
+    abstract Eval<'a, 'b when 'b :> IArgParserTemplate> :
+        (ParseResults<'b> -> Result<'a, ArguParseException>) -> ('a -> Task<int>) -> 'ret
+
+type ArgsCrate =
+    abstract Apply<'ret> : ArgsEvaluator<'ret> -> 'ret
+
+[<RequireQualifiedAccess>]
+module ArgsCrate =
+    let make<'a, 'b when 'b :> IArgParserTemplate>
+        (ofResult : ParseResults<'b> -> Result<'a, ArguParseException>)
+        (run : 'a -> Task<int>)
+        =
+        { new ArgsCrate with
+            member _.Apply e = e.Eval ofResult run
+        }

PureGym.App/AuthArg.fs

@@ -0,0 +1,41 @@
+namespace PureGym.App
+
+open Argu
+open PureGym
+
+type AuthArg =
+    | [<Unique ; CustomAppSettings "PUREGYM_BEARER_TOKEN">] Bearer_Token of string
+    | [<Unique>] User_Email of string
+    | [<Unique>] Pin of string
+    | [<GatherUnrecognized>] Others of string
+
+    interface IArgParserTemplate with
+        member s.Usage =
+            match s with
+            | AuthArg.Bearer_Token _ -> "A bearer token for the PureGym API"
+            | AuthArg.User_Email _ -> "PureGym user's email address"
+            | AuthArg.Pin _ -> "Eight-digit PureGym user's PIN"
+            | AuthArg.Others _ -> "<specific args for command>"
+
+    static member Parse (args : ParseResults<AuthArg>) : Result<Auth * string[], ArguParseException> =
+        let unmatchedArgs = args.GetResults AuthArg.Others |> List.toArray
+
+        match
+            args.TryGetResult AuthArg.User_Email, args.TryGetResult AuthArg.Pin, args.TryGetResult AuthArg.Bearer_Token
+        with
+        | Some email, Some pin, _ ->
+            let auth =
+                Auth.User
+                    {
+                        Username = email
+                        Pin = pin
+                    }
+
+            Ok (auth, unmatchedArgs)
+        | Some _email, None, _ -> failwith "Supplied --user-email but no --pin; either both or neither are required."
+        | None, Some _pin, _ -> failwith "Supplied --pin but no --user-email; either both or neither are required."
+        | None, None, None ->
+            failwith "No creds given: expected at least one of `--bearer-token` or `--user-email --pin`"
+        | None, None, Some token ->
+            let auth = Auth.Token (AuthToken.ofBearerToken token)
+            Ok (auth, unmatchedArgs)

PureGym.App/Authenticate.fs

@@ -0,0 +1,40 @@
+namespace PureGym.App
+
+open Argu
+open System
+open PureGym
+
+type GetTokenArg =
+    | [<ExactlyOnce>] User_Email of string
+    | [<ExactlyOnce>] Pin of string
+
+    interface IArgParserTemplate with
+        member s.Usage =
+            match s with
+            | GetTokenArg.Pin _ -> "Eight-digit PureGym user's PIN"
+            | GetTokenArg.User_Email _ -> "PureGym user's email address"
+
+    static member Parse (args : ParseResults<GetTokenArg>) : Result<UsernamePin, ArguParseException> =
+        try
+            {
+                Username = args.GetResult GetTokenArg.User_Email
+                Pin = args.GetResult GetTokenArg.Pin
+            }
+            |> Ok
+        with :? ArguParseException as e ->
+            Error e
+
+[<RequireQualifiedAccess>]
+module Authenticate =
+
+    let run (creds : UsernamePin) =
+        task {
+            let! cred = AuthToken.get creds
+            Console.WriteLine cred.AccessToken
+
+            match cred.ExpiryTime with
+            | None -> ()
+            | Some expiry -> Console.Error.WriteLine $"Expires at {expiry}"
+
+            return 0
+        }

PureGym.App/Exception.fs

@@ -0,0 +1,11 @@
+namespace PureGym.App
+
+open System.Runtime.ExceptionServices
+
+[<RequireQualifiedAccess>]
+module Exception =
+
+    let reraiseWithOriginalStackTrace<'a> (e : exn) : 'a =
+        let edi = ExceptionDispatchInfo.Capture e
+        edi.Throw ()
+        failwith "unreachable"

PureGym.App/Fullness.fs

@@ -0,0 +1,61 @@
+namespace PureGym.App
+
+open Argu
+open PureGym
+
+type FullnessArgsFragment =
+    | [<Unique>] Gym_Id of int
+    | [<Unique>] Gym_Name of string
+    | [<Unique>] Terse of bool
+
+    interface IArgParserTemplate with
+        member s.Usage =
+            match s with
+            | FullnessArgsFragment.Gym_Id _ -> "ID of the gym to look up, according to PureGym's internal mapping"
+            | FullnessArgsFragment.Gym_Name _ -> "Name of a gym (best-guess fuzzy matching)"
+            | FullnessArgsFragment.Terse _ -> "If true, output only the single number 'how many people are in the gym'."
+
+type FullnessArgs =
+    {
+        Creds : Auth
+        Gym : GymSelector
+        Terse : bool
+    }
+
+    static member Parse
+        (auth : Auth)
+        (args : FullnessArgsFragment ParseResults)
+        : Result<FullnessArgs, ArguParseException>
+        =
+        let gym =
+            match args.TryGetResult FullnessArgsFragment.Gym_Id, args.TryGetResult FullnessArgsFragment.Gym_Name with
+            | Some _, Some _ -> failwith "--gym-id and --gym-name are mutually exclusive"
+            | None, None ->
+                System.Console.Error.WriteLine "No gym ID given and no gym named; assuming the user's home gym"
+                GymSelector.Home
+            | Some id, None -> GymSelector.Id id
+            | None, Some name -> GymSelector.Name name
+
+        {
+            Creds = auth
+            Gym = gym
+            Terse = args.TryGetResult FullnessArgsFragment.Terse |> Option.defaultValue false
+        }
+        |> Ok
+
+[<RequireQualifiedAccess>]
+module Fullness =
+
+    let run (args : FullnessArgs) =
+        task {
+            let! client = Api.make args.Creds
+            let! id = GymSelector.canonicalId client args.Gym
+            let! attendance = client.GetGymAttendance id
+
+            if args.Terse then
+                System.Console.WriteLine attendance.TotalPeopleInGym
+            else
+                System.Console.WriteLine (string<GymAttendance> attendance)
+
+            return 0
+        }

PureGym.App/LookupGym.fs

@@ -0,0 +1,51 @@
+namespace PureGym.App
+
+open Argu
+open PureGym
+
+type LookupGymArgsFragment =
+    | [<Unique>] Gym_Id of int
+    | [<Unique>] Gym_Name of string
+
+    interface IArgParserTemplate with
+        member s.Usage =
+            match s with
+            | LookupGymArgsFragment.Gym_Id _ -> "ID of the gym to look up, according to PureGym's internal mapping"
+            | LookupGymArgsFragment.Gym_Name _ -> "Name of a gym (best-guess fuzzy matching)"
+
+type LookupGymArgs =
+    {
+        Creds : Auth
+        Gym : GymSelector
+    }
+
+    static member Parse
+        (auth : Auth)
+        (args : LookupGymArgsFragment ParseResults)
+        : Result<LookupGymArgs, ArguParseException>
+        =
+        let gym =
+            match args.TryGetResult LookupGymArgsFragment.Gym_Id, args.TryGetResult LookupGymArgsFragment.Gym_Name with
+            | Some _, Some _ -> failwith "--gym-id and --gym-name are mutually exclusive"
+            | None, None ->
+                System.Console.Error.WriteLine "No gym ID given and no gym named; assuming the user's home gym"
+                GymSelector.Home
+            | Some id, None -> GymSelector.Id id
+            | None, Some name -> GymSelector.Name name
+
+        {
+            Creds = auth
+            Gym = gym
+        }
+        |> Ok
+
+[<RequireQualifiedAccess>]
+module LookupGym =
+
+    let run (args : LookupGymArgs) =
+        task {
+            let! client = Api.make args.Creds
+            let! s = client.GetGym 19
+            System.Console.WriteLine (string<Gym> s)
+            return 0
+        }

PureGym.App/MemberActivity.fs

@@ -0,0 +1,38 @@
+namespace PureGym.App
+
+open Argu
+open PureGym
+
+type MemberActivityArgsFragment =
+    | MemberActivityArgsFragment of bool
+
+    interface IArgParserTemplate with
+        member s.Usage =
+            match s with
+            | MemberActivityArgsFragment _ -> "dummy argument: this subcommand has no args"
+
+type MemberActivityArgs =
+    {
+        Creds : Auth
+    }
+
+    static member Parse
+        (auth : Auth)
+        (_ : MemberActivityArgsFragment ParseResults)
+        : Result<MemberActivityArgs, ArguParseException>
+        =
+        {
+            Creds = auth
+        }
+        |> Ok
+
+[<RequireQualifiedAccess>]
+module MemberActivity =
+
+    let run (args : MemberActivityArgs) =
+        task {
+            let! client = Api.make args.Creds
+            let! activity = client.GetMemberActivity ()
+            System.Console.WriteLine (string<MemberActivity> activity)
+            return 0
+        }

PureGym.App/Program.fs

@@ -0,0 +1,118 @@
+namespace PureGym.App
+
+open System
+open Argu
+
+type Subcommand =
+    | RequiresAuth of (PureGym.Auth -> ArgsCrate)
+    | NoAuth of ArgsCrate
+
+module Program =
+    let subcommands =
+        [|
+            "auth", ("Get an authentication token", NoAuth (ArgsCrate.make GetTokenArg.Parse Authenticate.run))
+
+            "lookup-gym",
+            ("Get information about the physical instantiation of a gym",
+             RequiresAuth (fun auth -> ArgsCrate.make (LookupGymArgs.Parse auth) LookupGym.run))
+
+            "fullness",
+            ("Determine how full a gym is",
+             RequiresAuth (fun auth -> ArgsCrate.make (FullnessArgs.Parse auth) Fullness.run))
+
+            "activity",
+            ("Get information about your gym usage",
+             RequiresAuth (fun auth -> ArgsCrate.make (MemberActivityArgs.Parse auth) MemberActivity.run))
+        |]
+        |> Map.ofArray
+
+    [<EntryPoint>]
+    let main argv =
+        // It looks like Argu doesn't really support the combination of subcommands and read-from-env-vars, so we just
+        // roll our own.
+
+        match Array.tryHead argv with
+        | None
+        | Some "--help" ->
+            subcommands.Keys
+            |> String.concat ","
+            |> eprintfn "Subcommands (try each with `--help`): %s"
+
+            0
+
+        | Some commandName ->
+
+        match Map.tryFind commandName subcommands with
+        | None ->
+            subcommands.Keys
+            |> String.concat ","
+            |> eprintfn "Unrecognised command '%s'. Subcommands (try each with `--help`): %s" commandName
+
+            127
+
+        | Some (_help, command) ->
+
+        let argv = Array.tail argv
+        let config = ConfigurationReader.FromEnvironmentVariables ()
+
+        let argv, command =
+            match command with
+            | RequiresAuth command ->
+                let authParser = ArgumentParser.Create<AuthArg> ()
+
+                let extractedAuthParse, helpRequested =
+                    try
+                        authParser.Parse (argv, config, raiseOnUsage = true, ignoreUnrecognized = true), false
+                    with :? ArguParseException as e ->
+                        if e.Message.StartsWith ("USAGE:", StringComparison.OrdinalIgnoreCase) then
+                            authParser.Parse (argv, config, raiseOnUsage = false, ignoreUnrecognized = true), true
+                        else
+                            reraise ()
+
+                let authArgs, argv =
+                    if helpRequested then
+                        let subcommandArgs =
+                            ("--help" :: extractedAuthParse.GetResults AuthArg.Others) |> List.toArray
+
+                        Unchecked.defaultof<_>, subcommandArgs
+                    else
+                        match AuthArg.Parse extractedAuthParse with
+                        | Ok a -> a
+                        | Error e -> Exception.reraiseWithOriginalStackTrace e
+
+                argv, command authArgs
+            | NoAuth command -> argv, command
+
+        { new ArgsEvaluator<_> with
+            member _.Eval<'a, 'b when 'b :> IArgParserTemplate> (ofResult : ParseResults<'b> -> Result<'a, _>) run =
+                let parser = ArgumentParser.Create<'b> ()
+
+                let parsed =
+                    try
+                        parser.Parse (argv, config, raiseOnUsage = true) |> Ok
+                    with :? ArguParseException as e ->
+                        e.Message.Replace ("PureGym.App ", $"PureGym.App %s{commandName} ")
+                        |> Console.Error.WriteLine
+
+                        if e.Message.StartsWith ("USAGE:", StringComparison.OrdinalIgnoreCase) then
+                            Error true
+                        else
+                            Error false
+
+                match parsed with
+                | Error false -> Error 127
+                | Error true -> Error 0
+                | Ok parsed ->
+
+                match ofResult parsed with
+                | Error e ->
+                    e.Message.Replace ("PureGym.App ", $"PureGym.App %s{commandName} ")
+                    |> Console.Error.WriteLine
+
+                    Error 127
+                | Ok args ->
+
+                run args |> Ok
+        }
+        |> command.Apply
+        |> Result.cata (fun t -> t.Result) id

PureGym.App/PureGym.App.fsproj

@@ -0,0 +1,28 @@
+<Project Sdk="Microsoft.NET.Sdk">
+
+    <PropertyGroup>
+        <OutputType>Exe</OutputType>
+        <TargetFramework>net7.0</TargetFramework>
+    </PropertyGroup>
+
+    <ItemGroup>
+      <Compile Include="Result.fs" />
+      <Compile Include="Exception.fs" />
+      <Compile Include="ArgsCrate.fs" />
+      <Compile Include="AuthArg.fs" />
+      <Compile Include="Authenticate.fs" />
+      <Compile Include="Fullness.fs" />
+      <Compile Include="LookupGym.fs" />
+      <Compile Include="MemberActivity.fs" />
+      <Compile Include="Program.fs" />
+    </ItemGroup>
+
+    <ItemGroup>
+      <ProjectReference Include="..\PureGym\PureGym.fsproj" />
+    </ItemGroup>
+
+    <ItemGroup>
+      <PackageReference Include="Argu" Version="6.1.1" />
+    </ItemGroup>
+
+</Project>

PureGym.App/Result.fs

@@ -0,0 +1,9 @@
+namespace PureGym.App
+
+[<RequireQualifiedAccess>]
+module Result =
+
+    let cata<'ok, 'err, 'result> onOk onError (r : Result<'ok, 'err>) : 'result =
+        match r with
+        | Ok ok -> onOk ok
+        | Error e -> onError e