------------------------------------------------------------------------------
-- Copyright (c) 2013, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

package body Natools.String_Slices is

   use type String_Refs.Reference;

   -----------------------------
   -- String_Range primitives --
   -----------------------------

   function Is_In (Point : Natural; Reference : String_Range) return Boolean is
   begin
      return Point >= Reference.First
        and Point < Reference.First + Reference.Length;
   end Is_In;

   function Is_Subrange (Sample, Reference : String_Range) return Boolean is
   begin
      return Sample.First >= Reference.First
        and then Sample.First + Sample.Length
                   <= Reference.First + Reference.Length;
   end Is_Subrange;

   function Last (Self : String_Range) return Natural is
   begin
      return Self.First + Self.Length - 1;
   end Last;

   function To_Range (First : Positive; Last : Natural) return String_Range is
   begin
      if Last >= First then
         return (First => First, Length => Last - First + 1);
      else
         return (First => First, Length => 0);
      end if;
   end To_Range;

   function Get_Range (S : String) return String_Range is
   begin
      return (S'First, S'Length);
   end Get_Range;

   procedure Set_First (Self : in out String_Range; New_First : in Positive) is
   begin
      if New_First >= Self.First + Self.Length then
         Self.Length := 0;
      else
         Self.Length := Self.Length - (New_First - Self.First);
      end if;

      Self.First := New_First;
   end Set_First;

   procedure Set_Last (Self : in out String_Range; New_Last : in Natural) is
   begin
      if New_Last < Self.First then
         Self.Length := 0;
      else
         Self.Length := New_Last - Self.First + 1;
      end if;
   end Set_Last;

   procedure Set_Length
     (Self : in out String_Range; New_Length : in Natural) is
   begin
      Self.Length := New_Length;
   end Set_Length;

   function Image (Interval : String_Range) return String is
      First_Img : String := Integer'Image (Interval.First);
   begin
      pragma Assert (First_Img (First_Img'First) = ' ');

      if Interval.Length = 0 then
         return "empty at" & First_Img;
      end if;

      First_Img (First_Img'First) := '[';

      if Interval.Length = 1 then
         return First_Img & ']';
      else
         return First_Img
           & ','
           & Integer'Image (Last (Interval))
           & ']';
      end if;
   end Image;

   --------------------------
   -- Conversion functions --
   --------------------------

   function To_Slice (S : String) return Slice is
      function Create return String;

      function Create return String is
      begin
         return S;
      end Create;
   begin
      return Slice'(Bounds => (S'First, S'Length),
                    Ref    => String_Refs.Create (Create'Access));
   end To_Slice;

   function To_String (S : Slice) return String is
   begin
      if S.Ref.Is_Empty then
         return "";
      else
         return S.Ref.Query.Data.all (S.Bounds.First .. Last (S.Bounds));
      end if;
   end To_String;

   ---------------
   -- Accessors --
   ---------------

   procedure Export (S : in Slice; Output : out String) is
   begin
      if not S.Ref.Is_Empty then
         Output := S.Ref.Query.Data.all (S.Bounds.First .. Last (S.Bounds));
      end if;
   end Export;

   procedure Query
     (S : in Slice;
      Process : not null access procedure (Text : in String)) is
   begin
      if S.Bounds.Length = 0 or else S.Ref.Is_Empty then
         Process.all ("");
      else
         Process.all
           (S.Ref.Query.Data.all (S.Bounds.First .. Last (S.Bounds)));
      end if;
   end Query;

   function Get_Range (S : Slice) return String_Range is
   begin
      return S.Bounds;
   end Get_Range;

   function First (S : Slice) return Positive is
   begin
      return S.Bounds.First;
   end First;

   function Last (S : Slice) return Natural is
   begin
      return Last (S.Bounds);
   end Last;

   function Length (S : Slice) return Natural is
   begin
      return S.Bounds.Length;
   end Length;

   ---------------
   -- Extenders --
   ---------------

   function Parent (S : Slice) return Slice is
   begin
      if S.Ref.Is_Empty then
         return Slice'(others => <>);
      else
         return Slice'(Bounds => Get_Range (S.Ref.Query.Data.all),
                       Ref    => S.Ref);
      end if;
   end Parent;

   function Extend (S : Slice; New_Range : in String_Range) return Slice is
   begin
      if not Is_Subrange (New_Range, Get_Range (S.Ref.Query.Data.all)) then
         raise Constraint_Error with "Extend slice beyond complete range";
      end if;

      return Slice'(Bounds => New_Range,
                    Ref    => S.Ref);
   end Extend;

   function Extend (S : Slice; First : Positive; Last : Natural)
     return Slice is
   begin
      return Extend (S, To_Range (First, Last));
   end Extend;

   procedure Extend (S : in out Slice; New_Range : in String_Range) is
   begin
      if not Is_Subrange (New_Range, Get_Range (S.Ref.Query.Data.all)) then
         raise Constraint_Error with "Extend slice beyond complete range";
      end if;

      S.Bounds := New_Range;
   end Extend;

   procedure Extend
     (S : in out Slice; First : in Positive; Last : in Natural) is
   begin
      Extend (S, To_Range (First, Last));
   end Extend;

   -----------------
   -- Restrictors --
   -----------------

   function Subslice (S : Slice; New_Range : String_Range) return Slice is
   begin
      if S.Ref.Is_Empty then
         if New_Range.Length = 0 then
            return Slice'(Bounds => New_Range, Ref => <>);
         else
            raise Constraint_Error with "Subslice of null slice";
         end if;
      end if;

      if not Is_Subrange (New_Range, S.Bounds) then
         raise Constraint_Error with "Subslice out of parent range";
      end if;

      return Slice'(Bounds => New_Range,
                    Ref    => S.Ref);
   end Subslice;

   function Subslice (S : Slice; First : Positive; Last : Natural)
     return Slice is
   begin
      return Subslice (S, To_Range (First, Last));
   end Subslice;

   procedure Restrict (S : in out Slice; New_Range : in String_Range) is
   begin
      if S.Ref.Is_Empty and New_Range.Length /= 0 then
         raise Constraint_Error with "Restrict of null slice";
      end if;

      if not Is_Subrange (New_Range, S.Bounds) then
         raise Constraint_Error with "Restriction with not a subrange";
      end if;

      S.Bounds := New_Range;
   end Restrict;

   procedure Restrict
     (S : in out Slice; First : in Positive; Last : in Natural) is
   begin
      Restrict (S, To_Range (First, Last));
   end Restrict;

   procedure Set_First (S : in out Slice; New_First : in Positive) is
   begin
      if New_First < S.Bounds.First then
         raise Constraint_Error with "New_First out of slice range";
      end if;

      Set_First (S.Bounds, New_First);
   end Set_First;

   procedure Set_Last (S : in out Slice; New_Last : in Natural) is
   begin
      if New_Last > Last (S.Bounds) then
         raise Constraint_Error with "New_Last out of slice range";
      end if;

      Set_Last (S.Bounds, New_Last);
   end Set_Last;

   procedure Set_Length (S : in out Slice; New_Length : in Natural) is
   begin
      if New_Length > S.Bounds.Length then
         raise Constraint_Error with "New_Length out of slice range";
      end if;

      S.Bounds.Length := New_Length;
   end Set_Length;

   ----------------------
   -- Slice comparison --
   ----------------------

   function Is_Empty (S : Slice) return Boolean is
   begin
      return S.Bounds.Length = 0 or else S.Ref.Is_Empty;
   end Is_Empty;

   function Is_Null (S : Slice) return Boolean is
   begin
      return S.Ref.Is_Empty;
   end Is_Null;

   function Is_Related (Left, Right : Slice) return Boolean is
   begin
      return Left.Ref = Right.Ref;
   end Is_Related;

   function Is_Subslice (S, Reference : Slice) return Boolean is
   begin
      return S.Ref = Reference.Ref
        and then Is_Subrange (S.Bounds, Reference.Bounds);
   end Is_Subslice;

   ------------------
   -- Constructors --
   ------------------

   function Duplicate (S : Slice) return Slice is
      function Factory return String;

      function Factory return String is
      begin
         return S.Ref.Query.Data.all;
      end Factory;
   begin
      if S.Bounds.Length = 0 or else S.Ref.Is_Empty then
         return Null_Slice;
      else
         return Slice'(Bounds => S.Bounds,
                       Ref => String_Refs.Create (Factory'Access));
      end if;
   end Duplicate;

end Natools.String_Slices;

------------------------------------------------------------------------------
-- Copyright (c) 2013, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

package body Natools.String_Slices is

   use type String_Refs.Reference;

   -----------------------------
   -- String_Range primitives --
   -----------------------------

   function Is_In (Point : Natural; Reference : String_Range) return Boolean is
   begin
      return Point >= Reference.First
        and Point < Reference.First + Reference.Length;
   end Is_In;

   function Is_Subrange (Sample, Reference : String_Range) return Boolean is
   begin
      return Sample.Length = 0
        or else (Sample.First >= Reference.First
                 and then Sample.First + Sample.Length
                            <= Reference.First + Reference.Length);
   end Is_Subrange;

   function Last (Self : String_Range) return Natural is
   begin
      return Self.First + Self.Length - 1;
   end Last;

   function To_Range (First : Positive; Last : Natural) return String_Range is
   begin
      if Last >= First then
         return (First => First, Length => Last - First + 1);
      else
         return (First => First, Length => 0);
      end if;
   end To_Range;

   function Get_Range (S : String) return String_Range is
   begin
      return (S'First, S'Length);
   end Get_Range;

   procedure Set_First (Self : in out String_Range; New_First : in Positive) is
   begin
      if New_First >= Self.First + Self.Length then
         Self.Length := 0;
      else
         Self.Length := Self.Length - (New_First - Self.First);
      end if;

      Self.First := New_First;
   end Set_First;

   procedure Set_Last (Self : in out String_Range; New_Last : in Natural) is
   begin
      if New_Last < Self.First then
         Self.Length := 0;
      else
         Self.Length := New_Last - Self.First + 1;
      end if;
   end Set_Last;

   procedure Set_Length
     (Self : in out String_Range; New_Length : in Natural) is
   begin
      Self.Length := New_Length;
   end Set_Length;

   function Image (Interval : String_Range) return String is
      First_Img : String := Integer'Image (Interval.First);
   begin
      pragma Assert (First_Img (First_Img'First) = ' ');

      if Interval.Length = 0 then
         return "empty at" & First_Img;
      end if;

      First_Img (First_Img'First) := '[';

      if Interval.Length = 1 then
         return First_Img & ']';
      else
         return First_Img
           & ','
           & Integer'Image (Last (Interval))
           & ']';
      end if;
   end Image;

   --------------------------
   -- Conversion functions --
   --------------------------

   function To_Slice (S : String) return Slice is
      function Create return String;

      function Create return String is
      begin
         return S;
      end Create;
   begin
      return Slice'(Bounds => (S'First, S'Length),
                    Ref    => String_Refs.Create (Create'Access));
   end To_Slice;

   function To_String (S : Slice) return String is
   begin
      if S.Ref.Is_Empty then
         return "";
      else
         return S.Ref.Query.Data.all (S.Bounds.First .. Last (S.Bounds));
      end if;
   end To_String;

   ---------------
   -- Accessors --
   ---------------

   procedure Export (S : in Slice; Output : out String) is
   begin
      if not S.Ref.Is_Empty then
         Output := S.Ref.Query.Data.all (S.Bounds.First .. Last (S.Bounds));
      end if;
   end Export;

   procedure Query
     (S : in Slice;
      Process : not null access procedure (Text : in String)) is
   begin
      if S.Bounds.Length = 0 or else S.Ref.Is_Empty then
         Process.all ("");
      else
         Process.all
           (S.Ref.Query.Data.all (S.Bounds.First .. Last (S.Bounds)));
      end if;
   end Query;

   function Get_Range (S : Slice) return String_Range is
   begin
      return S.Bounds;
   end Get_Range;

   function First (S : Slice) return Positive is
   begin
      return S.Bounds.First;
   end First;

   function Last (S : Slice) return Natural is
   begin
      return Last (S.Bounds);
   end Last;

   function Length (S : Slice) return Natural is
   begin
      return S.Bounds.Length;
   end Length;

   ---------------
   -- Extenders --
   ---------------

   function Parent (S : Slice) return Slice is
   begin
      if S.Ref.Is_Empty then
         return Slice'(others => <>);
      else
         return Slice'(Bounds => Get_Range (S.Ref.Query.Data.all),
                       Ref    => S.Ref);
      end if;
   end Parent;

   function Extend (S : Slice; New_Range : in String_Range) return Slice is
   begin
      if not Is_Subrange (New_Range, Get_Range (S.Ref.Query.Data.all)) then
         raise Constraint_Error with "Extend slice beyond complete range";
      end if;

      return Slice'(Bounds => New_Range,
                    Ref    => S.Ref);
   end Extend;

   function Extend (S : Slice; First : Positive; Last : Natural)
     return Slice is
   begin
      return Extend (S, To_Range (First, Last));
   end Extend;

   procedure Extend (S : in out Slice; New_Range : in String_Range) is
   begin
      if not Is_Subrange (New_Range, Get_Range (S.Ref.Query.Data.all)) then
         raise Constraint_Error with "Extend slice beyond complete range";
      end if;

      S.Bounds := New_Range;
   end Extend;

   procedure Extend
     (S : in out Slice; First : in Positive; Last : in Natural) is
   begin
      Extend (S, To_Range (First, Last));
   end Extend;

   -----------------
   -- Restrictors --
   -----------------

   function Subslice (S : Slice; New_Range : String_Range) return Slice is
   begin
      if S.Ref.Is_Empty then
         if New_Range.Length = 0 then
            return Slice'(Bounds => New_Range, Ref => <>);
         else
            raise Constraint_Error with "Subslice of null slice";
         end if;
      end if;

      if not Is_Subrange (New_Range, S.Bounds) then
         raise Constraint_Error with "Subslice out of parent range";
      end if;

      return Slice'(Bounds => New_Range,
                    Ref    => S.Ref);
   end Subslice;

   function Subslice (S : Slice; First : Positive; Last : Natural)
     return Slice is
   begin
      return Subslice (S, To_Range (First, Last));
   end Subslice;

   procedure Restrict (S : in out Slice; New_Range : in String_Range) is
   begin
      if S.Ref.Is_Empty and New_Range.Length /= 0 then
         raise Constraint_Error with "Restrict of null slice";
      end if;

      if not Is_Subrange (New_Range, S.Bounds) then
         raise Constraint_Error with "Restriction with not a subrange";
      end if;

      S.Bounds := New_Range;
   end Restrict;

   procedure Restrict
     (S : in out Slice; First : in Positive; Last : in Natural) is
   begin
      Restrict (S, To_Range (First, Last));
   end Restrict;

   procedure Set_First (S : in out Slice; New_First : in Positive) is
   begin
      if New_First < S.Bounds.First then
         raise Constraint_Error with "New_First out of slice range";
      end if;

      Set_First (S.Bounds, New_First);
   end Set_First;

   procedure Set_Last (S : in out Slice; New_Last : in Natural) is
   begin
      if New_Last > Last (S.Bounds) then
         raise Constraint_Error with "New_Last out of slice range";
      end if;

      Set_Last (S.Bounds, New_Last);
   end Set_Last;

   procedure Set_Length (S : in out Slice; New_Length : in Natural) is
   begin
      if New_Length > S.Bounds.Length then
         raise Constraint_Error with "New_Length out of slice range";
      end if;

      S.Bounds.Length := New_Length;
   end Set_Length;

   ----------------------
   -- Slice comparison --
   ----------------------

   function Is_Empty (S : Slice) return Boolean is
   begin
      return S.Bounds.Length = 0 or else S.Ref.Is_Empty;
   end Is_Empty;

   function Is_Null (S : Slice) return Boolean is
   begin
      return S.Ref.Is_Empty;
   end Is_Null;

   function Is_Related (Left, Right : Slice) return Boolean is
   begin
      return Left.Ref = Right.Ref;
   end Is_Related;

   function Is_Subslice (S, Reference : Slice) return Boolean is
   begin
      return S.Ref = Reference.Ref
        and then Is_Subrange (S.Bounds, Reference.Bounds);
   end Is_Subslice;

   ------------------
   -- Constructors --
   ------------------

   function Duplicate (S : Slice) return Slice is
      function Factory return String;

      function Factory return String is
      begin
         return S.Ref.Query.Data.all;
      end Factory;
   begin
      if S.Bounds.Length = 0 or else S.Ref.Is_Empty then
         return Null_Slice;
      else
         return Slice'(Bounds => S.Bounds,
                       Ref => String_Refs.Create (Factory'Access));
      end if;
   end Duplicate;

end Natools.String_Slices;

string_slices: fix Is_Subrange so that any empty range is a subrange of any range


-----------------------------------------------------------------------
--  druss-commands-devices -- Print information about the devices
--  Copyright (C) 2017, 2018, 2019 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Properties;
with Bbox.API;
with Druss.Gateways;
package body Druss.Commands.Devices is

   --  ------------------------------
   --  Execute the wifi 'status' command to print the Wifi current status.
   --  ------------------------------
   procedure Do_List (Command   : in Command_Type;
                      Args      : in Argument_List'Class;
                      Selector  : in Device_Selector_Type;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Command, Args);
      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type);

      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;

      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type) is
         procedure Print_Device (Manager : in Util.Properties.Manager;
                                 Name    : in String);

         procedure Print_Device (Manager : in Util.Properties.Manager;
                                 Name    : in String) is
            Link : constant String := Manager.Get (Name & ".link", "");
            Kind : constant String := Manager.Get (Name & ".devicetype", "");
         begin
            case Selector is
               when DEVICE_ALL =>
                  null;

               when DEVICE_ACTIVE =>
                  if Manager.Get (Name & ".active", "") = "0" then
                     return;
                  end if;

               when DEVICE_INACTIVE =>
                  if Manager.Get (Name & ".active", "") = "1" then
                     return;
                  end if;

            end case;

            Console.Start_Row;
            Console.Print_Field (F_BBOX_IP_ADDR, Gateway.Ip);
            Console.Print_Field (F_IP_ADDR, Manager.Get (Name & ".ipaddress", ""));
            Console.Print_Field (F_ETHERNET, Manager.Get (Name & ".macaddress", ""));
            Console.Print_Field (F_HOSTNAME, Manager.Get (Name & ".hostname", ""));
            Console.Print_Field (F_ACTIVE, Manager.Get (Name & ".active", ""));
            Console.Print_Field (F_DEVTYPE, (if Kind = "STB" then "STB" else ""));
            if Link = "Ethernet" then
               Console.Print_Field (F_LINK, Link & " port "
                                    & Manager.Get (Name & ".ethernet.logicalport", ""));
            else
               Console.Print_Field (F_LINK, Link & " RSSI "
                                    & Manager.Get (Name & ".wireless.rssi0", ""));
            end if;
            Console.End_Row;
         end Print_Device;

      begin
         Gateway.Refresh;

         Bbox.API.Iterate (Gateway.Hosts, "hosts.list", Print_Device'Access);
      end Box_Status;

   begin
      Console.Start_Title;
      Console.Print_Title (F_BBOX_IP_ADDR, "Bbox IP", 16);
      Console.Print_Title (F_IP_ADDR, "Device IP", 16);
      Console.Print_Title (F_ETHERNET, "Ethernet", 20);
      Console.Print_Title (F_HOSTNAME, "Hostname", 28);
      Console.Print_Title (F_DEVTYPE, "Type", 6);
      --  Console.Print_Title (F_ACTIVE, "Active", 8);
      Console.Print_Title (F_LINK, "Link", 18);
      Console.End_Title;
      Druss.Gateways.Iterate (Context.Gateways, Gateways.ITER_ENABLE, Box_Status'Access);
   end Do_List;

   --  ------------------------------
   --  Execute a status command to report information about the Bbox.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in out Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Name);
   begin
      if Args.Get_Count > 1 then
         Context.Console.Notice (N_USAGE, "Too many arguments to the command");
         Druss.Commands.Driver.Usage (Args, Context);
      elsif Args.Get_Count = 0 then
         Command.Do_List (Args, DEVICE_ACTIVE, Context);
      elsif Args.Get_Argument (1) = "all" then
         Command.Do_List (Args, DEVICE_ALL, Context);
      elsif Args.Get_Argument (1) = "active" then
         Command.Do_List (Args, DEVICE_ACTIVE, Context);
      elsif Args.Get_Argument (1) = "inactive" then
         Command.Do_List (Args, DEVICE_INACTIVE, Context);
      else
         Context.Console.Notice (N_USAGE, "Invalid argument: " & Args.Get_Argument (1));
         Druss.Commands.Driver.Usage (Args, Context);
      end if;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in out Command_Type;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command);
      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;
   begin
      Console.Notice (N_HELP, "devices: Print information about the devices");
      Console.Notice (N_HELP, "Usage: devices [all | active | inactive]");
      Console.Notice (N_HELP, "");
      Console.Notice (N_HELP, "  List the devices that are known by the Bbox.");
      Console.Notice (N_HELP, "");
      Console.Notice (N_HELP, "    all        List all the devices");
      Console.Notice (N_HELP, "    active     List the active devices (the default)");
      Console.Notice (N_HELP, "    inative    List the inactive devices");
   end Help;

end Druss.Commands.Devices;

-----------------------------------------------------------------------
--  druss-commands-devices -- Print information about the devices
--  Copyright (C) 2017, 2018, 2019 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Properties;
with Bbox.API;
with Druss.Gateways;
package body Druss.Commands.Devices is

   --  ------------------------------
   --  Execute the wifi 'status' command to print the Wifi current status.
   --  ------------------------------
   procedure Do_List (Command   : in Command_Type;
                      Args      : in Argument_List'Class;
                      Selector  : in Device_Selector_Type;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Command, Args);
      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type);

      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;

      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type) is
         procedure Print_Device (Manager : in Util.Properties.Manager;
                                 Name    : in String);

         procedure Print_Device (Manager : in Util.Properties.Manager;
                                 Name    : in String) is
            Link : constant String := Manager.Get (Name & ".link", "");
            Kind : constant String := Manager.Get (Name & ".devicetype", "");
         begin
            case Selector is
               when DEVICE_ALL =>
                  null;

               when DEVICE_ACTIVE =>
                  if Manager.Get (Name & ".active", "") = "0" then
                     return;
                  end if;

               when DEVICE_INACTIVE =>
                  if Manager.Get (Name & ".active", "") = "1" then
                     return;
                  end if;

            end case;

            Console.Start_Row;
            Console.Print_Field (F_BBOX_IP_ADDR, Gateway.Ip);
            Console.Print_Field (F_IP_ADDR, Manager.Get (Name & ".ipaddress", ""));
            Console.Print_Field (F_ETHERNET, Manager.Get (Name & ".macaddress", ""));
            Console.Print_Field (F_HOSTNAME, Manager.Get (Name & ".hostname", ""));
            --  Console.Print_Field (F_ACTIVE, Manager.Get (Name & ".active", ""));
            Console.Print_Field (F_DEVTYPE, (if Kind = "STB" then "STB" else ""));
            if Link = "Ethernet" then
               Console.Print_Field (F_LINK, Link & " port "
                                    & Manager.Get (Name & ".ethernet.logicalport", ""));
            else
               Console.Print_Field (F_LINK, Link & " RSSI "
                                    & Manager.Get (Name & ".wireless.rssi0", ""));
            end if;
            Console.End_Row;
         end Print_Device;

      begin
         Gateway.Refresh;

         Bbox.API.Iterate (Gateway.Hosts, "hosts.list", Print_Device'Access);
      end Box_Status;

   begin
      Console.Start_Title;
      Console.Print_Title (F_BBOX_IP_ADDR, "Bbox IP", 16);
      Console.Print_Title (F_IP_ADDR, "Device IP", 16);
      Console.Print_Title (F_ETHERNET, "Ethernet", 20);
      Console.Print_Title (F_HOSTNAME, "Hostname", 28);
      Console.Print_Title (F_DEVTYPE, "Type", 6);
      --  Console.Print_Title (F_ACTIVE, "Active", 8);
      Console.Print_Title (F_LINK, "Link", 18);
      Console.End_Title;
      Druss.Gateways.Iterate (Context.Gateways, Gateways.ITER_ENABLE, Box_Status'Access);
   end Do_List;

   --  ------------------------------
   --  Execute a status command to report information about the Bbox.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in out Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Name);
   begin
      if Args.Get_Count > 1 then
         Context.Console.Notice (N_USAGE, "Too many arguments to the command");
         Druss.Commands.Driver.Usage (Args, Context);
      elsif Args.Get_Count = 0 then
         Command.Do_List (Args, DEVICE_ACTIVE, Context);
      elsif Args.Get_Argument (1) = "all" then
         Command.Do_List (Args, DEVICE_ALL, Context);
      elsif Args.Get_Argument (1) = "active" then
         Command.Do_List (Args, DEVICE_ACTIVE, Context);
      elsif Args.Get_Argument (1) = "inactive" then
         Command.Do_List (Args, DEVICE_INACTIVE, Context);
      else
         Context.Console.Notice (N_USAGE, "Invalid argument: " & Args.Get_Argument (1));
         Druss.Commands.Driver.Usage (Args, Context);
      end if;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in out Command_Type;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command);
      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;
   begin
      Console.Notice (N_HELP, "devices: Print information about the devices");
      Console.Notice (N_HELP, "Usage: devices [all | active | inactive]");
      Console.Notice (N_HELP, "");
      Console.Notice (N_HELP, "  List the devices that are known by the Bbox.");
      Console.Notice (N_HELP, "");
      Console.Notice (N_HELP, "    all        List all the devices");
      Console.Notice (N_HELP, "    active     List the active devices (the default)");
      Console.Notice (N_HELP, "    inative    List the inactive devices");
   end Help;

end Druss.Commands.Devices;

Fix presentation of list of devices

Fix presentation of list of devices


-----------------------------------------------------------------------
--  security -- Security
--  Copyright (C) 2010, 2011, 2012, 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

--  == Introduction ==
--  The <tt>Security</tt> package provides a security framework that allows
--  an application to use OpenID or OAuth security frameworks.  This security
--  framework was first developed within the Ada Server Faces project.
--  This package defines abstractions that are close or similar to Java
--  security package.
--
--  The security framework uses the following abstractions:
--
--  === Policy and policy manager ===
--  The <tt>Policy</tt> defines and implements the set of security rules that specify how to
--  protect the system or resources.  The <tt>Policy_Manager</tt> maintains the security policies.
--
--  === Principal ===
--  The <tt>Principal</tt> is the entity that can be authenticated.  A principal is obtained
--  after successful authentication of a user or of a system through an authorization process.
--  The OpenID or OAuth authentication processes generate such security principal.
--
--  === Permission ===
--  The <tt>Permission</tt> represents an access to a system or application resource.
--  A permission is checked by using the security policy manager.  The policy manager uses a
--  security controller to enforce the permission.
--
--  === Security Context ===
--  The <tt>Security_Context</tt> holds the contextual information that the security controller
--  can use to verify the permission.  The security context is associated with a principal and
--  a set of policy context.
--
--  == Overview ==
--  An application will create a security policy manager and register one or several security
--  policies (yellow).  The framework defines a simple role based security policy and an URL
--  security policy intended to provide security in web applications.  The security policy manager
--  reads some security policy configuration file which allows the security policies to configure
--  and create the security controllers.  These controllers will enforce the security according
--  to the application security rules.  All these components are built only once when
--  an application starts.
--
--  A user is authenticated through an authentication system which creates a <tt>Principal</tt>
--  instance that identifies the user (green).  The security framework provides two authentication
--  systems: OpenID and OAuth.
--
--  [images/ModelOverview.png]
--
--  When a permission must be enforced, a security context is created and linked to the
--  <tt>Principal</tt> instance (blue).  Additional security policy context can be added depending
--  on the application context.  To check the permission, the security policy manager is called
--  and it will ask a security controller to verify the permission.
--
--  The framework allows an application to plug its own security policy, its own policy context,
--  its own principal and authentication mechanism.
--
--  @include security-permissions.ads
--
--  == Principal ==
--  A principal is created by using either the [Security_Auth OpenID],
--  the [Security_OAuth OAuth] or another authentication mechanism.  The authentication produces
--  an object that must implement the <tt>Principal</tt> interface.  For example:
--
--    P : Security.Auth.Principal_Access := Security.Auth.Create_Principal (Auth);
--
--  or
--
--    P : Security.OAuth.Clients.Access_Token_Access := Security.OAuth.Clients.Create_Access_Token
--
--  The principal is then stored in a security context.
--
--  @include security-contexts.ads
--
--  [Security_Policies Security Policies]
--  [Security_Auth OpenID]
--  [Security_OAuth OAuth]
--
package Security is

   pragma Preelaborate;

   --  ------------------------------
   --  Principal
   --  ------------------------------
   type Principal is limited interface;
   type Principal_Access is access all Principal'Class;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String is abstract;

end Security;

-----------------------------------------------------------------------
--  security -- Security
--  Copyright (C) 2010, 2011, 2012, 2015, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

--  == Introduction ==
--  The <tt>Security</tt> package provides a security framework that allows
--  an application to use OpenID or OAuth security frameworks.  This security
--  framework was first developed within the Ada Server Faces project.
--  It was moved to a separate project so that it can easyly be used with AWS.
--  This package defines abstractions that are close or similar to Java
--  security package.
--
--  The security framework uses the following abstractions:
--
--  === Policy and policy manager ===
--  The <tt>Policy</tt> defines and implements the set of security rules that specify how to
--  protect the system or resources.  The <tt>Policy_Manager</tt> maintains the security policies.
--
--  === Principal ===
--  The <tt>Principal</tt> is the entity that can be authenticated.  A principal is obtained
--  after successful authentication of a user or of a system through an authorization process.
--  The OpenID or OAuth authentication processes generate such security principal.
--
--  === Permission ===
--  The <tt>Permission</tt> represents an access to a system or application resource.
--  A permission is checked by using the security policy manager.  The policy manager uses a
--  security controller to enforce the permission.
--
--  === Security Context ===
--  The <tt>Security_Context</tt> holds the contextual information that the security controller
--  can use to verify the permission.  The security context is associated with a principal and
--  a set of policy context.
--
--  == Overview ==
--  An application will create a security policy manager and register one or several security
--  policies (yellow).  The framework defines a simple role based security policy and an URL
--  security policy intended to provide security in web applications.  The security policy manager
--  reads some security policy configuration file which allows the security policies to configure
--  and create the security controllers.  These controllers will enforce the security according
--  to the application security rules.  All these components are built only once when
--  an application starts.
--
--  A user is authenticated through an authentication system which creates a <tt>Principal</tt>
--  instance that identifies the user (green).  The security framework provides two authentication
--  systems: OpenID and OAuth 2.0 OpenID Connect.
--
--  [images/ModelOverview.png]
--
--  When a permission must be enforced, a security context is created and linked to the
--  <tt>Principal</tt> instance (blue).  Additional security policy context can be added depending
--  on the application context.  To check the permission, the security policy manager is called
--  and it will ask a security controller to verify the permission.
--
--  The framework allows an application to plug its own security policy, its own policy context,
--  its own principal and authentication mechanism.
--
--  @include security-permissions.ads
--
--  == Principal ==
--  A principal is created by using either the [Security_Auth OpenID],
--  the [Security_OAuth OAuth] or another authentication mechanism.  The authentication produces
--  an object that must implement the <tt>Principal</tt> interface.  For example:
--
--    P : Security.Auth.Principal_Access := Security.Auth.Create_Principal (Auth);
--
--  or
--
--    P : Security.OAuth.Clients.Access_Token_Access := Security.OAuth.Clients.Create_Access_Token
--
--  The principal is then stored in a security context.
--
--  @include security-contexts.ads
--
--  [Security_Policies Security Policies]
--  [Security_Auth OpenID]
--  [Security_OAuth OAuth]
--
package Security is

   pragma Preelaborate;

   --  ------------------------------
   --  Principal
   --  ------------------------------
   type Principal is limited interface;
   type Principal_Access is access all Principal'Class;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String is abstract;

end Security;

Add some documentation

Add some documentation


-----------------------------------------------------------------------
--  security -- Security
--  Copyright (C) 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

--  == Introduction ==
--
--
--  @include "security-contexts.ads"
--  @include "security-controllers.ads"
package Security is

end Security;

-----------------------------------------------------------------------
--  security -- Security
--  Copyright (C) 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

--  == Introduction ==
--
--
--  @include security-contexts.ads
--  @include security-controllers.ads
package Security is

end Security;

Fix documentation links

Fix documentation links


-----------------------------------------------------------------------
--  properties-bundles -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Containers;
with Ada.Finalization;
with Ada.Containers.Hashed_Maps;
with Util.Strings;
with Util.Concurrent.Locks;
package Util.Properties.Bundles is

   NO_BUNDLE : exception;

   NOT_WRITEABLE : exception;

   type Manager is new Util.Properties.Manager with private;

   --  ------------------------------
   --  Bundle loader
   --  ------------------------------
   --  The <b>Loader</b> provides facilities for loading property bundles
   --  and maintains a cache of bundles.  The cache is thread-safe but the returned
   --  bundles are not thread-safe.
   type Loader is limited private;
   type Loader_Access is access all Loader;

   --  Initialize the bundle factory and specify where the property files are stored.
   procedure Initialize (Factory : in out Loader;
                         Path    : in String);

   --  Load the bundle with the given name and for the given locale name.
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class);
private

   procedure Add_Bundle (Self : in out Manager; Props : in Manager_Access);
   --  Add a bundle

   type Bundle_Manager_Access is access all Manager'Class;

   type Manager is new Util.Properties.Manager with null record;

   overriding
   procedure Initialize (Object : in out Manager);

   overriding
   procedure Adjust (Object : in out Manager);

   package Bundle_Map is
     new Ada.Containers.Hashed_Maps
       (Element_Type    => Bundle_Manager_Access,
        Key_Type        => Util.Strings.Name_Access,
        Hash            => Util.Strings.Hash,
        Equivalent_Keys => Util.Strings.Equivalent_Keys);

   type Loader is new Ada.Finalization.Limited_Controlled with record
      Lock    : Util.Concurrent.Locks.RW_Lock;
      Bundles : Bundle_Map.Map;
      Path    : Unbounded_String;
   end record;

   --  Finalize the bundle loader and clear the cache
   overriding
   procedure Finalize (Factory : in out Loader);

   --  Clear the cache bundle
   procedure Clear_Cache (Factory : in out Loader);

   --  Find the bundle with the given name and for the given locale name.
   procedure Find_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class;
                          Found   : out Boolean);

   --  Load the bundle with the given name and for the given locale name.
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Found   : out Boolean);

end Util.Properties.Bundles;

-----------------------------------------------------------------------
--  properties-bundles -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 2012, 2018 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Containers;
with Ada.Finalization;
with Ada.Containers.Hashed_Maps;
with Util.Strings;
with Util.Concurrent.Locks;

--  == Property bundles ==
--  Property bundles represent several property files that share some overriding rules and
--  capabilities.  Their introduction comes from Java resource bundles which allow to
--  localize easily some configuration files or some message.  When loading a property bundle
--  a locale is defined to specify the target language and locale.  If a specific property
--  file for that locale exists, it is used first.  Otherwise, the property bundle will use
--  the default property file.
--
--  A rule exists on the name of the specific property locale file: it must start with the
--  bundle name followed by `_` and the name of the locale.  The default property file must
--  be the bundle name.  For example, the bundle `dates` is associated with the following
--  property files:
--
--    dates.properties           Default values (English locale)
--    dates_fr.properties        French locale
--    dates_de.properties        German locale
--    dates_es.properties        Spain locale
--
--  Because a bundle can be associated with one or several property files, a specific loader is
--  used.  The loader instance must be declared and configured to indicate one or several search
--  directories that contain property files.
--
--    with Util.Properties.Bundles;
--    ...
--       Loader : Util.Properties.Bundles.Loader;
--       Bundle : Util.Properties.Bundles.Manager;
--       ...
--       Util.Properties.Bundles.Initialize (Loader, "bundles;/usr/share/bundles");
--       Util.Properties.Bundles.Load_Bundle (Loader, "dates", "fr", Bundle);
--       Ada.Text_IO.Put_Line (Bundle.Get ("util.month1.long");
--
--  In this example, the `util.month1.long` key is first search in the `dates_fr` French locale
--  and if it is not found it is searched in the default locale.
package Util.Properties.Bundles is

   NO_BUNDLE : exception;

   NOT_WRITEABLE : exception;

   type Manager is new Util.Properties.Manager with private;

   --  ------------------------------
   --  Bundle loader
   --  ------------------------------
   --  The <b>Loader</b> provides facilities for loading property bundles
   --  and maintains a cache of bundles.  The cache is thread-safe but the returned
   --  bundles are not thread-safe.
   type Loader is limited private;
   type Loader_Access is access all Loader;

   --  Initialize the bundle factory and specify where the property files are stored.
   procedure Initialize (Factory : in out Loader;
                         Path    : in String);

   --  Load the bundle with the given name and for the given locale name.
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class);
private

   procedure Add_Bundle (Self : in out Manager; Props : in Manager_Access);
   --  Add a bundle

   type Bundle_Manager_Access is access all Manager'Class;

   type Manager is new Util.Properties.Manager with null record;

   overriding
   procedure Initialize (Object : in out Manager);

   overriding
   procedure Adjust (Object : in out Manager);

   package Bundle_Map is
     new Ada.Containers.Hashed_Maps
       (Element_Type    => Bundle_Manager_Access,
        Key_Type        => Util.Strings.Name_Access,
        Hash            => Util.Strings.Hash,
        Equivalent_Keys => Util.Strings.Equivalent_Keys);

   type Loader is new Ada.Finalization.Limited_Controlled with record
      Lock    : Util.Concurrent.Locks.RW_Lock;
      Bundles : Bundle_Map.Map;
      Path    : Unbounded_String;
   end record;

   --  Finalize the bundle loader and clear the cache
   overriding
   procedure Finalize (Factory : in out Loader);

   --  Clear the cache bundle
   procedure Clear_Cache (Factory : in out Loader);

   --  Find the bundle with the given name and for the given locale name.
   procedure Find_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class;
                          Found   : out Boolean);

   --  Load the bundle with the given name and for the given locale name.
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Found   : out Boolean);

end Util.Properties.Bundles;

Document the property bundles

Document the property bundles


--  Copyright (c) 2018 onox <denkpadje@gmail.com>
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.

with Ada.Directories;

package body Orka.Resources.Locations.Directories is

   use Ada.Streams;

   function Open_File (File_Name : String) return Byte_Array_File is
   begin
      return Result : Byte_Array_File
        := (Ada.Finalization.Limited_Controlled with File => <>, Finalized => False) do
         Stream_IO.Open (Result.File, Stream_IO.In_File, File_Name);
      end return;
   end Open_File;

   overriding
   procedure Finalize (Object : in out Byte_Array_File) is
   begin
      if not Object.Finalized then
         if Stream_IO.Is_Open (Object.File) then
            Stream_IO.Close (Object.File);
         end if;
         Object.Finalized := True;
      end if;
   end Finalize;

   function Read_File (Object : in out Byte_Array_File) return Byte_Array_Access is
      File_Stream : Stream_IO.Stream_Access;
      File_Size   : constant Integer := Integer (Stream_IO.Size (Object.File));

      subtype File_Byte_Array is Byte_Array (1 .. Stream_Element_Offset (File_Size));
      Raw_Contents : Byte_Array_Access := new File_Byte_Array;
   begin
      File_Stream := Stream_IO.Stream (Object.File);
      File_Byte_Array'Read (File_Stream, Raw_Contents.all);
      return Raw_Contents;
   exception
      when others =>
         Free_Byte_Array (Raw_Contents);
         raise;
   end Read_File;

   -----------------------------------------------------------------------------

   function Create_File (File_Name : String) return Byte_Array_File is
   begin
      return Result : Byte_Array_File
        := (Ada.Finalization.Limited_Controlled with File => <>, Finalized => False) do
         Stream_IO.Create (Result.File, Stream_IO.In_File, File_Name);
      end return;
   end Create_File;

   procedure Write_Data (Object : in out Byte_Array_File'Class; Data : Byte_Array_Access) is
      File_Stream : Stream_IO.Stream_Access;
      File_Size   : constant Integer := Data'Length;

      subtype File_Byte_Array is Byte_Array (1 .. Stream_Element_Offset (File_Size));
   begin
      File_Stream := Stream_IO.Stream (Object.File);
      File_Byte_Array'Write (File_Stream, Data.all);
   end Write_Data;

   -----------------------------------------------------------------------------

   overriding
   function Exists (Object : Directory_Location; Path : String) return Boolean is
      Directory : String renames SU.To_String (Object.Full_Path);
      Full_Path : constant String := Directory & Path_Separator & Path;
   begin
      return Ada.Directories.Exists (Full_Path);
   end Exists;

   overriding
   function Read_Data
     (Object : Directory_Location;
      Path   : String) return not null Byte_Array_Access
   is
      Directory : String renames SU.To_String (Object.Full_Path);
      Full_Path : constant String := Directory & Path_Separator & Path;

      use Ada.Directories;
   begin
      if not Exists (Full_Path) then
         raise Name_Error with "File '" & Full_Path & "' not found";
      end if;

      if Kind (Full_Path) /= Ordinary_File then
         raise Name_Error with "Path '" & Full_Path & "' is not a regular file";
      end if;

      declare
         File : constant Byte_Array_File'Class := Open_File (Full_Path);
      begin
         return File.Read_File;
      end;
   end Read_Data;

   procedure Write_Data
     (Object : Directory_Location;
      Path   : String;
      Data   : Byte_Array_Access)
   is
      Directory : String renames SU.To_String (Object.Full_Path);
      Full_Path : constant String := Directory & Path_Separator & Path;

      use Ada.Directories;
   begin
      if Exists (Full_Path) then
         raise Name_Error with "File '" & Full_Path & "' already exists";
      end if;

      declare
         File : constant Byte_Array_File'Class := Create_File (Full_Path);
      begin
         File.Write_Data (Data);
      end;
   end Write_Data;

   function Create_Location (Path : String) return Location_Ptr is
      use Ada.Directories;

      Full_Path : constant String := Full_Name (Path);
   begin
      if not Exists (Full_Path) then
         raise Name_Error with "Directory '" & Full_Path & "' not found";
      end if;

      if Kind (Full_Path) /= Directory then
         raise Name_Error with "Path '" & Full_Path & "' is not a directory";
      end if;

      return new Directory_Location'(Full_Path => SU.To_Unbounded_String (Full_Path));
   end Create_Location;

end Orka.Resources.Locations.Directories;

--  Copyright (c) 2018 onox <denkpadje@gmail.com>
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.

with Ada.Directories;

package body Orka.Resources.Locations.Directories is

   use Ada.Streams;

   function Open_File (File_Name : String) return Byte_Array_File is
   begin
      return Result : Byte_Array_File
        := (Ada.Finalization.Limited_Controlled with File => <>, Finalized => False) do
         Stream_IO.Open (Result.File, Stream_IO.In_File, File_Name);
      end return;
   end Open_File;

   overriding
   procedure Finalize (Object : in out Byte_Array_File) is
   begin
      if not Object.Finalized then
         if Stream_IO.Is_Open (Object.File) then
            Stream_IO.Close (Object.File);
         end if;
         Object.Finalized := True;
      end if;
   end Finalize;

   function Read_File (Object : in out Byte_Array_File) return Byte_Array_Access is
      File_Stream : Stream_IO.Stream_Access;
      File_Size   : constant Integer := Integer (Stream_IO.Size (Object.File));

      subtype File_Byte_Array is Byte_Array (1 .. Stream_Element_Offset (File_Size));
      Raw_Contents : Byte_Array_Access := new File_Byte_Array;
   begin
      File_Stream := Stream_IO.Stream (Object.File);
      File_Byte_Array'Read (File_Stream, Raw_Contents.all);
      return Raw_Contents;
   exception
      when others =>
         Free_Byte_Array (Raw_Contents);
         raise;
   end Read_File;

   -----------------------------------------------------------------------------

   function Create_File (File_Name : String) return Byte_Array_File is
   begin
      return Result : Byte_Array_File
        := (Ada.Finalization.Limited_Controlled with File => <>, Finalized => False) do
         Stream_IO.Create (Result.File, Stream_IO.Out_File, File_Name);
      end return;
   end Create_File;

   procedure Write_Data (Object : in out Byte_Array_File'Class; Data : Byte_Array_Access) is
      File_Stream : Stream_IO.Stream_Access;
      File_Size   : constant Integer := Data'Length;

      subtype File_Byte_Array is Byte_Array (1 .. Stream_Element_Offset (File_Size));
   begin
      File_Stream := Stream_IO.Stream (Object.File);
      File_Byte_Array'Write (File_Stream, Data.all);
   end Write_Data;

   -----------------------------------------------------------------------------

   overriding
   function Exists (Object : Directory_Location; Path : String) return Boolean is
      Directory : String renames SU.To_String (Object.Full_Path);
      Full_Path : constant String := Directory & Path_Separator & Path;
   begin
      return Ada.Directories.Exists (Full_Path);
   end Exists;

   overriding
   function Read_Data
     (Object : Directory_Location;
      Path   : String) return not null Byte_Array_Access
   is
      Directory : String renames SU.To_String (Object.Full_Path);
      Full_Path : constant String := Directory & Path_Separator & Path;

      use Ada.Directories;
   begin
      if not Exists (Full_Path) then
         raise Name_Error with "File '" & Full_Path & "' not found";
      end if;

      if Kind (Full_Path) /= Ordinary_File then
         raise Name_Error with "Path '" & Full_Path & "' is not a regular file";
      end if;

      declare
         File : constant Byte_Array_File'Class := Open_File (Full_Path);
      begin
         return File.Read_File;
      end;
   end Read_Data;

   procedure Write_Data
     (Object : Directory_Location;
      Path   : String;
      Data   : Byte_Array_Access)
   is
      Directory : String renames SU.To_String (Object.Full_Path);
      Full_Path : constant String := Directory & Path_Separator & Path;

      use Ada.Directories;
   begin
      if Exists (Full_Path) then
         raise Name_Error with "File '" & Full_Path & "' already exists";
      end if;

      declare
         File : constant Byte_Array_File'Class := Create_File (Full_Path);
      begin
         File.Write_Data (Data);
      end;
   end Write_Data;

   function Create_Location (Path : String) return Location_Ptr is
      use Ada.Directories;

      Full_Path : constant String := Full_Name (Path);
   begin
      if not Exists (Full_Path) then
         raise Name_Error with "Directory '" & Full_Path & "' not found";
      end if;

      if Kind (Full_Path) /= Directory then
         raise Name_Error with "Path '" & Full_Path & "' is not a directory";
      end if;

      return new Directory_Location'(Full_Path => SU.To_Unbounded_String (Full_Path));
   end Create_Location;

end Orka.Resources.Locations.Directories;

orka: Fix writing to created file in procedure Write_Data

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


-----------------------------------------------------------------------
--  security-oauth-servers -- OAuth Server Authentication Support
--  Copyright (C) 2016, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Calendar;
with Ada.Finalization;
with Ada.Strings.Hash;
with Ada.Containers.Indefinite_Hashed_Maps;

with Util.Strings;

with Security.Auth;
with Security.Permissions;

--  == OAuth Server ==
--  OAuth server side is provided by the <tt>Security.OAuth.Servers</tt> package.
--  This package allows to implement the authorization framework described in RFC 6749
--  "The OAuth 2.0 Authorization Framework".
--
--  The authorization method produces a <tt>Grant_Type</tt> object that contains the result
--  of the grant (successful or denied).  It is the responsibility of the caller to format
--  the result in JSON/XML and return it to the client.
--
--  Three important operations are defined for the OAuth 2.0 framework.  They will be used
--  in the following order:
--
--  <tt>Authorize</tt> is used to obtain an authorization request.  This operation is
--  optional in the OAuth 2.0 framework since some authorization method directly return
--  the access token.  This operation is used by the "Authorization Code Grant" and the
--  "Implicit Grant".
--
--  <tt>Token</tt> is used to get the access token and optional refresh token.  Each time it
--  is called, a new token is generated.
--
--  <tt>Authenticate</tt> is used for the API request to verify the access token
--  and authenticate the API call.  This operation can be called several times with the same
--  token until the token is revoked or it has expired.
--
--  Several grant types are supported.
--
--  === Application Manager ===
--  The application manager maintains the repository of applications which are known by
--  the server and which can request authorization.  Each application is identified by
--  a client identifier (represented by the <tt>client_id</tt> request parameter).
--  The application defines the authorization methods which are allowed as well as
--  the parameters to control and drive the authorization.  This includes the redirection
--  URI, the application secret, the expiration delay for the access token.
--
--  The application manager is implemented by the application server and it must
--  implement the <tt>Application_Manager</tt> interface with the <tt>Find_Application</tt>
--  method.  The <tt>Find_Application</tt> is one of the first call made during the
--  authenticate and token generation phases.
--
--  === Resource Owner Password Credentials Grant ===
--  The password grant is one of the easiest grant method to understand but it is also one
--  of the less secure.  In this grant method, the username and user password are passed in
--  the request parameter together with the application client identifier.  The realm verifies
--  the username and password and when they are correct it generates the access token with
--  an optional refresh token.
--
--    Realm : Security.OAuth.Servers.Auth_Manager;
--    Grant : Security.OAuth.Servers.Grant_Type;
--
--      Realm.Token (Params, Grant);
--
--  === Accessing Protected Resources ===
--  When accessing a protected resource, the API implementation will use the
--  <tt>Authenticate</tt> operation to verify the access token and get a security principal.
--  The security principal will identify the resource owner as well as the application
--  that is doing the call.
--
--     Realm : Security.OAuth.Servers.Auth_Manager;
--     Grant : Security.OAuth.Servers.Grant_Type;
--     Token : String := ...;
--
--       Realm.Authenticate (Token, Grant);
--
--  When a security principal is returned, the access token was validated and the
--  request is granted for the application.
--
package Security.OAuth.Servers is

   Invalid_Application : exception;

   type Application is new Security.OAuth.Application with private;

   --  Check if the application has the given permission.
   function Has_Permission (App        : in Application;
                            Permission : in Security.Permissions.Permission_Index) return Boolean;

   --  Define the status of the grant.
   type Grant_Status is (Invalid_Grant, Expired_Grant, Revoked_Grant,
                         Stealed_Grant, Valid_Grant);

   --  Define the grant type.
   type Grant_Kind is (No_Grant, Access_Grant, Code_Grant,
                       Implicit_Grant, Password_Grant, Credential_Grant,
                       Extension_Grant);

   --  The <tt>Grant_Type</tt> holds the results of the authorization.
   --  When the grant is refused, the type holds information about the refusal.
   type Grant_Type is record
      --  The request grant type.
      Request : Grant_Kind := No_Grant;

      --  The response status.
      Status  : Grant_Status := Invalid_Grant;

      --  When success, the token to return.
      Token   : Ada.Strings.Unbounded.Unbounded_String;

      --  When success, the token expiration date.
      Expires : Ada.Calendar.Time;

      --  When success, the authentication principal.
      Auth    : Security.Principal_Access;

      --  When error, the type of error to return.
      Error   : Util.Strings.Name_Access;
   end record;

   type Application_Manager is limited interface;
   type Application_Manager_Access is access all Application_Manager'Class;

   --  Find the application that correspond to the given client id.
   --  The <tt>Invalid_Application</tt> exception should be raised if there is no such application.
   function Find_Application (Realm     : in Application_Manager;
                              Client_Id : in String) return Application'Class is abstract;

   type Realm_Manager is limited interface;
   type Realm_Manager_Access is access all Realm_Manager'Class;

   --  Authenticate the token and find the associated authentication principal.
   --  The access token has been verified and the token represents the identifier
   --  of the Tuple (client_id, user, session) that describes the authentication.
   --  The <tt>Authenticate</tt> procedure should look in its database (internal
   --  or external) to find the authentication principal that was granted for
   --  the token Tuple.  When the token was not found (because it was revoked),
   --  the procedure should return a null principal.  If the authentication
   --  principal can be cached, the <tt>Cacheable</tt> value should be set.
   --  In that case, the access token and authentication  principal are inserted
   --  in a cache.
   procedure Authenticate (Realm     : in out Realm_Manager;
                           Token     : in String;
                           Auth      : out Principal_Access;
                           Cacheable : out Boolean) is abstract;

   --  Create an auth token string that identifies the given principal.  The returned
   --  token will be used by <tt>Authenticate</tt> to retrieve back the principal.  The
   --  returned token does not need to be signed.  It will be inserted in the public part
   --  of the returned access token.
   function Authorize (Realm : in Realm_Manager;
                       App   : in Application'Class;
                       Scope : in String;
                       Auth  : in Principal_Access) return String is abstract;

   procedure Verify (Realm    : in out Realm_Manager;
                     Username : in String;
                     Password : in String;
                     Auth     : out Principal_Access) is abstract;

   procedure Verify (Realm : in out Realm_Manager;
                     Token : in String;
                     Auth  : out Principal_Access) is abstract;

   procedure Revoke (Realm : in out Realm_Manager;
                     Auth  : in Principal_Access) is abstract;

   type Auth_Manager is tagged limited private;
   type Auth_Manager_Access is access all Auth_Manager'Class;

   --  Set the auth private key.
   procedure Set_Private_Key (Manager : in out Auth_Manager;
                              Key     : in String);

   --  Set the application manager to use and and applications.
   procedure Set_Application_Manager (Manager    : in out Auth_Manager;
                                      Repository : in Application_Manager_Access);

   --  Set the realm manager to authentify users.
   procedure Set_Realm_Manager (Manager : in out Auth_Manager;
                                Realm   : in Realm_Manager_Access);

   --  Authorize the access to the protected resource by the application and for the
   --  given principal.  The resource owner has been verified and is represented by the
   --  <tt>Auth</tt> principal.  Extract from the request parameters represented by
   --  <tt>Params</tt> the application client id, the scope and the expected response type.
   --  Handle the "Authorization Code Grant" and "Implicit Grant" defined in RFC 6749.
   procedure Authorize (Realm   : in out Auth_Manager;
                        Params  : in Security.Auth.Parameters'Class;
                        Auth    : in Security.Principal_Access;
                        Grant   : out Grant_Type);

   procedure Token (Realm   : in out Auth_Manager;
                    Params  : in Security.Auth.Parameters'Class;
                    Grant   : out Grant_Type);

   --  Make the access token from the authorization code that was created by the
   --  <tt>Authorize</tt> operation.  Verify the client application, the redirect uri, the
   --  client secret and the validity of the authorization code.  Extract from the
   --  authorization code the auth principal that was used for the grant and make the
   --  access token.
   procedure Token_From_Code (Realm   : in out Auth_Manager;
                              App     : in Application'Class;
                              Params  : in Security.Auth.Parameters'Class;
                              Grant   : out Grant_Type);

   procedure Authorize_Code (Realm   : in out Auth_Manager;
                             App     : in Application'Class;
                             Params  : in Security.Auth.Parameters'Class;
                             Auth    : in Security.Principal_Access;
                             Grant   : out Grant_Type);

   procedure Authorize_Token (Realm   : in out Auth_Manager;
                              App     : in Application'Class;
                              Params  : in Security.Auth.Parameters'Class;
                              Auth    : in Security.Principal_Access;
                              Grant   : out Grant_Type);

   --  Make the access token from the resource owner password credentials.  The username,
   --  password and scope are extracted from the request and they are verified through the
   --  <tt>Verify</tt> procedure to obtain an associated principal.  When successful, the
   --  principal describes the authorization and it is used to forge the access token.
   --  This operation implements the RFC 6749: 4.3.  Resource Owner Password Credentials Grant.
   procedure Token_From_Password (Realm   : in out Auth_Manager;
                                  App     : in Application'Class;
                                  Params  : in Security.Auth.Parameters'Class;
                                  Grant   : out Grant_Type);

   --  RFC 6749: 5.  Issuing an Access Token
   procedure Create_Token (Realm  : in Auth_Manager;
                           Ident  : in String;
                           Grant  : in out Grant_Type);

   --  Authenticate the access token and get a security principal that identifies the app/user.
   --  See RFC 6749, 7.  Accessing Protected Resources.
   --  The access token is first searched in the cache.  If it was found, it means the access
   --  token was already verified in the past, it is granted and associated with a principal.
   --  Otherwise, we have to verify the token signature first, then the expiration date and
   --  we extract from the token public part the auth identification.  The <tt>Authenticate</tt>
   --  operation is then called to obtain the principal from the auth identification.
   --  When access token is invalid or authentification cannot be verified, a null principal
   --  is returned.  The <tt>Grant</tt> data will hold the result of the grant with the reason
   --  of failures (if any).
   procedure Authenticate (Realm : in out Auth_Manager;
                           Token : in String;
                           Grant : out Grant_Type);

   procedure Revoke (Realm     : in out Auth_Manager;
                     Token     : in String);

private

   use Ada.Strings.Unbounded;

   function Format_Expire (Expire : in Ada.Calendar.Time) return String;

   type Application is new Security.OAuth.Application with record
      Expire_Timeout : Duration := 3600.0;
      Permissions    : Security.Permissions.Permission_Index_Set := Security.Permissions.EMPTY_SET;
   end record;

   type Cache_Entry is record
      Expire : Ada.Calendar.Time;
      Auth   : Principal_Access;
   end record;

   package Cache_Map is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Cache_Entry,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => "=");

   --  The access token cache is used to speed up the access token verification
   --  when a request to a protected resource is made.
   protected type Token_Cache is

      procedure Authenticate (Token : in String;
                              Grant : in out Grant_Type);

      procedure Insert (Token     : in String;
                        Expire    : in Ada.Calendar.Time;
                        Principal : in Principal_Access);

      procedure Remove (Token : in String);

      procedure Timeout;

   private
      Entries : Cache_Map.Map;
   end Token_Cache;

   type Auth_Manager is new Ada.Finalization.Limited_Controlled with record
      --  The repository of applications.
      Repository  : Application_Manager_Access;

      --  The realm for user authentication.
      Realm       : Realm_Manager_Access;

      --  The server private key used by the HMAC signature.
      Private_Key : Ada.Strings.Unbounded.Unbounded_String;

      --  The access token cache.
      Cache       : Token_Cache;

      --  The expiration time for the generated authorization code.
      Expire_Code : Duration := 300.0;
   end record;

   --  The <tt>Token_Validity</tt> record provides information about a token to find out
   --  the different components it is made of and verify its validity.  The <tt>Validate</tt>
   --  procedure is in charge of checking the components and verifying the HMAC signature.
   --  The token has the following format:
   --  <expiration>.<client_id>.<auth-ident>.hmac(<public>.<private-key>)
   type Token_Validity is record
      Status       : Grant_Status := Invalid_Grant;
      Ident_Start  : Natural := 0;
      Ident_End    : Natural := 0;
      Expire       : Ada.Calendar.Time;
   end record;

   function Validate (Realm     : in Auth_Manager;
                      Client_Id : in String;
                      Token     : in String) return Token_Validity;

end Security.OAuth.Servers;

-----------------------------------------------------------------------
--  security-oauth-servers -- OAuth Server Authentication Support
--  Copyright (C) 2016, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Calendar;
with Ada.Finalization;
with Ada.Strings.Hash;
with Ada.Containers.Indefinite_Hashed_Maps;

with Util.Strings;

with Security.Auth;
with Security.Permissions;

--  == OAuth Server ==
--  OAuth server side is provided by the <tt>Security.OAuth.Servers</tt> package.
--  This package allows to implement the authorization framework described in RFC 6749
--  "The OAuth 2.0 Authorization Framework".
--
--  The authorization method produces a <tt>Grant_Type</tt> object that contains the result
--  of the grant (successful or denied).  It is the responsibility of the caller to format
--  the result in JSON/XML and return it to the client.
--
--  Three important operations are defined for the OAuth 2.0 framework.  They will be used
--  in the following order:
--
--  <tt>Authorize</tt> is used to obtain an authorization request.  This operation is
--  optional in the OAuth 2.0 framework since some authorization method directly return
--  the access token.  This operation is used by the "Authorization Code Grant" and the
--  "Implicit Grant".
--
--  <tt>Token</tt> is used to get the access token and optional refresh token.  Each time it
--  is called, a new token is generated.
--
--  <tt>Authenticate</tt> is used for the API request to verify the access token
--  and authenticate the API call.  This operation can be called several times with the same
--  token until the token is revoked or it has expired.
--
--  Several grant types are supported.
--
--  === Application Manager ===
--  The application manager maintains the repository of applications which are known by
--  the server and which can request authorization.  Each application is identified by
--  a client identifier (represented by the <tt>client_id</tt> request parameter).
--  The application defines the authorization methods which are allowed as well as
--  the parameters to control and drive the authorization.  This includes the redirection
--  URI, the application secret, the expiration delay for the access token.
--
--  The application manager is implemented by the application server and it must
--  implement the <tt>Application_Manager</tt> interface with the <tt>Find_Application</tt>
--  method.  The <tt>Find_Application</tt> is one of the first call made during the
--  authenticate and token generation phases.
--
--  === Resource Owner Password Credentials Grant ===
--  The password grant is one of the easiest grant method to understand but it is also one
--  of the less secure.  In this grant method, the username and user password are passed in
--  the request parameter together with the application client identifier.  The realm verifies
--  the username and password and when they are correct it generates the access token with
--  an optional refresh token.
--
--    Realm : Security.OAuth.Servers.Auth_Manager;
--    Grant : Security.OAuth.Servers.Grant_Type;
--
--      Realm.Token (Params, Grant);
--
--  === Accessing Protected Resources ===
--  When accessing a protected resource, the API implementation will use the
--  <tt>Authenticate</tt> operation to verify the access token and get a security principal.
--  The security principal will identify the resource owner as well as the application
--  that is doing the call.
--
--     Realm : Security.OAuth.Servers.Auth_Manager;
--     Grant : Security.OAuth.Servers.Grant_Type;
--     Token : String := ...;
--
--       Realm.Authenticate (Token, Grant);
--
--  When a security principal is returned, the access token was validated and the
--  request is granted for the application.
--
package Security.OAuth.Servers is

   Invalid_Application : exception;

   type Application is new Security.OAuth.Application with private;

   --  Check if the application has the given permission.
   function Has_Permission (App        : in Application;
                            Permission : in Security.Permissions.Permission_Index) return Boolean;

   --  Define the status of the grant.
   type Grant_Status is (Invalid_Grant, Expired_Grant, Revoked_Grant,
                         Stealed_Grant, Valid_Grant);

   --  Define the grant type.
   type Grant_Kind is (No_Grant, Access_Grant, Code_Grant,
                       Implicit_Grant, Password_Grant, Credential_Grant,
                       Extension_Grant);

   --  The <tt>Grant_Type</tt> holds the results of the authorization.
   --  When the grant is refused, the type holds information about the refusal.
   type Grant_Type is record
      --  The request grant type.
      Request : Grant_Kind := No_Grant;

      --  The response status.
      Status  : Grant_Status := Invalid_Grant;

      --  When success, the token to return.
      Token   : Ada.Strings.Unbounded.Unbounded_String;

      --  When success, the token expiration date.
      Expires : Ada.Calendar.Time;

      --  When success, the authentication principal.
      Auth    : Security.Principal_Access;

      --  When error, the type of error to return.
      Error   : Util.Strings.Name_Access;
   end record;

   type Application_Manager is limited interface;
   type Application_Manager_Access is access all Application_Manager'Class;

   --  Find the application that correspond to the given client id.
   --  The <tt>Invalid_Application</tt> exception should be raised if there is no such application.
   function Find_Application (Realm     : in Application_Manager;
                              Client_Id : in String) return Application'Class is abstract;

   type Realm_Manager is limited interface;
   type Realm_Manager_Access is access all Realm_Manager'Class;

   --  Authenticate the token and find the associated authentication principal.
   --  The access token has been verified and the token represents the identifier
   --  of the Tuple (client_id, user, session) that describes the authentication.
   --  The <tt>Authenticate</tt> procedure should look in its database (internal
   --  or external) to find the authentication principal that was granted for
   --  the token Tuple.  When the token was not found (because it was revoked),
   --  the procedure should return a null principal.  If the authentication
   --  principal can be cached, the <tt>Cacheable</tt> value should be set.
   --  In that case, the access token and authentication  principal are inserted
   --  in a cache.
   procedure Authenticate (Realm     : in out Realm_Manager;
                           Token     : in String;
                           Auth      : out Principal_Access;
                           Cacheable : out Boolean) is abstract;

   --  Create an auth token string that identifies the given principal.  The returned
   --  token will be used by <tt>Authenticate</tt> to retrieve back the principal.  The
   --  returned token does not need to be signed.  It will be inserted in the public part
   --  of the returned access token.
   function Authorize (Realm : in Realm_Manager;
                       App   : in Application'Class;
                       Scope : in String;
                       Auth  : in Principal_Access) return String is abstract;

   procedure Verify (Realm    : in out Realm_Manager;
                     Username : in String;
                     Password : in String;
                     Auth     : out Principal_Access) is abstract;

   procedure Verify (Realm : in out Realm_Manager;
                     Token : in String;
                     Auth  : out Principal_Access) is abstract;

   procedure Revoke (Realm : in out Realm_Manager;
                     Auth  : in Principal_Access) is abstract;

   type Auth_Manager is tagged limited private;
   type Auth_Manager_Access is access all Auth_Manager'Class;

   --  Set the auth private key.
   procedure Set_Private_Key (Manager : in out Auth_Manager;
                              Key     : in String);

   --  Set the application manager to use and and applications.
   procedure Set_Application_Manager (Manager    : in out Auth_Manager;
                                      Repository : in Application_Manager_Access);

   --  Set the realm manager to authentify users.
   procedure Set_Realm_Manager (Manager : in out Auth_Manager;
                                Realm   : in Realm_Manager_Access);

   --  Authorize the access to the protected resource by the application and for the
   --  given principal.  The resource owner has been verified and is represented by the
   --  <tt>Auth</tt> principal.  Extract from the request parameters represented by
   --  <tt>Params</tt> the application client id, the scope and the expected response type.
   --  Handle the "Authorization Code Grant" and "Implicit Grant" defined in RFC 6749.
   procedure Authorize (Realm   : in out Auth_Manager;
                        Params  : in Security.Auth.Parameters'Class;
                        Auth    : in Security.Principal_Access;
                        Grant   : out Grant_Type);

   --  The <tt>Token</tt> procedure is the main entry point to get the access token and
   --  refresh token.  The request parameters are accessed through the <tt>Params</tt> interface.
   --  The operation looks at the "grant_type" parameter to identify the access method.
   --  It also looks at the "client_id" to find the application for which the access token
   --  is created.  Upon successful authentication, the operation returns a grant.
   procedure Token (Realm   : in out Auth_Manager;
                    Params  : in Security.Auth.Parameters'Class;
                    Grant   : out Grant_Type);

   --  Make the access token from the authorization code that was created by the
   --  <tt>Authorize</tt> operation.  Verify the client application, the redirect uri, the
   --  client secret and the validity of the authorization code.  Extract from the
   --  authorization code the auth principal that was used for the grant and make the
   --  access token.
   procedure Token_From_Code (Realm   : in out Auth_Manager;
                              App     : in Application'Class;
                              Params  : in Security.Auth.Parameters'Class;
                              Grant   : out Grant_Type);

   procedure Authorize_Code (Realm   : in out Auth_Manager;
                             App     : in Application'Class;
                             Params  : in Security.Auth.Parameters'Class;
                             Auth    : in Security.Principal_Access;
                             Grant   : out Grant_Type);

   procedure Authorize_Token (Realm   : in out Auth_Manager;
                              App     : in Application'Class;
                              Params  : in Security.Auth.Parameters'Class;
                              Auth    : in Security.Principal_Access;
                              Grant   : out Grant_Type);

   --  Make the access token from the resource owner password credentials.  The username,
   --  password and scope are extracted from the request and they are verified through the
   --  <tt>Verify</tt> procedure to obtain an associated principal.  When successful, the
   --  principal describes the authorization and it is used to forge the access token.
   --  This operation implements the RFC 6749: 4.3.  Resource Owner Password Credentials Grant.
   procedure Token_From_Password (Realm   : in out Auth_Manager;
                                  App     : in Application'Class;
                                  Params  : in Security.Auth.Parameters'Class;
                                  Grant   : out Grant_Type);

   --  Forge an access token.  The access token is signed by an HMAC-SHA1 signature.
   --  The returned token is formed as follows:
   --    <expiration>.<ident>.HMAC-SHA1(<private-key>, <expiration>.<ident>)
   --  See also RFC 6749: 5.  Issuing an Access Token
   procedure Create_Token (Realm  : in Auth_Manager;
                           Ident  : in String;
                           Grant  : in out Grant_Type);

   --  Authenticate the access token and get a security principal that identifies the app/user.
   --  See RFC 6749, 7.  Accessing Protected Resources.
   --  The access token is first searched in the cache.  If it was found, it means the access
   --  token was already verified in the past, it is granted and associated with a principal.
   --  Otherwise, we have to verify the token signature first, then the expiration date and
   --  we extract from the token public part the auth identification.  The <tt>Authenticate</tt>
   --  operation is then called to obtain the principal from the auth identification.
   --  When access token is invalid or authentification cannot be verified, a null principal
   --  is returned.  The <tt>Grant</tt> data will hold the result of the grant with the reason
   --  of failures (if any).
   procedure Authenticate (Realm : in out Auth_Manager;
                           Token : in String;
                           Grant : out Grant_Type);

   procedure Revoke (Realm     : in out Auth_Manager;
                     Token     : in String);

private

   use Ada.Strings.Unbounded;

   function Format_Expire (Expire : in Ada.Calendar.Time) return String;

   type Application is new Security.OAuth.Application with record
      Expire_Timeout : Duration := 3600.0;
      Permissions    : Security.Permissions.Permission_Index_Set := Security.Permissions.EMPTY_SET;
   end record;

   type Cache_Entry is record
      Expire : Ada.Calendar.Time;
      Auth   : Principal_Access;
   end record;

   package Cache_Map is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Cache_Entry,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => "=");

   --  The access token cache is used to speed up the access token verification
   --  when a request to a protected resource is made.
   protected type Token_Cache is

      procedure Authenticate (Token : in String;
                              Grant : in out Grant_Type);

      procedure Insert (Token     : in String;
                        Expire    : in Ada.Calendar.Time;
                        Principal : in Principal_Access);

      procedure Remove (Token : in String);

      procedure Timeout;

   private
      Entries : Cache_Map.Map;
   end Token_Cache;

   type Auth_Manager is new Ada.Finalization.Limited_Controlled with record
      --  The repository of applications.
      Repository  : Application_Manager_Access;

      --  The realm for user authentication.
      Realm       : Realm_Manager_Access;

      --  The server private key used by the HMAC signature.
      Private_Key : Ada.Strings.Unbounded.Unbounded_String;

      --  The access token cache.
      Cache       : Token_Cache;

      --  The expiration time for the generated authorization code.
      Expire_Code : Duration := 300.0;
   end record;

   --  The <tt>Token_Validity</tt> record provides information about a token to find out
   --  the different components it is made of and verify its validity.  The <tt>Validate</tt>
   --  procedure is in charge of checking the components and verifying the HMAC signature.
   --  The token has the following format:
   --  <expiration>.<client_id>.<auth-ident>.hmac(<public>.<private-key>)
   type Token_Validity is record
      Status       : Grant_Status := Invalid_Grant;
      Ident_Start  : Natural := 0;
      Ident_End    : Natural := 0;
      Expire       : Ada.Calendar.Time;
   end record;

   function Validate (Realm     : in Auth_Manager;
                      Client_Id : in String;
                      Token     : in String) return Token_Validity;

end Security.OAuth.Servers;

Add some documentation

Add some documentation