-----------------------------------------------------------------------
--  mat-targets - Representation of target information
--  Copyright (C) 2014 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.Containers.Ordered_Maps;
with Ada.Finalization;

with GNAT.Sockets;

with MAT.Types;
with MAT.Memory.Targets;
with MAT.Symbols.Targets;
with MAT.Events.Targets;
with MAT.Events.Probes;
with MAT.Readers;
with MAT.Readers.Streams;
with MAT.Readers.Streams.Sockets;
with MAT.Consoles;
package MAT.Targets is

   --  Exception raised if some option is invalid.
   Usage_Error : exception;

   --  The options that can be configured through the command line.
   type Options_Type is record
      --  Enable and enter in the interactive TTY console mode.
      Interactive  : Boolean := True;

      --  Try to load the symbol file automatically when a new process is received.
      Load_Symbols : Boolean := True;

      --  Enable the graphical mode (when available).
      Graphical    : Boolean := False;

      --  Print the events as they are received.
      Print_Events : Boolean := False;

      --  Define the server listening address.
      Address      : GNAT.Sockets.Sock_Addr_Type := (Port => 4096, others => <>);
   end record;

   type Target_Process_Type is tagged limited record
      Pid     : MAT.Types.Target_Process_Ref;
      Endian  : MAT.Readers.Endian_Type := MAT.Readers.LITTLE_ENDIAN;
      Path    : Ada.Strings.Unbounded.Unbounded_String;
      Memory  : MAT.Memory.Targets.Target_Memory;
      Symbols : MAT.Symbols.Targets.Target_Symbols_Ref;
      Events  : MAT.Events.Targets.Target_Events_Access;
      Console : MAT.Consoles.Console_Access;
   end record;
   type Target_Process_Type_Access is access all Target_Process_Type'Class;

   type Target_Type is new Ada.Finalization.Limited_Controlled
     and MAT.Events.Probes.Reader_List_Type with private;

   type Target_Type_Access is access all Target_Type'Class;

   --  Get the console instance.
   function Console (Target : in Target_Type) return MAT.Consoles.Console_Access;

   --  Set the console instance.
   procedure Console (Target  : in out Target_Type;
                      Console : in MAT.Consoles.Console_Access);

   --  Get the current process instance.
   function Process (Target : in Target_Type) return Target_Process_Type_Access;

   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   overriding
   procedure Initialize (Target : in out Target_Type;
                         Reader : in out MAT.Events.Probes.Probe_Manager_Type'Class);

   --  Create a process instance to hold and keep track of memory and other information about
   --  the given process ID.
   procedure Create_Process (Target  : in out Target_Type;
                             Pid     : in MAT.Types.Target_Process_Ref;
                             Path    : in Ada.Strings.Unbounded.Unbounded_String;
                             Process : out Target_Process_Type_Access);

   --  Find the process instance from the process ID.
   function Find_Process (Target : in Target_Type;
                          Pid    : in MAT.Types.Target_Process_Ref)
                          return Target_Process_Type_Access;

   --  Iterate over the list of connected processes and execute the <tt>Process</tt> procedure.
   procedure Iterator (Target  : in Target_Type;
                       Process : access procedure (Proc : in Target_Process_Type'Class));

   --  Parse the command line arguments and configure the target instance.
   procedure Initialize_Options (Target  : in out Target_Type);

   --  Enter in the interactive loop reading the commands from the standard input
   --  and executing the commands.
   procedure Interactive (Target : in out MAT.Targets.Target_Type);

   --  Start the server to listen to MAT event socket streams.
   procedure Start (Target : in out Target_Type);

   --  Stop the server thread.
   procedure Stop (Target : in out Target_Type);

   --  Convert the string to a socket address.  The string can have two forms:
   --     port
   --     host:port
   function To_Sock_Addr_Type (Param : in String) return GNAT.Sockets.Sock_Addr_Type;

   --  Print the application usage.
   procedure Usage;

private

   --  Define a map of <tt>Target_Process_Type_Access</tt> keyed by the process Id.
   --  This map allows to retrieve the information about a process.
   use type MAT.Types.Target_Process_Ref;
   package Process_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Process_Ref,
                                      Element_Type => Target_Process_Type_Access);

   subtype Process_Map is Process_Maps.Map;
   subtype Process_Cursor is Process_Maps.Cursor;

   type Target_Type is new Ada.Finalization.Limited_Controlled
     and MAT.Events.Probes.Reader_List_Type with record
      Current   : Target_Process_Type_Access;
      Processes : Process_Map;
      Console   : MAT.Consoles.Console_Access;
      Options   : Options_Type;
      Server    : MAT.Readers.Streams.Sockets.Socket_Listener_Type;
   end record;

end MAT.Targets;

-----------------------------------------------------------------------
--  mat-targets - Representation of target information
--  Copyright (C) 2014 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.Containers.Ordered_Maps;
with Ada.Finalization;

with GNAT.Sockets;

with MAT.Types;
with MAT.Memory.Targets;
with MAT.Symbols.Targets;
with MAT.Events.Targets;
with MAT.Events.Probes;
with MAT.Readers;
with MAT.Readers.Streams;
with MAT.Readers.Streams.Sockets;
with MAT.Consoles;
package MAT.Targets is

   --  Exception raised if some option is invalid.
   Usage_Error : exception;

   --  The options that can be configured through the command line.
   type Options_Type is record
      --  Enable and enter in the interactive TTY console mode.
      Interactive  : Boolean := True;

      --  Try to load the symbol file automatically when a new process is received.
      Load_Symbols : Boolean := True;

      --  Enable the graphical mode (when available).
      Graphical    : Boolean := False;

      --  Print the events as they are received.
      Print_Events : Boolean := False;

      --  Define the server listening address.
      Address      : GNAT.Sockets.Sock_Addr_Type := (Port => 4096, others => <>);
   end record;

   type Target_Process_Type is new Ada.Finalization.Limited_Controlled with record
      Pid     : MAT.Types.Target_Process_Ref;
      Endian  : MAT.Readers.Endian_Type := MAT.Readers.LITTLE_ENDIAN;
      Path    : Ada.Strings.Unbounded.Unbounded_String;
      Memory  : MAT.Memory.Targets.Target_Memory;
      Symbols : MAT.Symbols.Targets.Target_Symbols_Ref;
      Events  : MAT.Events.Targets.Target_Events_Access;
      Console : MAT.Consoles.Console_Access;
   end record;
   type Target_Process_Type_Access is access all Target_Process_Type'Class;

   --  Release the target process instance.
   overriding
   procedure Finalize (Target : in out Target_Process_Type);

   type Target_Type is new Ada.Finalization.Limited_Controlled
     and MAT.Events.Probes.Reader_List_Type with private;

   type Target_Type_Access is access all Target_Type'Class;

   --  Get the console instance.
   function Console (Target : in Target_Type) return MAT.Consoles.Console_Access;

   --  Set the console instance.
   procedure Console (Target  : in out Target_Type;
                      Console : in MAT.Consoles.Console_Access);

   --  Get the current process instance.
   function Process (Target : in Target_Type) return Target_Process_Type_Access;

   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   overriding
   procedure Initialize (Target : in out Target_Type;
                         Reader : in out MAT.Events.Probes.Probe_Manager_Type'Class);

   --  Create a process instance to hold and keep track of memory and other information about
   --  the given process ID.
   procedure Create_Process (Target  : in out Target_Type;
                             Pid     : in MAT.Types.Target_Process_Ref;
                             Path    : in Ada.Strings.Unbounded.Unbounded_String;
                             Process : out Target_Process_Type_Access);

   --  Find the process instance from the process ID.
   function Find_Process (Target : in Target_Type;
                          Pid    : in MAT.Types.Target_Process_Ref)
                          return Target_Process_Type_Access;

   --  Iterate over the list of connected processes and execute the <tt>Process</tt> procedure.
   procedure Iterator (Target  : in Target_Type;
                       Process : access procedure (Proc : in Target_Process_Type'Class));

   --  Parse the command line arguments and configure the target instance.
   procedure Initialize_Options (Target  : in out Target_Type);

   --  Enter in the interactive loop reading the commands from the standard input
   --  and executing the commands.
   procedure Interactive (Target : in out MAT.Targets.Target_Type);

   --  Start the server to listen to MAT event socket streams.
   procedure Start (Target : in out Target_Type);

   --  Stop the server thread.
   procedure Stop (Target : in out Target_Type);

   --  Convert the string to a socket address.  The string can have two forms:
   --     port
   --     host:port
   function To_Sock_Addr_Type (Param : in String) return GNAT.Sockets.Sock_Addr_Type;

   --  Print the application usage.
   procedure Usage;

private

   --  Define a map of <tt>Target_Process_Type_Access</tt> keyed by the process Id.
   --  This map allows to retrieve the information about a process.
   use type MAT.Types.Target_Process_Ref;
   package Process_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Process_Ref,
                                      Element_Type => Target_Process_Type_Access);

   subtype Process_Map is Process_Maps.Map;
   subtype Process_Cursor is Process_Maps.Cursor;

   type Target_Type is new Ada.Finalization.Limited_Controlled
     and MAT.Events.Probes.Reader_List_Type with record
      Current   : Target_Process_Type_Access;
      Processes : Process_Map;
      Console   : MAT.Consoles.Console_Access;
      Options   : Options_Type;
      Server    : MAT.Readers.Streams.Sockets.Socket_Listener_Type;
   end record;

   --  Release the storage used by the target object.
   overriding
   procedure Finalize (Target : in out Target_Type);

end MAT.Targets;

Declare the Finalize procedure

Declare the Finalize procedure


-----------------------------------------------------------------------
--  util-encoders-hmac-sha1 -- Compute HMAC-SHA256 authentication code
--  Copyright (C) 2017, 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.Encoders.Base16;
with Util.Encoders.Base64;

package body Util.Encoders.HMAC.SHA256 is

   --  ------------------------------
   --  Sign the data string with the key and return the HMAC-SHA256 code in binary.
   --  ------------------------------
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA256.Hash_Array is
      Ctx    : Context;
      Result : Util.Encoders.SHA256.Hash_Array;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish (Ctx, Result);
      return Result;
   end Sign;

   --  ------------------------------
   --  Sign the data array with the key and return the HMAC-SHA256 code in the result.
   --  ------------------------------
   procedure Sign (Key    : in Ada.Streams.Stream_Element_Array;
                   Data   : in Ada.Streams.Stream_Element_Array;
                   Result : out Util.Encoders.SHA256.Hash_Array) is
      Ctx    : Context;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish (Ctx, Result);
   end Sign;

   procedure Sign (Key    : in Secret_Key;
                   Data   : in Ada.Streams.Stream_Element_Array;
                   Result : out Util.Encoders.SHA256.Hash_Array) is
   begin
      Sign (Key.Secret, Data, Result);
   end Sign;

   --  ------------------------------
   --  Sign the data string with the key and return the HMAC-SHA256 code as hexadecimal string.
   --  ------------------------------
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA256.Digest is
      Ctx    : Context;
      Result : Util.Encoders.SHA256.Digest;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish (Ctx, Result);
      return Result;
   end Sign;

   --  ------------------------------
   --  Sign the data string with the key and return the HMAC-SHA256 code as base64 string.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   --  ------------------------------
   function Sign_Base64 (Key  : in String;
                         Data : in String;
                         URL  : in Boolean := False) return Util.Encoders.SHA256.Base64_Digest is
      Ctx    : Context;
      Result : Util.Encoders.SHA256.Base64_Digest;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish_Base64 (Ctx, Result, URL);
      return Result;
   end Sign_Base64;

   --  ------------------------------
   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   --  ------------------------------
   procedure Set_Key (E   : in out Context;
                      Key : in String) is
      Buf : Ada.Streams.Stream_Element_Array (1 .. Key'Length);
      for Buf'Address use Key'Address;
      pragma Import (Ada, Buf);

   begin
      Set_Key (E, Buf);
   end Set_Key;

   IPAD : constant Ada.Streams.Stream_Element := 16#36#;
   OPAD : constant Ada.Streams.Stream_Element := 16#5c#;

   --  ------------------------------
   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   --  ------------------------------
   procedure Set_Key (E   : in out Context;
                      Key : in Ada.Streams.Stream_Element_Array) is
   begin
      --  Reduce the key
      if Key'Length > 64 then
         Util.Encoders.SHA256.Update (E.SHA, Key);
         Util.Encoders.SHA256.Finish (E.SHA, E.Key (0 .. 31));
         E.Key_Len := 31;
      else
         E.Key_Len := Key'Length - 1;
         E.Key (0 .. E.Key_Len) := Key;
      end if;

      --  Hash the key in the SHA256 context.
      declare
         Block : Ada.Streams.Stream_Element_Array (0 .. 63);
      begin
         for I in 0 .. E.Key_Len loop
            Block (I) := IPAD xor E.Key (I);
         end loop;
         for I in E.Key_Len + 1 .. 63 loop
            Block (I) := IPAD;
         end loop;
         Util.Encoders.SHA256.Update (E.SHA, Block);
      end;
   end Set_Key;

   --  ------------------------------
   --  Update the hash with the string.
   --  ------------------------------
   procedure Update (E : in out Context;
                     S : in String) is
   begin
      Util.Encoders.SHA256.Update (E.SHA, S);
   end Update;

   --  ------------------------------
   --  Update the hash with the string.
   --  ------------------------------
   procedure Update (E : in out Context;
                     S : in Ada.Streams.Stream_Element_Array) is
   begin
      Util.Encoders.SHA256.Update (E.SHA, S);
   end Update;

   --  ------------------------------
   --  Computes the HMAC-SHA256 with the private key and the data collected by
   --  the Update procedures.  Returns the raw binary hash in Hash.
   --  ------------------------------
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA256.Hash_Array) is
   begin
      Util.Encoders.SHA256.Finish (E.SHA, Hash);

      --  Hash the key in the SHA256 context.
      declare
         Block : Ada.Streams.Stream_Element_Array (0 .. 63);
      begin
         for I in 0 .. E.Key_Len loop
            Block (I) := OPAD xor E.Key (I);
         end loop;
         if E.Key_Len < 63 then
            for I in E.Key_Len + 1 .. 63 loop
               Block (I) := OPAD;
            end loop;
         end if;
         Util.Encoders.SHA256.Update (E.SHA, Block);
      end;
      Util.Encoders.SHA256.Update (E.SHA, Hash);
      Util.Encoders.SHA256.Finish (E.SHA, Hash);
   end Finish;

   --  ------------------------------
   --  Computes the HMAC-SHA256 with the private key and the data collected by
   --  the Update procedures.  Returns the hexadecimal hash in Hash.
   --  ------------------------------
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA256.Digest) is
      H       : Util.Encoders.SHA256.Hash_Array;
      B       : Util.Encoders.Base16.Encoder;
   begin
      Finish (E, H);
      B.Convert (H, Hash);
   end Finish;

   --  ------------------------------
   --  Computes the HMAC-SHA256 with the private key and the data collected by
   --  the Update procedures.  Returns the base64 hash in Hash.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   --  ------------------------------
   procedure Finish_Base64 (E    : in out Context;
                            Hash : out Util.Encoders.SHA256.Base64_Digest;
                            URL  : in Boolean := False) is
      H       : Util.Encoders.SHA256.Hash_Array;
      B       : Util.Encoders.Base64.Encoder;
   begin
      Finish (E, H);
      B.Set_URL_Mode (URL);
      B.Convert (H, Hash);
   end Finish_Base64;

   --  Initialize the SHA-1 context.
   overriding
   procedure Initialize (E : in out Context) is
   begin
      null;
   end Initialize;

end Util.Encoders.HMAC.SHA256;

-----------------------------------------------------------------------
--  util-encoders-hmac-sha1 -- Compute HMAC-SHA256 authentication code
--  Copyright (C) 2017, 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.Encoders.Base16;
with Util.Encoders.Base64;

package body Util.Encoders.HMAC.SHA256 is

   --  ------------------------------
   --  Sign the data string with the key and return the HMAC-SHA256 code in binary.
   --  ------------------------------
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA256.Hash_Array is
      Ctx    : Context;
      Result : Util.Encoders.SHA256.Hash_Array;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish (Ctx, Result);
      return Result;
   end Sign;

   --  ------------------------------
   --  Sign the data array with the key and return the HMAC-SHA256 code in the result.
   --  ------------------------------
   procedure Sign (Key    : in Ada.Streams.Stream_Element_Array;
                   Data   : in Ada.Streams.Stream_Element_Array;
                   Result : out Util.Encoders.SHA256.Hash_Array) is
      Ctx    : Context;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish (Ctx, Result);
   end Sign;

   procedure Sign (Key    : in Secret_Key;
                   Data   : in Ada.Streams.Stream_Element_Array;
                   Result : out Util.Encoders.SHA256.Hash_Array) is
   begin
      Sign (Key.Secret, Data, Result);
   end Sign;

   --  ------------------------------
   --  Sign the data string with the key and return the HMAC-SHA256 code as hexadecimal string.
   --  ------------------------------
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA256.Digest is
      Ctx    : Context;
      Result : Util.Encoders.SHA256.Digest;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish (Ctx, Result);
      return Result;
   end Sign;

   --  ------------------------------
   --  Sign the data string with the key and return the HMAC-SHA256 code as base64 string.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   --  ------------------------------
   function Sign_Base64 (Key  : in String;
                         Data : in String;
                         URL  : in Boolean := False) return Util.Encoders.SHA256.Base64_Digest is
      Ctx    : Context;
      Result : Util.Encoders.SHA256.Base64_Digest;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish_Base64 (Ctx, Result, URL);
      return Result;
   end Sign_Base64;

   --  ------------------------------
   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   --  ------------------------------
   procedure Set_Key (E   : in out Context;
                      Key : in String) is
      Buf : Ada.Streams.Stream_Element_Array (1 .. Key'Length);
      for Buf'Address use Key'Address;
      pragma Import (Ada, Buf);

   begin
      Set_Key (E, Buf);
   end Set_Key;

   IPAD : constant Ada.Streams.Stream_Element := 16#36#;
   OPAD : constant Ada.Streams.Stream_Element := 16#5c#;

   --  ------------------------------
   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   --  ------------------------------
   procedure Set_Key (E   : in out Context;
                      Key : in Ada.Streams.Stream_Element_Array) is
   begin
      --  Reduce the key
      if Key'Length > 64 then
         Util.Encoders.SHA256.Update (E.SHA, Key);
         Util.Encoders.SHA256.Finish (E.SHA, E.Key (0 .. 31));
         E.Key_Len := 31;
      else
         E.Key_Len := Key'Length - 1;
         E.Key (0 .. E.Key_Len) := Key;
      end if;

      --  Hash the key in the SHA256 context.
      declare
         Block : Ada.Streams.Stream_Element_Array (0 .. 63);
      begin
         for I in 0 .. E.Key_Len loop
            Block (I) := IPAD xor E.Key (I);
         end loop;
         for I in E.Key_Len + 1 .. 63 loop
            Block (I) := IPAD;
         end loop;
         Util.Encoders.SHA256.Update (E.SHA, Block);
      end;
   end Set_Key;

   procedure Set_Key (E   : in out Context;
                      Key : in Secret_Key) is
   begin
      Set_Key (E, Key.Secret);
   end Set_Key;

   --  ------------------------------
   --  Update the hash with the string.
   --  ------------------------------
   procedure Update (E : in out Context;
                     S : in String) is
   begin
      Util.Encoders.SHA256.Update (E.SHA, S);
   end Update;

   --  ------------------------------
   --  Update the hash with the string.
   --  ------------------------------
   procedure Update (E : in out Context;
                     S : in Ada.Streams.Stream_Element_Array) is
   begin
      Util.Encoders.SHA256.Update (E.SHA, S);
   end Update;

   --  ------------------------------
   --  Update the hash with the secret key.
   --  ------------------------------
   procedure Update (E : in out Context;
                     S : in Secret_Key) is
   begin
      Update (E, S.Secret);
   end Update;

   --  ------------------------------
   --  Computes the HMAC-SHA256 with the private key and the data collected by
   --  the Update procedures.  Returns the raw binary hash in Hash.
   --  ------------------------------
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA256.Hash_Array) is
   begin
      Util.Encoders.SHA256.Finish (E.SHA, Hash);

      --  Hash the key in the SHA256 context.
      declare
         Block : Ada.Streams.Stream_Element_Array (0 .. 63);
      begin
         for I in 0 .. E.Key_Len loop
            Block (I) := OPAD xor E.Key (I);
         end loop;
         if E.Key_Len < 63 then
            for I in E.Key_Len + 1 .. 63 loop
               Block (I) := OPAD;
            end loop;
         end if;
         Util.Encoders.SHA256.Update (E.SHA, Block);
      end;
      Util.Encoders.SHA256.Update (E.SHA, Hash);
      Util.Encoders.SHA256.Finish (E.SHA, Hash);
   end Finish;

   --  ------------------------------
   --  Computes the HMAC-SHA256 with the private key and the data collected by
   --  the Update procedures.  Returns the hexadecimal hash in Hash.
   --  ------------------------------
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA256.Digest) is
      H       : Util.Encoders.SHA256.Hash_Array;
      B       : Util.Encoders.Base16.Encoder;
   begin
      Finish (E, H);
      B.Convert (H, Hash);
   end Finish;

   --  ------------------------------
   --  Computes the HMAC-SHA256 with the private key and the data collected by
   --  the Update procedures.  Returns the base64 hash in Hash.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   --  ------------------------------
   procedure Finish_Base64 (E    : in out Context;
                            Hash : out Util.Encoders.SHA256.Base64_Digest;
                            URL  : in Boolean := False) is
      H       : Util.Encoders.SHA256.Hash_Array;
      B       : Util.Encoders.Base64.Encoder;
   begin
      Finish (E, H);
      B.Set_URL_Mode (URL);
      B.Convert (H, Hash);
   end Finish_Base64;

   --  Initialize the SHA-1 context.
   overriding
   procedure Initialize (E : in out Context) is
   begin
      null;
   end Initialize;

end Util.Encoders.HMAC.SHA256;

Implement Set_Key and Update procedures

Implement Set_Key and Update procedures


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 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.

private with Ada.Finalization;

private with GL.Objects.Vertex_Arrays;
private with GL.Types;

private with Orka.Inputs.Pointers;

private with Glfw.Windows;
private with Glfw.Input.Keys;
private with Glfw.Input.Mouse;

with Orka.Contexts;

package Orka.Windows.GLFW is

   type GLFW_Context is limited new Contexts.Surface_Context with private;

   overriding
   function Create_Context
     (Version : Contexts.Context_Version;
      Flags   : Contexts.Context_Flags := (others => False)) return GLFW_Context;

   type GLFW_Window is limited new Window with private;

   overriding
   procedure Set_Title (Object : in out GLFW_Window; Value : String);

   overriding
   function Should_Close (Object : GLFW_Window) return Boolean;

   overriding
   function Create_Window
     (Context            : Contexts.Surface_Context'Class;
      Width, Height      : Positive;
      Title              : String  := "";
      Samples            : Natural := 0;
      Visible, Resizable : Boolean := True;
      Transparent        : Boolean := False) return GLFW_Window
   with Pre => Context in GLFW_Context'Class;

private

   type GLFW_Context is
     limited new Ada.Finalization.Limited_Controlled and Contexts.Surface_Context with
   record
      Version  : Contexts.Context_Version;
      Flags    : Contexts.Context_Flags;
      Features : Contexts.Feature_Array := (others => False);
   end record;

   overriding
   procedure Finalize (Object : in out GLFW_Context);

   overriding
   procedure Enable (Object : in out GLFW_Context; Subject : Contexts.Feature);

   overriding
   function Enabled (Object : GLFW_Context; Subject : Contexts.Feature) return Boolean;

   overriding
   function Version (Object : GLFW_Context) return Contexts.Context_Version;

   overriding
   function Flags (Object : GLFW_Context) return Contexts.Context_Flags;

   overriding
   function Is_Current (Object : GLFW_Context; Kind : Orka.Contexts.Task_Kind) return Boolean;

   overriding
   procedure Make_Current (Object : GLFW_Context);

   overriding
   procedure Make_Current
     (Object : GLFW_Context;
      Window : in out Orka.Windows.Window'Class);

   overriding
   procedure Make_Not_Current (Object : GLFW_Context);

   type GLFW_Window is limited new Standard.Glfw.Windows.Window and Window with record
      Input     : Inputs.Pointers.Pointer_Input_Ptr;
      Finalized : Boolean;

      Vertex_Array : GL.Objects.Vertex_Arrays.Vertex_Array_Object;

      Position_X : GL.Types.Double := 0.0;
      Position_Y : GL.Types.Double := 0.0;
      Scroll_X   : GL.Types.Double := 0.0;
      Scroll_Y   : GL.Types.Double := 0.0;
      Width, Height : Positive;

      --  Needed to workaround a GLFW bug
      Got_Locked, Last_Locked : Boolean := False;
   end record;

   overriding
   function Pointer_Input
     (Object : GLFW_Window) return Inputs.Pointers.Pointer_Input_Ptr;

   overriding
   function Width (Object : GLFW_Window) return Positive;

   overriding
   function Height (Object : GLFW_Window) return Positive;

   overriding
   procedure Close (Object : in out GLFW_Window);

   overriding
   procedure Process_Input (Object : in out GLFW_Window);

   overriding
   procedure Swap_Buffers (Object : in out GLFW_Window);

   overriding
   procedure Set_Vertical_Sync (Object : in out GLFW_Window; Enable : Boolean);

   overriding
   procedure Finalize (Object : in out GLFW_Window);

   overriding
   procedure Close_Requested (Object : not null access GLFW_Window);

   overriding
   procedure Key_Changed
     (Object   : not null access GLFW_Window;
      Key      : Standard.Glfw.Input.Keys.Key;
      Scancode : Standard.Glfw.Input.Keys.Scancode;
      Action   : Standard.Glfw.Input.Keys.Action;
      Mods     : Standard.Glfw.Input.Keys.Modifiers);

   overriding
   procedure Mouse_Position_Changed
     (Object : not null access GLFW_Window;
      X, Y   : Standard.Glfw.Input.Mouse.Coordinate);

   overriding
   procedure Mouse_Scrolled
     (Object : not null access GLFW_Window;
      X, Y   : Standard.Glfw.Input.Mouse.Scroll_Offset);

   overriding
   procedure Mouse_Button_Changed
     (Object  : not null access GLFW_Window;
      Button  : Standard.Glfw.Input.Mouse.Button;
      State   : Standard.Glfw.Input.Button_State;
      Mods    : Standard.Glfw.Input.Keys.Modifiers);

   overriding
   procedure Framebuffer_Size_Changed
     (Object : not null access GLFW_Window;
      Width, Height : Natural);

end Orka.Windows.GLFW;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 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.

private with Ada.Finalization;

private with GL.Objects.Vertex_Arrays;
private with GL.Types;

private with Orka.Inputs.Pointers;

private with Glfw.Windows;
private with Glfw.Input.Keys;
private with Glfw.Input.Mouse;

with Orka.Contexts;

package Orka.Windows.GLFW is
   pragma Preelaborate;

   type GLFW_Context is limited new Contexts.Surface_Context with private;

   overriding
   function Create_Context
     (Version : Contexts.Context_Version;
      Flags   : Contexts.Context_Flags := (others => False)) return GLFW_Context;

   type GLFW_Window is limited new Window with private;

   overriding
   procedure Set_Title (Object : in out GLFW_Window; Value : String);

   overriding
   function Should_Close (Object : GLFW_Window) return Boolean;

   overriding
   function Create_Window
     (Context            : Contexts.Surface_Context'Class;
      Width, Height      : Positive;
      Title              : String  := "";
      Samples            : Natural := 0;
      Visible, Resizable : Boolean := True;
      Transparent        : Boolean := False) return GLFW_Window
   with Pre => Context in GLFW_Context'Class;

private

   type GLFW_Context is
     limited new Ada.Finalization.Limited_Controlled and Contexts.Surface_Context with
   record
      Version  : Contexts.Context_Version;
      Flags    : Contexts.Context_Flags;
      Features : Contexts.Feature_Array := (others => False);
   end record;

   overriding
   procedure Finalize (Object : in out GLFW_Context);

   overriding
   procedure Enable (Object : in out GLFW_Context; Subject : Contexts.Feature);

   overriding
   function Enabled (Object : GLFW_Context; Subject : Contexts.Feature) return Boolean;

   overriding
   function Version (Object : GLFW_Context) return Contexts.Context_Version;

   overriding
   function Flags (Object : GLFW_Context) return Contexts.Context_Flags;

   overriding
   function Is_Current (Object : GLFW_Context; Kind : Orka.Contexts.Task_Kind) return Boolean;

   overriding
   procedure Make_Current (Object : GLFW_Context);

   overriding
   procedure Make_Current
     (Object : GLFW_Context;
      Window : in out Orka.Windows.Window'Class);

   overriding
   procedure Make_Not_Current (Object : GLFW_Context);

   type GLFW_Window is limited new Standard.Glfw.Windows.Window and Window with record
      Input     : Inputs.Pointers.Pointer_Input_Ptr;
      Finalized : Boolean;

      Vertex_Array : GL.Objects.Vertex_Arrays.Vertex_Array_Object;

      Position_X : GL.Types.Double := 0.0;
      Position_Y : GL.Types.Double := 0.0;
      Scroll_X   : GL.Types.Double := 0.0;
      Scroll_Y   : GL.Types.Double := 0.0;
      Width, Height : Positive;

      --  Needed to workaround a GLFW bug
      Got_Locked, Last_Locked : Boolean := False;
   end record;

   overriding
   function Pointer_Input
     (Object : GLFW_Window) return Inputs.Pointers.Pointer_Input_Ptr;

   overriding
   function Width (Object : GLFW_Window) return Positive;

   overriding
   function Height (Object : GLFW_Window) return Positive;

   overriding
   procedure Close (Object : in out GLFW_Window);

   overriding
   procedure Process_Input (Object : in out GLFW_Window);

   overriding
   procedure Swap_Buffers (Object : in out GLFW_Window);

   overriding
   procedure Set_Vertical_Sync (Object : in out GLFW_Window; Enable : Boolean);

   overriding
   procedure Finalize (Object : in out GLFW_Window);

   overriding
   procedure Close_Requested (Object : not null access GLFW_Window);

   overriding
   procedure Key_Changed
     (Object   : not null access GLFW_Window;
      Key      : Standard.Glfw.Input.Keys.Key;
      Scancode : Standard.Glfw.Input.Keys.Scancode;
      Action   : Standard.Glfw.Input.Keys.Action;
      Mods     : Standard.Glfw.Input.Keys.Modifiers);

   overriding
   procedure Mouse_Position_Changed
     (Object : not null access GLFW_Window;
      X, Y   : Standard.Glfw.Input.Mouse.Coordinate);

   overriding
   procedure Mouse_Scrolled
     (Object : not null access GLFW_Window;
      X, Y   : Standard.Glfw.Input.Mouse.Scroll_Offset);

   overriding
   procedure Mouse_Button_Changed
     (Object  : not null access GLFW_Window;
      Button  : Standard.Glfw.Input.Mouse.Button;
      State   : Standard.Glfw.Input.Button_State;
      Mods    : Standard.Glfw.Input.Keys.Modifiers);

   overriding
   procedure Framebuffer_Size_Changed
     (Object : not null access GLFW_Window;
      Width, Height : Natural);

end Orka.Windows.GLFW;

glfw: Make package Orka.Windows.GLFW preelaborated

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


-----------------------------------------------------------------------
--  druss-config -- Configuration management for Druss
--  Copyright (C) 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.Environment_Variables;
with Ada.Directories;
with Ada.Strings.Unbounded;
with Util.Files;
with Util.Properties;
package body Druss.Config is

   Cfg      : Util.Properties.Manager;
   Cfg_Path : Ada.Strings.Unbounded.Unbounded_String;

   --  ------------------------------
   --  Initialize the configuration.
   --  ------------------------------
   procedure Initialize (Path : in String) is
      Home     : constant String := Ada.Environment_Variables.Value ("HOME");
      Def_Path : constant String := Util.Files.Compose (Home, ".config/druss/druss.properties");
   begin
      if Path'Length > 0 and then Ada.Directories.Exists (Path) then
         Cfg.Load_Properties (Path);
         Cfg_Path := Ada.Strings.Unbounded.To_Unbounded_String (Path);
      elsif Ada.Directories.Exists (Def_Path) then
         Cfg.Load_Properties (Def_Path);
         Cfg_Path := Ada.Strings.Unbounded.To_Unbounded_String (Def_Path);
      end if;
   end Initialize;

   --  ------------------------------
   --  Get the configuration parameter.
   --  ------------------------------
   function Get (Name : in String) return String is
   begin
      return Cfg.Get (Name);
   end Get;

   --  ------------------------------
   --  Initalize the list of gateways from the configuration file.
   --  ------------------------------
   procedure Get_Gateways (List   : in out Druss.Gateways.Gateway_Vector) is
   begin
      Druss.Gateways.Initialize (Cfg, List);
   end Get_Gateways;

end Druss.Config;

-----------------------------------------------------------------------
--  druss-config -- Configuration management for Druss
--  Copyright (C) 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.Environment_Variables;
with Ada.Directories;
with Ada.Strings.Unbounded;
with Util.Files;
with Util.Properties;
package body Druss.Config is

   Cfg      : Util.Properties.Manager;
   Cfg_Path : Ada.Strings.Unbounded.Unbounded_String;

   --  ------------------------------
   --  Initialize the configuration.
   --  ------------------------------
   procedure Initialize (Path : in String) is
      Home     : constant String := Ada.Environment_Variables.Value ("HOME");
      Def_Path : constant String := Util.Files.Compose (Home, ".config/druss/druss.properties");
   begin
      if Path'Length > 0 and then Ada.Directories.Exists (Path) then
         Cfg.Load_Properties (Path);
         Cfg_Path := Ada.Strings.Unbounded.To_Unbounded_String (Path);
      elsif Ada.Directories.Exists (Def_Path) then
         Cfg.Load_Properties (Def_Path);
         Cfg_Path := Ada.Strings.Unbounded.To_Unbounded_String (Def_Path);
      end if;
   end Initialize;

   procedure Save is
      Path : constant String := Ada.Strings.Unbounded.To_String (Cfg_Path);
   begin
      if not Ada.Directories.Exists (Path) then
         Ada.Directories.Create_Path (Ada.Directories.Containing_Directory (Path));
      end if;
      Cfg.Save_Properties (Path);
   end Save;

   --  ------------------------------
   --  Get the configuration parameter.
   --  ------------------------------
   function Get (Name : in String) return String is
   begin
      return Cfg.Get (Name);
   end Get;

   --  ------------------------------
   --  Initalize the list of gateways from the configuration file.
   --  ------------------------------
   procedure Get_Gateways (List   : in out Druss.Gateways.Gateway_Vector) is
   begin
      Druss.Gateways.Initialize (Cfg, List);
   end Get_Gateways;

   --  ------------------------------
   --  Save the list of gateways.
   --  ------------------------------
   procedure Save_Gateways (List  : in Druss.Gateways.Gateway_Vector) is
   begin
      Druss.Gateways.Save_Gateways (Cfg, List);
      Save;
   end Save_Gateways;

end Druss.Config;

Implement the Save_Gateways procedure

Implement the Save_Gateways procedure


-----------------------------------------------------------------------
--  html-selects -- ASF HTML UISelectOne and UISelectMany components
--  Copyright (C) 2011, 2013, 2014 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.Strings;
with ASF.Utils;
package body ASF.Components.Html.Selects is

   --  ------------------------------
   --  UISelectItem Component
   --  ------------------------------

   ITEM_LABEL_NAME       : constant String := "itemLabel";
   ITEM_VALUE_NAME       : constant String := "itemValue";
   ITEM_DESCRIPTION_NAME : constant String := "itemDescription";
   ITEM_DISABLED_NAME    : constant String := "itemDisabled";

   SELECT_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   --  ------------------------------
   --  UISelectBoolean Component
   --  ------------------------------
   --  Render the checkbox element.
   overriding
   procedure Render_Input (UI       : in UISelectBoolean;
                           Context  : in out Faces_Context'Class;
                           Write_Id : in Boolean := True) is
      use ASF.Components.Html.Forms;

      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
      Value  : constant EL.Objects.Object := UIInput'Class (UI).Get_Value;
   begin
      Writer.Start_Element ("input");
      Writer.Write_Attribute (Name => "type", Value => "checkbox");
      UI.Render_Attributes (Context, SELECT_ATTRIBUTE_NAMES, Writer, Write_Id);
      Writer.Write_Attribute (Name => "name", Value => UI.Get_Client_Id);
      if not EL.Objects.Is_Null (Value) and then EL.Objects.To_Boolean (Value) then
         Writer.Write_Attribute (Name => "checked", Value => "true");
      end if;
      Writer.End_Element ("input");
   end Render_Input;

   --  ------------------------------
   --  Convert the string into a value.  If a converter is specified on the component,
   --  use it to convert the value.  Make sure the result is a boolean.
   --  ------------------------------
   overriding
   function Convert_Value (UI      : in UISelectBoolean;
                           Value   : in String;
                           Context : in Faces_Context'Class) return EL.Objects.Object is
      use type EL.Objects.Data_Type;

      Result : constant EL.Objects.Object := Forms.UIInput (UI).Convert_Value (Value, Context);
   begin
      case EL.Objects.Get_Type (Result) is
         when EL.Objects.TYPE_BOOLEAN =>
            return Result;

         when EL.Objects.TYPE_INTEGER =>
            return EL.Objects.To_Object (EL.Objects.To_Boolean (Result));

         when others =>
            if Value = "on" then
               return EL.Objects.To_Object (True);
            else
               return EL.Objects.To_Object (False);
            end if;

      end case;
   end Convert_Value;

   --  ------------------------------
   --  Iterator over the Select_Item elements
   --  ------------------------------

   --  ------------------------------
   --  Get an iterator to scan the component children.
   --  ------------------------------
   procedure First (UI       : in UISelectOne'Class;
                    Context  : in Faces_Context'Class;
                    Iterator : out Cursor) is
   begin
      Iterator.Component := UI.First;
      Iterator.Pos       := 0;
      Iterator.Last      := 0;
      while ASF.Components.Base.Has_Element (Iterator.Component) loop
         Iterator.Current := ASF.Components.Base.Element (Iterator.Component);
         if Iterator.Current.all in UISelectItem'Class then
            return;
         end if;
         if Iterator.Current.all in UISelectItems'Class then
            Iterator.List := UISelectItems'Class (Iterator.Current.all)
              .Get_Select_Item_List (Context);
            Iterator.Last := Iterator.List.Length;
            Iterator.Pos  := 1;
            if Iterator.Last > 0 then
               return;
            end if;
         end if;
         ASF.Components.Base.Next (Iterator.Component);
      end loop;
      Iterator.Pos := 0;
      Iterator.Current := null;
   end First;

   --  ------------------------------
   --  Returns True if the iterator points to a valid child.
   --  ------------------------------
   function Has_Element (Pos : in Cursor) return Boolean is
      use type ASF.Components.Base.UIComponent_Access;
   begin
      if Pos.Pos > 0 and Pos.Pos <= Pos.Last then
         return True;
      else
         return Pos.Current /= null;
      end if;
   end Has_Element;

   --  ------------------------------
   --  Get the child component pointed to by the iterator.
   --  ------------------------------
   function Element (Pos     : in Cursor;
                     Context : in Faces_Context'Class) return ASF.Models.Selects.Select_Item is
   begin
      if Pos.Pos > 0 and Pos.Pos <= Pos.Last then
         return Pos.List.Get_Select_Item (Pos.Pos);
      else
         return UISelectItem'Class (Pos.Current.all).Get_Select_Item (Context);
      end if;
   end Element;

   --  ------------------------------
   --  Move to the next child.
   --  ------------------------------
   procedure Next (Pos     : in out Cursor;
                   Context : in Faces_Context'Class) is
   begin
      if Pos.Pos > 0 and Pos.Pos < Pos.Last then
         Pos.Pos := Pos.Pos + 1;
      else
         Pos.Pos := 0;
         loop
            Pos.Current := null;
            ASF.Components.Base.Next (Pos.Component);
            exit when not ASF.Components.Base.Has_Element (Pos.Component);
            Pos.Current := ASF.Components.Base.Element (Pos.Component);
            exit when Pos.Current.all in UISelectItem'Class;
            if Pos.Current.all in UISelectItems'Class then
               Pos.List := UISelectItems'Class (Pos.Current.all).Get_Select_Item_List (Context);
               Pos.Last := Pos.List.Length;
               Pos.Pos  := 1;
               exit when Pos.Last > 0;
               Pos.Pos := 0;
            end if;
         end loop;
      end if;
   end Next;

   --  ------------------------------
   --  Get the Select_Item represented by the component.
   --  ------------------------------
   function Get_Select_Item (From    : in UISelectItem;
                             Context : in Faces_Context'Class)
                             return ASF.Models.Selects.Select_Item is
      use Util.Beans.Objects;

      Val : constant Object := From.Get_Attribute (Name    => VALUE_NAME,
                                                   Context => Context);
   begin
      if not Is_Null (Val) then
         return ASF.Models.Selects.To_Select_Item (Val);
      end if;
      declare
         Label       : constant Object := From.Get_Attribute (Name    => ITEM_LABEL_NAME,
                                                              Context => Context);
         Value       : constant Object := From.Get_Attribute (Name    => ITEM_VALUE_NAME,
                                                              Context => Context);
         Description : constant Object := From.Get_Attribute (Name    => ITEM_DESCRIPTION_NAME,
                                                              Context => Context);
         Disabled    : constant Boolean := From.Get_Attribute (Name   => ITEM_DISABLED_NAME,
                                                               Context => Context);
      begin
         if Is_Null (Label) then
            return ASF.Models.Selects.Create_Select_Item (Value, Value, Description, Disabled);
         else
            return ASF.Models.Selects.Create_Select_Item (Label, Value, Description, Disabled);
         end if;
      end;
   end Get_Select_Item;

   --  ------------------------------
   --  UISelectItems Component
   --  ------------------------------

   --  ------------------------------
   --  Get the Select_Item represented by the component.
   --  ------------------------------
   function Get_Select_Item_List (From : in UISelectItems;
                                  Context : in Faces_Context'Class)
                                     return ASF.Models.Selects.Select_Item_List is
      use Util.Beans.Objects;

      Value : constant Object := From.Get_Attribute (Name    => VALUE_NAME,
                                                     Context => Context);
   begin
      return ASF.Models.Selects.To_Select_Item_List (Value);
   end Get_Select_Item_List;

   --  ------------------------------
   --  SelectOne Component
   --  ------------------------------

   --  ------------------------------
   --  Render the select element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UISelectOne;
                           Context : in out Faces_Context'Class) is
   begin
      if UI.Is_Rendered (Context) then
         UISelectOne'Class (UI).Render_Select (Context);
      end if;
   end Encode_Begin;

   --  ------------------------------
   --  Renders the select element.  This is called by Encode_Begin if
   --  the component is rendered.
   --  ------------------------------
   procedure Render_Select (UI      : in UISelectOne;
                            Context : in out Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
      Value  : constant EL.Objects.Object := UISelectOne'Class (UI).Get_Value;
   begin
      Writer.Start_Element ("select");
      Writer.Write_Attribute (Name => "name", Value => UI.Get_Client_Id);
      UI.Render_Attributes (Context, SELECT_ATTRIBUTE_NAMES, Writer);

      UISelectOne'Class (UI).Render_Options (Value, Context);
      Writer.End_Element ("select");
   end Render_Select;

   --  ------------------------------
   --  Renders the option element.  This is called by Render_Select to
   --  generate the component options.
   --  ------------------------------
   procedure Render_Options (UI      : in UISelectOne;
                             Value   : in Util.Beans.Objects.Object;
                             Context : in out Faces_Context'Class) is
      Writer   : constant Response_Writer_Access := Context.Get_Response_Writer;
      Selected : constant Wide_Wide_String := Util.Beans.Objects.To_Wide_Wide_String (Value);
      Iter     : Cursor;
   begin
      UI.First (Context, Iter);
      while Has_Element (Iter) loop
         declare
            Item       : constant ASF.Models.Selects.Select_Item := Element (Iter, Context);
            Item_Value : constant Wide_Wide_String := Item.Get_Value;
         begin
            Writer.Start_Element ("option");
            Writer.Write_Wide_Attribute ("value", Item_Value);
            if Item_Value = Selected then
               Writer.Write_Attribute ("selected", "selected");
            end if;
            if Item.Is_Escaped then
               Writer.Write_Wide_Text (Item.Get_Label);
            else
               Writer.Write_Wide_Text (Item.Get_Label);
            end if;
            Writer.End_Element ("option");
            Next (Iter, Context);
         end;
      end loop;
   end Render_Options;

   --  ------------------------------
   --  Returns True if the radio options must be rendered vertically.
   --  ------------------------------
   function Is_Vertical (UI      : in UISelectOneRadio;
                         Context : in Faces_Context'Class) return Boolean is
      Dir    : constant String := UI.Get_Attribute (Context => Context,
                                                    Name    => "layout",
                                                    Default => "");
   begin
      return Dir = "pageDirection";
   end Is_Vertical;

   --  ------------------------------
   --  Renders the select element.  This is called by Encode_Begin if
   --  the component is rendered.
   --  ------------------------------
   overriding
   procedure Render_Select (UI      : in UISelectOneRadio;
                            Context : in out Faces_Context'Class) is
      Writer   : constant Response_Writer_Access := Context.Get_Response_Writer;
      Value    : constant EL.Objects.Object := UISelectOne'Class (UI).Get_Value;
      Vertical : constant Boolean := UI.Is_Vertical (Context);
      Selected : constant Wide_Wide_String := Util.Beans.Objects.To_Wide_Wide_String (Value);
      Iter     : Cursor;
      Id       : constant String := To_String (UI.Get_Client_Id);
      N        : Natural := 0;

      Disabled_Class : constant EL.Objects.Object := UI.Get_Attribute (Context => Context,
                                                                       Name => "disabledClass");
      Enabled_Class  : constant EL.Objects.Object := UI.Get_Attribute (Context => Context,
                                                                       Name => "enabledClass");
   begin
      Writer.Start_Element ("table");
      UI.Render_Attributes (Context, Writer);

      if not Vertical then
         Writer.Start_Element ("tr");
      end if;

      UI.First (Context, Iter);
      while Has_Element (Iter) loop
         declare
            Item       : constant ASF.Models.Selects.Select_Item := Element (Iter, Context);
            Item_Value : constant Wide_Wide_String := Item.Get_Value;
         begin
            if Vertical then
               Writer.Start_Element ("tr");
            end if;
            Writer.Start_Element ("td");

            --  Render the input radio checkbox.
            Writer.Start_Element ("input");
            Writer.Write_Attribute ("type", "radio");
            if Item.Is_Disabled then
               Writer.Write_Attribute ("disabled", "disabled");
            end if;
            Writer.Write_Attribute ("id", Id & "_" & Util.Strings.Image (N));
            Writer.Write_Wide_Attribute ("value", Item_Value);
            if Item_Value = Selected then
               Writer.Write_Attribute ("checked", "checked");
            end if;
            Writer.End_Element ("input");

            --  Render the label associated with the checkbox.
            Writer.Start_Element ("label");
            if Item.Is_Disabled then
               if not Util.Beans.Objects.Is_Null (Disabled_Class) then
                  Writer.Write_Attribute ("class", Disabled_Class);
               end if;
            else
               if not Util.Beans.Objects.Is_Null (Enabled_Class) then
                  Writer.Write_Attribute ("class", Enabled_Class);
               end if;
            end if;

            Writer.Write_Attribute ("for", Id & "_" & Util.Strings.Image (N));
            if Item.Is_Escaped then
               Writer.Write_Wide_Text (Item.Get_Label);
            else
               Writer.Write_Wide_Text (Item.Get_Label);
            end if;
            Writer.End_Element ("label");

            Writer.End_Element ("td");
            if Vertical then
               Writer.End_Element ("tr");
            end if;

            Next (Iter, Context);
            N := N + 1;
         end;
      end loop;

      if not Vertical then
         Writer.End_Element ("tr");
      end if;
      Writer.End_Element ("table");
   end Render_Select;

begin
   ASF.Utils.Set_Text_Attributes (SELECT_ATTRIBUTE_NAMES);
   ASF.Utils.Set_Interactive_Attributes (SELECT_ATTRIBUTE_NAMES);
end ASF.Components.Html.Selects;

-----------------------------------------------------------------------
--  html-selects -- ASF HTML UISelectOne and UISelectMany components
--  Copyright (C) 2011, 2013, 2014, 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.
-----------------------------------------------------------------------

with Util.Strings;
with ASF.Utils;
package body ASF.Components.Html.Selects is

   --  ------------------------------
   --  UISelectItem Component
   --  ------------------------------

   ITEM_LABEL_NAME       : constant String := "itemLabel";
   ITEM_VALUE_NAME       : constant String := "itemValue";
   ITEM_DESCRIPTION_NAME : constant String := "itemDescription";
   ITEM_DISABLED_NAME    : constant String := "itemDisabled";

   SELECT_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   --  ------------------------------
   --  UISelectBoolean Component
   --  ------------------------------
   --  Render the checkbox element.
   overriding
   procedure Render_Input (UI       : in UISelectBoolean;
                           Context  : in out Faces_Context'Class;
                           Write_Id : in Boolean := True) is
      use ASF.Components.Html.Forms;

      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
      Value  : constant EL.Objects.Object := UIInput'Class (UI).Get_Value;
   begin
      Writer.Start_Element ("input");
      Writer.Write_Attribute (Name => "type", Value => "checkbox");
      UI.Render_Attributes (Context, SELECT_ATTRIBUTE_NAMES, Writer, Write_Id);
      Writer.Write_Attribute (Name => "name", Value => UI.Get_Client_Id);
      if not EL.Objects.Is_Null (Value) and then EL.Objects.To_Boolean (Value) then
         Writer.Write_Attribute (Name => "checked", Value => "true");
      end if;
      Writer.End_Element ("input");
   end Render_Input;

   --  ------------------------------
   --  Convert the string into a value.  If a converter is specified on the component,
   --  use it to convert the value.  Make sure the result is a boolean.
   --  ------------------------------
   overriding
   function Convert_Value (UI      : in UISelectBoolean;
                           Value   : in String;
                           Context : in Faces_Context'Class) return EL.Objects.Object is
      use type EL.Objects.Data_Type;

      Result : constant EL.Objects.Object := Forms.UIInput (UI).Convert_Value (Value, Context);
   begin
      case EL.Objects.Get_Type (Result) is
         when EL.Objects.TYPE_BOOLEAN =>
            return Result;

         when EL.Objects.TYPE_INTEGER =>
            return EL.Objects.To_Object (EL.Objects.To_Boolean (Result));

         when others =>
            if Value = "on" then
               return EL.Objects.To_Object (True);
            else
               return EL.Objects.To_Object (False);
            end if;

      end case;
   end Convert_Value;

   --  ------------------------------
   --  Iterator over the Select_Item elements
   --  ------------------------------

   --  ------------------------------
   --  Get an iterator to scan the component children.
   --  ------------------------------
   procedure First (UI       : in UISelectOne'Class;
                    Context  : in Faces_Context'Class;
                    Iterator : out Cursor) is
   begin
      Iterator.Component := UI.First;
      Iterator.Pos       := 0;
      Iterator.Last      := 0;
      while ASF.Components.Base.Has_Element (Iterator.Component) loop
         Iterator.Current := ASF.Components.Base.Element (Iterator.Component);
         if Iterator.Current.all in UISelectItem'Class then
            return;
         end if;
         if Iterator.Current.all in UISelectItems'Class then
            Iterator.List := UISelectItems'Class (Iterator.Current.all)
              .Get_Select_Item_List (Context);
            Iterator.Last := Iterator.List.Length;
            Iterator.Pos  := 1;
            if Iterator.Last > 0 then
               return;
            end if;
         end if;
         ASF.Components.Base.Next (Iterator.Component);
      end loop;
      Iterator.Pos := 0;
      Iterator.Current := null;
   end First;

   --  ------------------------------
   --  Returns True if the iterator points to a valid child.
   --  ------------------------------
   function Has_Element (Pos : in Cursor) return Boolean is
      use type ASF.Components.Base.UIComponent_Access;
   begin
      if Pos.Pos > 0 and Pos.Pos <= Pos.Last then
         return True;
      else
         return Pos.Current /= null;
      end if;
   end Has_Element;

   --  ------------------------------
   --  Get the child component pointed to by the iterator.
   --  ------------------------------
   function Element (Pos     : in Cursor;
                     Context : in Faces_Context'Class) return ASF.Models.Selects.Select_Item is
   begin
      if Pos.Pos > 0 and Pos.Pos <= Pos.Last then
         return Pos.List.Get_Select_Item (Pos.Pos);
      else
         return UISelectItem'Class (Pos.Current.all).Get_Select_Item (Context);
      end if;
   end Element;

   --  ------------------------------
   --  Move to the next child.
   --  ------------------------------
   procedure Next (Pos     : in out Cursor;
                   Context : in Faces_Context'Class) is
   begin
      if Pos.Pos > 0 and Pos.Pos < Pos.Last then
         Pos.Pos := Pos.Pos + 1;
      else
         Pos.Pos := 0;
         loop
            Pos.Current := null;
            ASF.Components.Base.Next (Pos.Component);
            exit when not ASF.Components.Base.Has_Element (Pos.Component);
            Pos.Current := ASF.Components.Base.Element (Pos.Component);
            exit when Pos.Current.all in UISelectItem'Class;
            if Pos.Current.all in UISelectItems'Class then
               Pos.List := UISelectItems'Class (Pos.Current.all).Get_Select_Item_List (Context);
               Pos.Last := Pos.List.Length;
               Pos.Pos  := 1;
               exit when Pos.Last > 0;
               Pos.Pos := 0;
            end if;
         end loop;
      end if;
   end Next;

   --  ------------------------------
   --  Get the Select_Item represented by the component.
   --  ------------------------------
   function Get_Select_Item (From    : in UISelectItem;
                             Context : in Faces_Context'Class)
                             return ASF.Models.Selects.Select_Item is
      use Util.Beans.Objects;

      Val : constant Object := From.Get_Attribute (Name    => VALUE_NAME,
                                                   Context => Context);
   begin
      if not Is_Null (Val) then
         return ASF.Models.Selects.To_Select_Item (Val);
      end if;
      declare
         Label       : constant Object := From.Get_Attribute (Name    => ITEM_LABEL_NAME,
                                                              Context => Context);
         Value       : constant Object := From.Get_Attribute (Name    => ITEM_VALUE_NAME,
                                                              Context => Context);
         Description : constant Object := From.Get_Attribute (Name    => ITEM_DESCRIPTION_NAME,
                                                              Context => Context);
         Disabled    : constant Boolean := From.Get_Attribute (Name   => ITEM_DISABLED_NAME,
                                                               Context => Context);
      begin
         if Is_Null (Label) then
            return ASF.Models.Selects.Create_Select_Item (Value, Value, Description, Disabled);
         else
            return ASF.Models.Selects.Create_Select_Item (Label, Value, Description, Disabled);
         end if;
      end;
   end Get_Select_Item;

   --  ------------------------------
   --  UISelectItems Component
   --  ------------------------------

   --  ------------------------------
   --  Get the Select_Item represented by the component.
   --  ------------------------------
   function Get_Select_Item_List (From : in UISelectItems;
                                  Context : in Faces_Context'Class)
                                     return ASF.Models.Selects.Select_Item_List is
      use Util.Beans.Objects;

      Value : constant Object := From.Get_Attribute (Name    => VALUE_NAME,
                                                     Context => Context);
   begin
      return ASF.Models.Selects.To_Select_Item_List (Value);
   end Get_Select_Item_List;

   --  ------------------------------
   --  SelectOne Component
   --  ------------------------------

   --  ------------------------------
   --  Render the select element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UISelectOne;
                           Context : in out Faces_Context'Class) is
   begin
      if UI.Is_Rendered (Context) then
         UISelectOne'Class (UI).Render_Select (Context);
      end if;
   end Encode_Begin;

   --  ------------------------------
   --  Renders the select element.  This is called by Encode_Begin if
   --  the component is rendered.
   --  ------------------------------
   procedure Render_Select (UI      : in UISelectOne;
                            Context : in out Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
      Value  : constant EL.Objects.Object := UISelectOne'Class (UI).Get_Value;
   begin
      Writer.Start_Element ("select");
      Writer.Write_Attribute (Name => "name", Value => UI.Get_Client_Id);
      UI.Render_Attributes (Context, SELECT_ATTRIBUTE_NAMES, Writer);

      UISelectOne'Class (UI).Render_Options (Value, Context);
      Writer.End_Element ("select");
   end Render_Select;

   --  ------------------------------
   --  Renders the option element.  This is called by Render_Select to
   --  generate the component options.
   --  ------------------------------
   procedure Render_Options (UI      : in UISelectOne;
                             Value   : in Util.Beans.Objects.Object;
                             Context : in out Faces_Context'Class) is
      Writer   : constant Response_Writer_Access := Context.Get_Response_Writer;
      Selected : constant Wide_Wide_String := Util.Beans.Objects.To_Wide_Wide_String (Value);
      Iter     : Cursor;
   begin
      UI.First (Context, Iter);
      while Has_Element (Iter) loop
         declare
            Item       : constant ASF.Models.Selects.Select_Item := Element (Iter, Context);
            Item_Value : constant Wide_Wide_String := Item.Get_Value;
         begin
            Writer.Start_Element ("option");
            Writer.Write_Wide_Attribute ("value", Item_Value);
            if Item_Value = Selected then
               Writer.Write_Attribute ("selected", "selected");
            end if;
            if Item.Is_Escaped then
               Writer.Write_Wide_Text (Item.Get_Label);
            else
               Writer.Write_Wide_Text (Item.Get_Label);
            end if;
            Writer.End_Element ("option");
            Next (Iter, Context);
         end;
      end loop;
   end Render_Options;

   --  ------------------------------
   --  Returns True if the radio options must be rendered vertically.
   --  ------------------------------
   function Is_Vertical (UI      : in UISelectOneRadio;
                         Context : in Faces_Context'Class) return Boolean is
      Dir    : constant String := UI.Get_Attribute (Context => Context,
                                                    Name    => "layout",
                                                    Default => "");
   begin
      return Dir = "pageDirection";
   end Is_Vertical;

   --  ------------------------------
   --  Renders the select element.  This is called by Encode_Begin if
   --  the component is rendered.
   --  ------------------------------
   overriding
   procedure Render_Select (UI      : in UISelectOneRadio;
                            Context : in out Faces_Context'Class) is
      Writer   : constant Response_Writer_Access := Context.Get_Response_Writer;
      Value    : constant EL.Objects.Object := UISelectOne'Class (UI).Get_Value;
      Vertical : constant Boolean := UI.Is_Vertical (Context);
      Selected : constant Wide_Wide_String := Util.Beans.Objects.To_Wide_Wide_String (Value);
      Iter     : Cursor;
      Id       : constant String := To_String (UI.Get_Client_Id);
      N        : Natural := 0;

      Disabled_Class : constant EL.Objects.Object := UI.Get_Attribute (Context => Context,
                                                                       Name => "disabledClass");
      Enabled_Class  : constant EL.Objects.Object := UI.Get_Attribute (Context => Context,
                                                                       Name => "enabledClass");
   begin
      Writer.Start_Element ("table");
      UI.Render_Attributes (Context, Writer);

      if not Vertical then
         Writer.Start_Element ("tr");
      end if;

      UI.First (Context, Iter);
      while Has_Element (Iter) loop
         declare
            Item       : constant ASF.Models.Selects.Select_Item := Element (Iter, Context);
            Item_Value : constant Wide_Wide_String := Item.Get_Value;
         begin
            if Vertical then
               Writer.Start_Element ("tr");
            end if;
            Writer.Start_Element ("td");

            --  Render the input radio checkbox.
            Writer.Start_Element ("input");
            Writer.Write_Attribute ("type", "radio");
            Writer.Write_Attribute ("name", Id);
            if Item.Is_Disabled then
               Writer.Write_Attribute ("disabled", "disabled");
            end if;
            Writer.Write_Attribute ("id", Id & "_" & Util.Strings.Image (N));
            Writer.Write_Wide_Attribute ("value", Item_Value);
            if Item_Value = Selected then
               Writer.Write_Attribute ("checked", "checked");
            end if;
            Writer.End_Element ("input");

            --  Render the label associated with the checkbox.
            Writer.Start_Element ("label");
            if Item.Is_Disabled then
               if not Util.Beans.Objects.Is_Null (Disabled_Class) then
                  Writer.Write_Attribute ("class", Disabled_Class);
               end if;
            else
               if not Util.Beans.Objects.Is_Null (Enabled_Class) then
                  Writer.Write_Attribute ("class", Enabled_Class);
               end if;
            end if;

            Writer.Write_Attribute ("for", Id & "_" & Util.Strings.Image (N));
            if Item.Is_Escaped then
               Writer.Write_Wide_Text (Item.Get_Label);
            else
               Writer.Write_Wide_Text (Item.Get_Label);
            end if;
            Writer.End_Element ("label");

            Writer.End_Element ("td");
            if Vertical then
               Writer.End_Element ("tr");
            end if;

            Next (Iter, Context);
            N := N + 1;
         end;
      end loop;

      if not Vertical then
         Writer.End_Element ("tr");
      end if;
      Writer.End_Element ("table");
   end Render_Select;

begin
   ASF.Utils.Set_Text_Attributes (SELECT_ATTRIBUTE_NAMES);
   ASF.Utils.Set_Interactive_Attributes (SELECT_ATTRIBUTE_NAMES);
end ASF.Components.Html.Selects;

Fix the radio button HTML, the input 'name' attribute was missing


-----------------------------------------------------------------------
--  security-openid -- OpenID 2.0 Support
--  Copyright (C) 2009, 2010, 2011, 2012, 2013 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.Log.Loggers;

with Security.Auth.OpenID;
with Security.Auth.OAuth.Facebook;
package body Security.Auth is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Auth");

   --  ------------------------------
   --  Get the provider.
   --  ------------------------------
   function Get_Provider (Assoc : in Association) return String is
   begin
      return To_String (Assoc.Provider);
   end Get_Provider;

   --  ------------------------------
   --  Get the email address
   --  ------------------------------
   function Get_Email (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Email);
   end Get_Email;

   --  ------------------------------
   --  Get the user first name.
   --  ------------------------------
   function Get_First_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.First_Name);
   end Get_First_Name;

   --  ------------------------------
   --  Get the user last name.
   --  ------------------------------
   function Get_Last_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Last_Name);
   end Get_Last_Name;

   --  ------------------------------
   --  Get the user full name.
   --  ------------------------------
   function Get_Full_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Full_Name);
   end Get_Full_Name;

   --  ------------------------------
   --  Get the user identity.
   --  ------------------------------
   function Get_Identity (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Identity);
   end Get_Identity;

   --  ------------------------------
   --  Get the user claimed identity.
   --  ------------------------------
   function Get_Claimed_Id (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Claimed_Id);
   end Get_Claimed_Id;

   --  ------------------------------
   --  Get the user language.
   --  ------------------------------
   function Get_Language (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Language);
   end Get_Language;

   --  ------------------------------
   --  Get the user country.
   --  ------------------------------
   function Get_Country (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Country);
   end Get_Country;

   --  ------------------------------
   --  Get the result of the authentication.
   --  ------------------------------
   function Get_Status (Auth : in Authentication) return Auth_Result is
   begin
      return Auth.Status;
   end Get_Status;

   --  ------------------------------
   --  Default principal
   --  ------------------------------

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   function Get_Name (From : in Principal) return String is
   begin
      return Get_First_Name (From.Auth) & " " & Get_Last_Name (From.Auth);
   end Get_Name;

   --  ------------------------------
   --  Get the user email address.
   --  ------------------------------
   function Get_Email (From : in Principal) return String is
   begin
      return Get_Email (From.Auth);
   end Get_Email;

   --  ------------------------------
   --  Get the authentication data.
   --  ------------------------------
   function Get_Authentication (From : in Principal) return Authentication is
   begin
      return From.Auth;
   end Get_Authentication;

   --  ------------------------------
   --  Create a principal with the given authentication results.
   --  ------------------------------
   function Create_Principal (Auth : in Authentication) return Principal_Access is
      P : constant Principal_Access := new Principal;
   begin
      P.Auth := Auth;
      return P;
   end Create_Principal;

   --  ------------------------------
   --  Initialize the OpenID realm.
   --  ------------------------------
   procedure Initialize (Realm  : in out Manager;
                         Params : in Parameters'Class;
                         Name   : in String := PROVIDER_OPENID) is
      Provider : constant String := Params.Get_Parameter ("auth.provider." & Name);
      Impl     : Manager_Access;
   begin
      if Provider = PROVIDER_OPENID then
         Impl := new Security.Auth.OpenID.Manager;

      elsif Provider = PROVIDER_FACEBOOK then
         Impl := new Security.Auth.OAuth.Facebook.Manager;

      else
         Log.Error ("Authentication provider {0} not recognized", Provider);
         raise Service_Error with "Authentication provider not supported";
      end if;
      Realm.Delegate := Impl;
      Impl.Initialize (Params, Name);
      Realm.Provider := To_Unbounded_String (Name);
   end Initialize;

   --  ------------------------------
   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The <b>Name</b> can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  (See OpenID Section 7.3 Discovery)
   --  ------------------------------
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point) is
   begin
      if Realm.Delegate /= null then
         Realm.Delegate.Discover (Name, Result);
      else
--           Result.URL := Realm.Realm;
         Result.Alias := To_Unbounded_String ("");
      end if;
   end Discover;

   --  ------------------------------
   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   --  ------------------------------
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association) is
   begin
      Result.Provider := Realm.Provider;
      if Realm.Delegate /= null then
         Realm.Delegate.Associate (OP, Result);
      end if;
   end Associate;

   --  ------------------------------
   --  Get the authentication URL to which the user must be redirected for authentication
   --  by the authentication server.
   --  ------------------------------
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String is
   begin
      if Realm.Delegate /= null then
         return Realm.Delegate.Get_Authentication_URL (OP, Assoc);
      else
         return To_String (OP.URL);
      end if;
   end Get_Authentication_URL;

   procedure Set_Result (Result  : in out Authentication;
                         Status  : in Auth_Result;
                         Message : in String) is
   begin
      if Status /= AUTHENTICATED then
         Log.Error ("OpenID verification failed: {0}", Message);
      else
         Log.Info ("OpenID verification: {0}", Message);
      end if;
      Result.Status := Status;
   end Set_Result;

   --  ------------------------------
   --  Verify the authentication result
   --  ------------------------------
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication) is
   begin
      if Realm.Delegate /= null then
         Realm.Delegate.Verify (Assoc, Request, Result);
      else
         Set_Result (Result, SETUP_NEEDED, "Setup is needed");
      end if;
   end Verify;

   function To_String (OP : End_Point) return String is
   begin
      return "openid://" & To_String (OP.URL);
   end To_String;

   function To_String (Assoc : Association) return String is
   begin
      return "session_type=" & To_String (Assoc.Session_Type)
        & "&assoc_type=" & To_String (Assoc.Assoc_Type)
        & "&assoc_handle=" & To_String (Assoc.Assoc_Handle)
        & "&mac_key=" & To_String (Assoc.Mac_Key);
   end To_String;

end Security.Auth;

-----------------------------------------------------------------------
--  security-openid -- OpenID 2.0 Support
--  Copyright (C) 2009, 2010, 2011, 2012, 2013 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.Log.Loggers;

with Security.Auth.OpenID;
with Security.Auth.OAuth.Facebook;
with Security.Auth.OAuth.Googleplus;
package body Security.Auth is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Auth");

   --  ------------------------------
   --  Get the provider.
   --  ------------------------------
   function Get_Provider (Assoc : in Association) return String is
   begin
      return To_String (Assoc.Provider);
   end Get_Provider;

   --  ------------------------------
   --  Get the email address
   --  ------------------------------
   function Get_Email (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Email);
   end Get_Email;

   --  ------------------------------
   --  Get the user first name.
   --  ------------------------------
   function Get_First_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.First_Name);
   end Get_First_Name;

   --  ------------------------------
   --  Get the user last name.
   --  ------------------------------
   function Get_Last_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Last_Name);
   end Get_Last_Name;

   --  ------------------------------
   --  Get the user full name.
   --  ------------------------------
   function Get_Full_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Full_Name);
   end Get_Full_Name;

   --  ------------------------------
   --  Get the user identity.
   --  ------------------------------
   function Get_Identity (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Identity);
   end Get_Identity;

   --  ------------------------------
   --  Get the user claimed identity.
   --  ------------------------------
   function Get_Claimed_Id (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Claimed_Id);
   end Get_Claimed_Id;

   --  ------------------------------
   --  Get the user language.
   --  ------------------------------
   function Get_Language (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Language);
   end Get_Language;

   --  ------------------------------
   --  Get the user country.
   --  ------------------------------
   function Get_Country (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Country);
   end Get_Country;

   --  ------------------------------
   --  Get the result of the authentication.
   --  ------------------------------
   function Get_Status (Auth : in Authentication) return Auth_Result is
   begin
      return Auth.Status;
   end Get_Status;

   --  ------------------------------
   --  Default principal
   --  ------------------------------

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   function Get_Name (From : in Principal) return String is
   begin
      return Get_First_Name (From.Auth) & " " & Get_Last_Name (From.Auth);
   end Get_Name;

   --  ------------------------------
   --  Get the user email address.
   --  ------------------------------
   function Get_Email (From : in Principal) return String is
   begin
      return Get_Email (From.Auth);
   end Get_Email;

   --  ------------------------------
   --  Get the authentication data.
   --  ------------------------------
   function Get_Authentication (From : in Principal) return Authentication is
   begin
      return From.Auth;
   end Get_Authentication;

   --  ------------------------------
   --  Create a principal with the given authentication results.
   --  ------------------------------
   function Create_Principal (Auth : in Authentication) return Principal_Access is
      P : constant Principal_Access := new Principal;
   begin
      P.Auth := Auth;
      return P;
   end Create_Principal;

   --  ------------------------------
   --  Initialize the OpenID realm.
   --  ------------------------------
   procedure Initialize (Realm  : in out Manager;
                         Params : in Parameters'Class;
                         Name   : in String := PROVIDER_OPENID) is
      Provider : constant String := Params.Get_Parameter ("auth.provider." & Name);
      Impl     : Manager_Access;
   begin
      if Provider = PROVIDER_OPENID then
         Impl := new Security.Auth.OpenID.Manager;

      elsif Provider = PROVIDER_FACEBOOK then
         Impl := new Security.Auth.OAuth.Facebook.Manager;

      elsif Provider = PROVIDER_GOOGLE_PLUS then
         Impl := new Security.Auth.OAuth.Googleplus.Manager;

      else
         Log.Error ("Authentication provider {0} not recognized", Provider);
         raise Service_Error with "Authentication provider not supported";
      end if;
      Realm.Delegate := Impl;
      Impl.Initialize (Params, Name);
      Realm.Provider := To_Unbounded_String (Name);
   end Initialize;

   --  ------------------------------
   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The <b>Name</b> can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  (See OpenID Section 7.3 Discovery)
   --  ------------------------------
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point) is
   begin
      if Realm.Delegate /= null then
         Realm.Delegate.Discover (Name, Result);
      else
--           Result.URL := Realm.Realm;
         Result.Alias := To_Unbounded_String ("");
      end if;
   end Discover;

   --  ------------------------------
   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   --  ------------------------------
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association) is
   begin
      Result.Provider := Realm.Provider;
      if Realm.Delegate /= null then
         Realm.Delegate.Associate (OP, Result);
      end if;
   end Associate;

   --  ------------------------------
   --  Get the authentication URL to which the user must be redirected for authentication
   --  by the authentication server.
   --  ------------------------------
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String is
   begin
      if Realm.Delegate /= null then
         return Realm.Delegate.Get_Authentication_URL (OP, Assoc);
      else
         return To_String (OP.URL);
      end if;
   end Get_Authentication_URL;

   procedure Set_Result (Result  : in out Authentication;
                         Status  : in Auth_Result;
                         Message : in String) is
   begin
      if Status /= AUTHENTICATED then
         Log.Error ("OpenID verification failed: {0}", Message);
      else
         Log.Info ("OpenID verification: {0}", Message);
      end if;
      Result.Status := Status;
   end Set_Result;

   --  ------------------------------
   --  Verify the authentication result
   --  ------------------------------
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication) is
   begin
      if Realm.Delegate /= null then
         Realm.Delegate.Verify (Assoc, Request, Result);
      else
         Set_Result (Result, SETUP_NEEDED, "Setup is needed");
      end if;
   end Verify;

   function To_String (OP : End_Point) return String is
   begin
      return "openid://" & To_String (OP.URL);
   end To_String;

   function To_String (Assoc : Association) return String is
   begin
      return "session_type=" & To_String (Assoc.Session_Type)
        & "&assoc_type=" & To_String (Assoc.Assoc_Type)
        & "&assoc_handle=" & To_String (Assoc.Assoc_Handle)
        & "&mac_key=" & To_String (Assoc.Mac_Key);
   end To_String;

end Security.Auth;

Use the Google+ implementation

Use the Google+ implementation