-----------------------------------------------------------------------
--  mat-commands -- Command support and execution
--  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 MAT.Targets;
package MAT.Commands is

   Stop_Interp : exception;

   --  Procedure that defines a command handler.
   type Command_Handler is access procedure (Target : in out MAT.Targets.Target_Type'Class;
                                             Args   : in String);

   --  Execute the command given in the line.
   procedure Execute (Target : in out MAT.Targets.Target_Type'Class;
                      Line   : in String);

   --  Initialize the process targets by loading the MAT files.
   procedure Initialize_Files (Target  : in out MAT.Targets.Target_Type'Class);

   --  Symbol command.
   --  Load the symbols from the binary file.
   procedure Symbol_Command (Target : in out MAT.Targets.Target_Type'Class;
                             Args   : in String);

   --  Sizes command.
   --  Collect statistics about the used memory slots and report the different slot
   --  sizes with count.
   procedure Sizes_Command (Target : in out MAT.Targets.Target_Type'Class;
                            Args   : in String);

end MAT.Commands;

-----------------------------------------------------------------------
--  mat-commands -- Command support and execution
--  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 MAT.Targets;
package MAT.Commands is

   Stop_Interp : exception;

   --  Procedure that defines a command handler.
   type Command_Handler is access procedure (Target : in out MAT.Targets.Target_Type'Class;
                                             Args   : in String);

   --  Execute the command given in the line.
   procedure Execute (Target : in out MAT.Targets.Target_Type'Class;
                      Line   : in String);

   --  Initialize the process targets by loading the MAT files.
   procedure Initialize_Files (Target  : in out MAT.Targets.Target_Type'Class);

   --  Symbol command.
   --  Load the symbols from the binary file.
   procedure Symbol_Command (Target : in out MAT.Targets.Target_Type'Class;
                             Args   : in String);

   --  Sizes command.
   --  Collect statistics about the used memory slots and report the different slot
   --  sizes with count.
   procedure Sizes_Command (Target : in out MAT.Targets.Target_Type'Class;
                            Args   : in String);

   --  Threads command.
   --  Collect statistics about the threads and their allocation.
   procedure Threads_Command (Target : in out MAT.Targets.Target_Type'Class;
                              Args   : in String);

end MAT.Commands;

Make the Threads_Command a public procedure


-----------------------------------------------------------------------
--  mat-consoles - Console interface
--  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.
-----------------------------------------------------------------------

package body MAT.Consoles is

   --  ------------------------------
   --  Format the address and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Addr    : in MAT.Types.Target_Addr) is
      Value : constant String := MAT.Types.Hex_Image (Addr);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Field;

   --  ------------------------------
   --  Format the size and print it for the given field.
   --  ------------------------------
   procedure Print_Size (Console : in out Console_Type;
                         Field   : in Field_Type;
                         Size    : in MAT.Types.Target_Size) is
      Value : constant String := MAT.Types.Target_Size'Image (Size);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Size;

end MAT.Consoles;

-----------------------------------------------------------------------
--  mat-consoles - Console interface
--  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.
-----------------------------------------------------------------------

package body MAT.Consoles is

   --  ------------------------------
   --  Format the address and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Addr    : in MAT.Types.Target_Addr) is
      Value : constant String := MAT.Types.Hex_Image (Addr);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Field;

   --  ------------------------------
   --  Format the size and print it for the given field.
   --  ------------------------------
   procedure Print_Size (Console : in out Console_Type;
                         Field   : in Field_Type;
                         Size    : in MAT.Types.Target_Size) is
      Value : constant String := MAT.Types.Target_Size'Image (Size);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Size;

   --  ------------------------------
   --  Format the integer and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Integer) is
      Val : constant String := Integer'Image (Value);
   begin
      Console_Type'Class (Console).Print_Field (Field, Val);
   end Print_Field;

end MAT.Consoles;

Implement the Print_Field operation

Implement the Print_Field operation


-----------------------------------------------------------------------
--  awa_command - Tests for AWA command
--  Copyright (C) 2020 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.Commands;
with Util.Tests;
with AWA.Tests;
with AWA.Commands.Drivers;
with AWA.Commands.List;
with AWA.Commands.Start;
with AWA.Commands.Stop;
with Servlet.Server;
with ADO.Drivers;
with AWA.Testsuite;
procedure AWA_Command is

   package Server_Commands is
     new AWA.Commands.Drivers (Driver_Name => "awa",
                               Container_Type => Servlet.Server.Container);

   package List_Command is
      new AWA.Commands.List (Server_Commands);

   package Start_Command is
      new AWA.Commands.Start (Server_Commands);

   package Stop_Command is
      new AWA.Commands.Stop (Server_Commands);

   App       : aliased AWA.Tests.Test_Application;
   Context   : AWA.Commands.Context_Type;
   Arguments : Util.Commands.Dynamic_Argument_List;
   Suite     : Util.Tests.Access_Test_Suite := AWA.Testsuite.Suite;
   pragma Unreferenced (Suite);
begin
   ADO.Drivers.Initialize;
   Server_Commands.WS.Register_Application ("/test", App'Unchecked_Access);
   Server_Commands.Run (Context, Arguments);

exception
   when E : others =>
      AWA.Commands.Print (Context, E);

end AWA_Command;

-----------------------------------------------------------------------
--  awa_command - Tests for AWA command
--  Copyright (C) 2020 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.Commands;
with Util.Tests;
with AWA.Tests;
with AWA.Commands.Drivers;
with AWA.Commands.List;
with AWA.Commands.Start;
with AWA.Commands.Stop;
with AWA.Commands.Info;
with Servlet.Server;
with ADO.Drivers;
with AWA.Testsuite;
procedure AWA_Command is

   package Server_Commands is
     new AWA.Commands.Drivers (Driver_Name => "awa",
                               Container_Type => Servlet.Server.Container);

   package List_Command is
      new AWA.Commands.List (Server_Commands);

   package Start_Command is
      new AWA.Commands.Start (Server_Commands);

   package Stop_Command is
      new AWA.Commands.Stop (Server_Commands);

   package Info_Command is
      new AWA.Commands.Info (Server_Commands);

   App       : aliased AWA.Tests.Test_Application;
   Context   : AWA.Commands.Context_Type;
   Arguments : Util.Commands.Dynamic_Argument_List;
   Suite     : Util.Tests.Access_Test_Suite := AWA.Testsuite.Suite;
   pragma Unreferenced (Suite);
begin
   ADO.Drivers.Initialize;
   Server_Commands.WS.Register_Application ("/test", App'Unchecked_Access);
   Server_Commands.Run (Context, Arguments);

exception
   when E : others =>
      AWA.Commands.Print (Context, E);

end AWA_Command;

Add the info command by instantiating the AWA.Commands.Info package


-----------------------------------------------------------------------
--  asf-servlets-mappers -- Read servlet configuration files
--  Copyright (C) 2011 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.Beans.Objects;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Serialize.IO.XML;

with EL.Contexts;

--  The ASF.Servlets.Mappers package defines an XML mapper that can be used
--  to read the servlet configuration files.
--
--  The servlet configuration used by ASF is a subset of the servlet deployment descriptor
--  defined in JSR 315 - Java Servlet Specification Version 3.0.  It includes:
--
--

--
Definition of filter mapping (filter-mapping tag)

--
Definition of servlet mapping (servlet-mapping tag)

--
Definition of context parameters (context-param tag)

--
Definition of mime types (mime-mapping tag)

--
Definition of error pages (error-page tag)

--

--
--  Other configurations are ignored by the mapper.
--
--  Note: several JSR 315 configuration parameters do not makes sense in the ASF world
--  because we cannot create a servlet or a filter through the configuration file.
package ASF.Servlets.Mappers is

   type Servlet_Fields is (FILTER_MAPPING, FILTER_NAME, SERVLET_NAME,
                           URL_PATTERN, SERVLET_MAPPING,
                           CONTEXT_PARAM, PARAM_NAME, PARAM_VALUE,
                           MIME_MAPPING, MIME_TYPE, EXTENSION,
                           ERROR_PAGE, ERROR_CODE, LOCATION);

   --  ------------------------------
   --  Servlet Config Reader
   --  ------------------------------
   --  When reading and parsing the servlet configuration file, the Servlet_Config object
   --  is populated by calls through the Set_Member procedure.  The data is
   --  collected and when the end of an element (FILTER_MAPPING, SERVLET_MAPPING, CONTEXT_PARAM)
   --  is reached, the definition is updated in the servlet registry.
   type Servlet_Config is limited record
      Filter_Name      : Util.Beans.Objects.Object;
      Servlet_Name     : Util.Beans.Objects.Object;
      URL_Pattern      : Util.Beans.Objects.Object;
      Param_Name       : Util.Beans.Objects.Object;
      Param_Value      : Util.Beans.Objects.Object;
      Mime_Type        : Util.Beans.Objects.Object;
      Extension        : Util.Beans.Objects.Object;
      Error_Code       : Util.Beans.Objects.Object;
      Location         : Util.Beans.Objects.Object;
      Handler          : Servlet_Registry_Access;
      Context          : EL.Contexts.ELContext_Access;
   end record;
   type Servlet_Config_Access is access all Servlet_Config;

   --  Save in the servlet config object the value associated with the given field.
   --  When the FILTER_MAPPING, SERVLET_MAPPING or CONTEXT_PARAM field
   --  is reached, insert the new configuration rule in the servlet registry.
   procedure Set_Member (N     : in out Servlet_Config;
                         Field : in Servlet_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  Setup the XML parser to read the servlet and mapping rules context-param,
   --  filter-mapping and servlet-mapping.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Handler : in Servlet_Registry_Access;
      Context : in EL.Contexts.ELContext_Access;
   package Reader_Config is
      Config : aliased Servlet_Config;
   end Reader_Config;

private

   package Servlet_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Servlet_Config,
                                               Element_Type_Access => Servlet_Config_Access,
                                               Fields              => Servlet_Fields,
                                               Set_Member          => Set_Member);

end ASF.Servlets.Mappers;

-----------------------------------------------------------------------
--  asf-servlets-mappers -- Read servlet configuration files
--  Copyright (C) 2011, 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.Beans.Objects;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Serialize.IO.XML;
with Util.Beans.Objects.Vectors;

with EL.Contexts;

--  The ASF.Servlets.Mappers package defines an XML mapper that can be used
--  to read the servlet configuration files.
--
--  The servlet configuration used by ASF is a subset of the servlet deployment descriptor
--  defined in JSR 315 - Java Servlet Specification Version 3.0.  It includes:
--
--

--
Definition of filter mapping (filter-mapping tag)

--
Definition of servlet mapping (servlet-mapping tag)

--
Definition of context parameters (context-param tag)

--
Definition of mime types (mime-mapping tag)

--
Definition of error pages (error-page tag)

--

--
--  Other configurations are ignored by the mapper.
--
--  Note: several JSR 315 configuration parameters do not makes sense in the ASF world
--  because we cannot create a servlet or a filter through the configuration file.
package ASF.Servlets.Mappers is

   type Servlet_Fields is (FILTER_MAPPING, FILTER_NAME, SERVLET_NAME,
                           URL_PATTERN, SERVLET_MAPPING,
                           CONTEXT_PARAM, PARAM_NAME, PARAM_VALUE,
                           MIME_MAPPING, MIME_TYPE, EXTENSION,
                           ERROR_PAGE, ERROR_CODE, LOCATION);

   --  ------------------------------
   --  Servlet Config Reader
   --  ------------------------------
   --  When reading and parsing the servlet configuration file, the Servlet_Config object
   --  is populated by calls through the Set_Member procedure.  The data is
   --  collected and when the end of an element (FILTER_MAPPING, SERVLET_MAPPING, CONTEXT_PARAM)
   --  is reached, the definition is updated in the servlet registry.
   type Servlet_Config is limited record
      Filter_Name      : Util.Beans.Objects.Object;
      Servlet_Name     : Util.Beans.Objects.Object;
      URL_Patterns     : Util.Beans.Objects.Vectors.Vector;
      Param_Name       : Util.Beans.Objects.Object;
      Param_Value      : Util.Beans.Objects.Object;
      Mime_Type        : Util.Beans.Objects.Object;
      Extension        : Util.Beans.Objects.Object;
      Error_Code       : Util.Beans.Objects.Object;
      Location         : Util.Beans.Objects.Object;
      Handler          : Servlet_Registry_Access;
      Context          : EL.Contexts.ELContext_Access;
   end record;
   type Servlet_Config_Access is access all Servlet_Config;

   --  Save in the servlet config object the value associated with the given field.
   --  When the FILTER_MAPPING, SERVLET_MAPPING or CONTEXT_PARAM field
   --  is reached, insert the new configuration rule in the servlet registry.
   procedure Set_Member (N     : in out Servlet_Config;
                         Field : in Servlet_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  Setup the XML parser to read the servlet and mapping rules context-param,
   --  filter-mapping and servlet-mapping.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Handler : in Servlet_Registry_Access;
      Context : in EL.Contexts.ELContext_Access;
   package Reader_Config is
      Config : aliased Servlet_Config;
   end Reader_Config;

private

   package Servlet_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Servlet_Config,
                                               Element_Type_Access => Servlet_Config_Access,
                                               Fields              => Servlet_Fields,
                                               Set_Member          => Set_Member);

end ASF.Servlets.Mappers;

Allow to have several url-pattern for a filter/servlet mapping


-----------------------------------------------------------------------
--  bbox -- Bbox API
--  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 Util.Properties.JSON;
with Util.Log.Loggers;
with Util.Strings;
package body Bbox.API is

   use Ada.Strings.Unbounded;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Bbox.API");

   --  ------------------------------
   --  Set the server IP address.
   --  ------------------------------
   procedure Set_Server (Client : in out Client_Type;
                         Server : in String) is
   begin
      Log.Debug ("Using bbox server {0}", Server);
      Client.Server := Ada.Strings.Unbounded.To_Unbounded_String (Server);
   end Set_Server;

   --  ------------------------------
   --  Internal operation to get the URI based on the operation being called.
   --  ------------------------------
   function Get_URI (Client    : in Client_Type;
                     Operation : in String) return String is
   begin
      return "http://" & To_String (Client.Server) & "/api/v1/" & Operation;
   end Get_URI;

   --  ------------------------------
   --  Login to the server Bbox API with the password.
   --  ------------------------------
   procedure Login (Client   : in out Client_Type;
                    Password : in String) is
      procedure Process (Name, Value : in String);

      URI      : constant String := Client.Get_URI ("login");
      Response : Util.Http.Clients.Response;

      procedure Process (Name, Value : in String) is
         Pos, Last : Natural;
      begin
         if Name = "Set-Cookie" then
            Pos := Util.Strings.Index (Value, '=');
            if Pos = 0 then
               return;
            end if;
            Last := Util.Strings.Index (Value, ';');
            if Last = 0 or else Last < Pos then
               return;
            end if;
            Client.Http.Set_Header ("Cookie", Value (Value'First .. Last - 1));
         end if;
      end Process;

   begin
      Log.Debug ("Login to {0}", URI);
      Client.Http.Add_Header ("X-Requested-By", "Bbox Ada Api");
      Client.Http.Post (URI, "password=" & Password, Response);
      if Response.Get_Status = Util.Http.SC_OK then
         Response.Iterate_Headers (Process'Access);
      else
         Log.Error ("Connection and login to {0} failed", URI);
      end if;
   end Login;

   --  ------------------------------
   --  Execute a GET operation on the Bbox API to retrieve the result into the property list.
   --  ------------------------------
   procedure Get (Client    : in out Client_Type;
                  Operation : in String;
                  Result    : in out Util.Properties.Manager) is
      URI      : constant String := Client.Get_URI (Operation);
      Response : Util.Http.Clients.Response;
   begin
      Log.Debug ("Get {0}", URI);
      Client.Http.Get (URI, Response);
      Util.Properties.JSON.Parse_JSON (Result, Response.Get_Body);
   end Get;

end Bbox.API;

-----------------------------------------------------------------------
--  bbox -- Bbox API
--  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 Util.Properties.JSON;
with Util.Log.Loggers;
with Util.Strings;
package body Bbox.API is

   use Ada.Strings.Unbounded;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Bbox.API");

   --  ------------------------------
   --  Set the server IP address.
   --  ------------------------------
   procedure Set_Server (Client : in out Client_Type;
                         Server : in String) is
   begin
      Log.Debug ("Using bbox server {0}", Server);
      Client.Server := Ada.Strings.Unbounded.To_Unbounded_String (Server);
   end Set_Server;

   --  ------------------------------
   --  Internal operation to get the URI based on the operation being called.
   --  ------------------------------
   function Get_URI (Client    : in Client_Type;
                     Operation : in String) return String is
   begin
      return "http://" & To_String (Client.Server) & "/api/v1/" & Operation;
   end Get_URI;

   --  ------------------------------
   --  Login to the server Bbox API with the password.
   --  ------------------------------
   procedure Login (Client   : in out Client_Type;
                    Password : in String) is
      procedure Process (Name, Value : in String);

      URI      : constant String := Client.Get_URI ("login");
      Response : Util.Http.Clients.Response;

      procedure Process (Name, Value : in String) is
         Pos, Last : Natural;
      begin
         if Name = "Set-Cookie" then
            Pos := Util.Strings.Index (Value, '=');
            if Pos = 0 then
               return;
            end if;
            Last := Util.Strings.Index (Value, ';');
            if Last = 0 or else Last < Pos then
               return;
            end if;
            Client.Http.Set_Header ("Cookie", Value (Value'First .. Last - 1));
         end if;
      end Process;

   begin
      Log.Debug ("Login to {0}", URI);
      Client.Http.Add_Header ("X-Requested-By", "Bbox Ada Api");
      Client.Http.Post (URI, "password=" & Password, Response);
      if Response.Get_Status = Util.Http.SC_OK then
         Response.Iterate_Headers (Process'Access);
      else
         Log.Error ("Connection and login to {0} failed", URI);
      end if;
   end Login;

   --  ------------------------------
   --  Execute a GET operation on the Bbox API to retrieve the result into the property list.
   --  ------------------------------
   procedure Get (Client    : in out Client_Type;
                  Operation : in String;
                  Result    : in out Util.Properties.Manager) is
      URI      : constant String := Client.Get_URI (Operation);
      Response : Util.Http.Clients.Response;
   begin
      Log.Debug ("Get {0}", URI);
      Client.Http.Get (URI, Response);
      Util.Properties.JSON.Parse_JSON (Result, Response.Get_Body);
   end Get;

   --  ------------------------------
   --  Execute a GET operation on the Bbox API to retrieve the JSON result and return it.
   --  ------------------------------
   function Get (Client    : in out Client_Type;
                 Operation : in String) return String is
      URI      : constant String := Client.Get_URI (Operation);
      Response : Util.Http.Clients.Response;
   begin
      Log.Debug ("Get {0}", URI);
      Client.Http.Get (URI, Response);
      return Response.Get_Body;
   end Get;

end Bbox.API;

Implement the Get function

Implement the Get function


-----------------------------------------------------------------------
--  bbox -- Bbox API
--  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 Util.Properties.JSON;
with Util.Log.Loggers;
with Util.Strings;
with Util.Properties.Basic;
package body Bbox.API is

   use Ada.Strings.Unbounded;

   package Int_Property renames Util.Properties.Basic.Integer_Property;
   package Bool_Property renames Util.Properties.Basic.Boolean_Property;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Bbox.API");

   function Strip_Unecessary_Array (Content : in String) return String;

   --  ------------------------------
   --  Set the server IP address.
   --  ------------------------------
   procedure Set_Server (Client : in out Client_Type;
                         Server : in String) is
   begin
      Log.Debug ("Using bbox server {0}", Server);
      Client.Server := Ada.Strings.Unbounded.To_Unbounded_String (Server);
   end Set_Server;

   --  ------------------------------
   --  Internal operation to get the URI based on the operation being called.
   --  ------------------------------
   function Get_URI (Client    : in Client_Type;
                     Operation : in String) return String is
   begin
      return "http://" & To_String (Client.Server) & "/api/v1/" & Operation;
   end Get_URI;

   --  ------------------------------
   --  Login to the server Bbox API with the password.
   --  ------------------------------
   procedure Login (Client   : in out Client_Type;
                    Password : in String) is
      procedure Process (Name, Value : in String);

      URI      : constant String := Client.Get_URI ("login");
      Response : Util.Http.Clients.Response;

      procedure Process (Name, Value : in String) is
         Pos, Last : Natural;
      begin
         if Name = "Set-Cookie" then
            Pos := Util.Strings.Index (Value, '=');
            if Pos = 0 then
               return;
            end if;
            Last := Util.Strings.Index (Value, ';');
            if Last = 0 or else Last < Pos then
               return;
            end if;
            Client.Http.Set_Header ("Cookie", Value (Value'First .. Last - 1));
            Client.Is_Logged := True;
         end if;
      end Process;

   begin
      Log.Debug ("Login to {0}", URI);
      Client.Is_Logged := False;
      Client.Http.Set_Header ("Cookie", "");
      Client.Http.Add_Header ("X-Requested-By", "Bbox Ada Api");
      Client.Http.Set_Timeout (10.0);
      Client.Http.Post (URI, "password=" & Password, Response);
      if Response.Get_Status = Util.Http.SC_OK then
         Response.Iterate_Headers (Process'Access);
      else
         Log.Error ("Connection and login to {0} failed", URI);
      end if;
   end Login;

   --  ------------------------------
   --  Strip [] for some Json content.
   --  We did a mistake when we designed the Bbox API and used '[' ... ']' arrays
   --  for most of the JSON result.  Strip that unecessary array.
   --  ------------------------------
   function Strip_Unecessary_Array (Content : in String) return String is
      Last      : Natural := Content'Last;
   begin
      while Last > Content'First and Content (Last) = ASCII.LF loop
         Last := Last - 1;
      end loop;
      if Content (Content'First) = '[' and Content (Last) = ']' then
         return Content (Content'First + 1 .. Last - 1);
      else
         return Content;
      end if;
   end Strip_Unecessary_Array;

   --  ------------------------------
   --  Execute a GET operation on the Bbox API to retrieve the result into the property list.
   --  ------------------------------
   procedure Get (Client    : in out Client_Type;
                  Operation : in String;
                  Result    : in out Util.Properties.Manager) is
      URI      : constant String := Client.Get_URI (Operation);
      Response : Util.Http.Clients.Response;
   begin
      Log.Debug ("Get {0}", URI);
      Client.Http.Set_Timeout (10.0);
      Client.Http.Get (URI, Response);
      Util.Properties.JSON.Parse_JSON (Result, Strip_Unecessary_Array (Response.Get_Body));
   end Get;

   --  ------------------------------
   --  Execute a GET operation on the Bbox API to retrieve the JSON result and return it.
   --  ------------------------------
   function Get (Client    : in out Client_Type;
                 Operation : in String) return String is
      URI      : constant String := Client.Get_URI (Operation);
      Response : Util.Http.Clients.Response;
   begin
      Log.Debug ("Get {0}", URI);
      Client.Http.Set_Timeout (10.0);
      Client.Http.Get (URI, Response);
      return Response.Get_Body;
   end Get;

   --  ------------------------------
   --  Execute a PUT operation on the Bbox API to change some parameter.
   --  ------------------------------
   procedure Put (Client    : in out Client_Type;
                  Operation : in String;
                  Params    : in String) is
      URI      : constant String := Client.Get_URI (Operation);
      Response : Util.Http.Clients.Response;
   begin
      Log.Debug ("Put {0}", URI);
      Client.Http.Set_Timeout (10.0);
      Client.Http.Put (URI, Params, Response);
   end Put;

   procedure Refresh_Token (Client : in out Client_Type) is
      use type Ada.Calendar.Time;

      Now      : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      Response : Util.Http.Clients.Response;
      Tokens   : Util.Properties.Manager;
   begin
      if Length (Client.Token) /= 0 and then Client.Expires > Now then
         return;
      end if;
      Log.Debug ("Get bbox token");
      Client.Http.Set_Timeout (10.0);
      Client.Http.Get (Client.Get_URI ("device/token"), Response);
      Util.Properties.JSON.Parse_JSON (Tokens, Strip_Unecessary_Array (Response.Get_Body));
      Client.Token := To_Unbounded_String (Tokens.Get ("device.token", ""));
      Client.Expires := Ada.Calendar.Clock + 60.0;
   end Refresh_Token;

   --  Execute a POST operation on the Bbox API to change some parameter.
   procedure Post (Client    : in out Client_Type;
                   Operation : in String;
                   Params    : in String) is
      URI      : constant String := Client.Get_URI (Operation);
      Response : Util.Http.Clients.Response;
   begin
      Log.Debug ("Post {0}", URI);
      Client.Refresh_Token;
      Client.Http.Set_Timeout (10.0);
      Client.Http.Post (URI & "?btoken=" & To_String (Client.Token), Params, Response);
   end Post;

   --  Iterate over a JSON array flattened in the properties.
   procedure Iterate (Props : in Util.Properties.Manager;
                      Name  : in String;
                      Process : access procedure (P : in Util.Properties.Manager;
                                                  Base : in String)) is
      Count : constant Integer := Int_Property.Get (Props, Name & ".length", 0);
   begin
      for I in 0 .. Count loop
         declare
            Base : constant String := Name & "." & Util.Strings.Image (I);
         begin
            Process (Props, Base);
         end;
      end loop;
   end Iterate;

end Bbox.API;

-----------------------------------------------------------------------
--  bbox -- Bbox API
--  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.Properties.JSON;
with Util.Log.Loggers;
with Util.Strings;
with Util.Properties.Basic;
package body Bbox.API is

   use Ada.Strings.Unbounded;

   package Int_Property renames Util.Properties.Basic.Integer_Property;
   package Bool_Property renames Util.Properties.Basic.Boolean_Property;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Bbox.API");

   function Strip_Unecessary_Array (Content : in String) return String;

   --  ------------------------------
   --  Set the server IP address.
   --  ------------------------------
   procedure Set_Server (Client : in out Client_Type;
                         Server : in String) is
   begin
      Log.Debug ("Using bbox server {0}", Server);
      Client.Server := Ada.Strings.Unbounded.To_Unbounded_String (Server);
   end Set_Server;

   --  ------------------------------
   --  Internal operation to get the URI based on the operation being called.
   --  ------------------------------
   function Get_URI (Client    : in Client_Type;
                     Operation : in String) return String is
   begin
      return "https://" & To_String (Client.Server) & "/api/v1/" & Operation;
   end Get_URI;

   --  ------------------------------
   --  Login to the server Bbox API with the password.
   --  ------------------------------
   procedure Login (Client   : in out Client_Type;
                    Password : in String) is
      procedure Process (Name, Value : in String);

      URI      : constant String := Client.Get_URI ("login");
      Response : Util.Http.Clients.Response;

      procedure Process (Name, Value : in String) is
         Pos, Last : Natural;
      begin
         if Name = "Set-Cookie" then
            Pos := Util.Strings.Index (Value, '=');
            if Pos = 0 then
               return;
            end if;
            Last := Util.Strings.Index (Value, ';');
            if Last = 0 or else Last < Pos then
               return;
            end if;
            Client.Http.Set_Header ("Cookie", Value (Value'First .. Last - 1));
            Client.Is_Logged := True;
         end if;
      end Process;

   begin
      Log.Debug ("Login to {0}", URI);
      Client.Is_Logged := False;
      Client.Http.Set_Header ("Cookie", "");
      Client.Http.Add_Header ("X-Requested-By", "Bbox Ada Api");
      Client.Http.Set_Timeout (10.0);
      Client.Http.Post (URI, "password=" & Password, Response);
      if Response.Get_Status = Util.Http.SC_OK then
         Response.Iterate_Headers (Process'Access);
      else
         Log.Error ("Connection and login to {0} failed", URI);
      end if;
   end Login;

   --  ------------------------------
   --  Strip [] for some Json content.
   --  We did a mistake when we designed the Bbox API and used '[' ... ']' arrays
   --  for most of the JSON result.  Strip that unecessary array.
   --  ------------------------------
   function Strip_Unecessary_Array (Content : in String) return String is
      Last      : Natural := Content'Last;
   begin
      if Content'Length = 0 then
         return Content;
      end if;
      while Last > Content'First and then Content (Last) = ASCII.LF loop
         Last := Last - 1;
      end loop;
      if Content (Content'First) = '[' and Content (Last) = ']' then
         return Content (Content'First + 1 .. Last - 1);
      else
         return Content;
      end if;
   end Strip_Unecessary_Array;

   --  ------------------------------
   --  Execute a GET operation on the Bbox API to retrieve the result into the property list.
   --  ------------------------------
   procedure Get (Client    : in out Client_Type;
                  Operation : in String;
                  Result    : in out Util.Properties.Manager) is
      URI      : constant String := Client.Get_URI (Operation);
      Response : Util.Http.Clients.Response;
   begin
      Log.Debug ("Get {0}", URI);
      Client.Http.Set_Timeout (10.0);
      Client.Http.Get (URI, Response);
      Util.Properties.JSON.Parse_JSON (Result, Strip_Unecessary_Array (Response.Get_Body));
   end Get;

   --  ------------------------------
   --  Execute a GET operation on the Bbox API to retrieve the JSON result and return it.
   --  ------------------------------
   function Get (Client    : in out Client_Type;
                 Operation : in String) return String is
      URI      : constant String := Client.Get_URI (Operation);
      Response : Util.Http.Clients.Response;
   begin
      Log.Debug ("Get {0}", URI);
      Client.Http.Set_Timeout (10.0);
      Client.Http.Get (URI, Response);
      return Response.Get_Body;
   end Get;

   --  ------------------------------
   --  Execute a PUT operation on the Bbox API to change some parameter.
   --  ------------------------------
   procedure Put (Client    : in out Client_Type;
                  Operation : in String;
                  Params    : in String) is
      URI      : constant String := Client.Get_URI (Operation);
      Response : Util.Http.Clients.Response;
   begin
      Log.Debug ("Put {0}", URI);
      Client.Http.Set_Timeout (10.0);
      Client.Http.Put (URI, Params, Response);
   end Put;

   procedure Refresh_Token (Client : in out Client_Type) is
      use type Ada.Calendar.Time;

      Now      : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      Response : Util.Http.Clients.Response;
      Tokens   : Util.Properties.Manager;
   begin
      if Length (Client.Token) /= 0 and then Client.Expires > Now then
         return;
      end if;
      Log.Debug ("Get bbox token");
      Client.Http.Set_Timeout (10.0);
      Client.Http.Get (Client.Get_URI ("device/token"), Response);
      Util.Properties.JSON.Parse_JSON (Tokens, Strip_Unecessary_Array (Response.Get_Body));
      Client.Token := To_Unbounded_String (Tokens.Get ("device.token", ""));
      Client.Expires := Ada.Calendar.Clock + 60.0;
   end Refresh_Token;

   --  Execute a POST operation on the Bbox API to change some parameter.
   procedure Post (Client    : in out Client_Type;
                   Operation : in String;
                   Params    : in String) is
      URI      : constant String := Client.Get_URI (Operation);
      Response : Util.Http.Clients.Response;
   begin
      Log.Debug ("Post {0}", URI);
      Client.Refresh_Token;
      Client.Http.Set_Timeout (10.0);
      Client.Http.Post (URI & "?btoken=" & To_String (Client.Token), Params, Response);
   end Post;

   --  Iterate over a JSON array flattened in the properties.
   procedure Iterate (Props : in Util.Properties.Manager;
                      Name  : in String;
                      Process : access procedure (P : in Util.Properties.Manager;
                                                  Base : in String)) is
      Count : constant Integer := Int_Property.Get (Props, Name & ".length", 0);
   begin
      for I in 0 .. Count loop
         declare
            Base : constant String := Name & "." & Util.Strings.Image (I);
         begin
            Process (Props, Base);
         end;
      end loop;
   end Iterate;

end Bbox.API;

Fix to force using HTTPS with latest Bbox firmwares


-----------------------------------------------------------------------
--  awa-blogs-services -- Blogs and post management
--  Copyright (C) 2011 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 AWA.Blogs.Models;
with AWA.Services.Contexts;
with AWA.Permissions;
with AWA.Permissions.Services;

with ADO.Sessions;

with Ada.Calendar;

with Util.Log.Loggers;

--  The Blogs.Services package defines the service and operations to
--  create, update and delete a post.
package body AWA.Blogs.Services is

   use AWA.Services;
   use ADO.Sessions;
   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Blogs.Services");

   --  ------------------------------
   --  Create a new blog for the user workspace.
   --  ------------------------------
   procedure Create_Blog (Model        : in Blog_Service;
                          Workspace_Id : in ADO.Identifier;
                          Title        : in String;
                          Result       : out ADO.Identifier) is
      use type ADO.Identifier;

      Ctx   : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      User  : constant ADO.Identifier := Ctx.Get_User_Identifier;
      DB    : Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Blog  : AWA.Blogs.Models.Blog_Ref;
   begin
      Log.Info ("Creating blog for user");

      --  Check that the user has the create blog permission on the given workspace.
      AWA.Permissions.Check (Permission => ACL_Create_Blog.Permission,
                             Entity     => Workspace_Id);

      Ctx.Start;
      Blog.Set_Name (Title);
      Blog.Save (DB);

      --  Add the permission for the user to use the new blog.
      AWA.Permissions.Services.Add_Permission (Session => DB,
                                               User    => User,
                                               Entity  => Blog);
      Ctx.Commit;

      Result := Blog.Get_Id;
      Log.Info ("Blog {0} created for user {1}",
                ADO.Identifier'Image (Result), ADO.Identifier'Image (User));
   end Create_Blog;

   --  ------------------------------
   --  Create a new post associated with the given blog identifier.
   --  ------------------------------
   procedure Create_Post (Model   : in Blog_Service;
                          Blog_Id : in ADO.Identifier;
                          Title   : in String;
                          URI     : in String;
                          Text    : in String;
                          Result  : out ADO.Identifier) is
      use type ADO.Identifier;

      Ctx   : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      User  : constant ADO.Identifier := Ctx.Get_User_Identifier;
      DB    : Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Blog  : AWA.Blogs.Models.Blog_Ref;
      Post  : AWA.Blogs.Models.Post_Ref;
      Found : Boolean;
   begin
      Log.Debug ("Creating post for user");

      Ctx.Start;
      --  Get the blog instance.
      Blog.Load (Session => DB,
                 Id      => Blog_Id,
                 Found   => Found);
      if not Found then
         Log.Error ("Blog {0} not found", ADO.Identifier'Image (Blog_Id));
         raise Not_Found with "Blog not found";
      end if;

      --  Check that the user has the create post permission on the given blog.
      AWA.Permissions.Check (Permission => ACL_Create_Blog.Permission,
                             Entity     => Blog_Id);

      --  Build the new post.
      Post.Set_Title (Title);
      Post.Set_Text (Text);
      Post.Set_Create_Date (Ada.Calendar.Clock);
      Post.Set_Uri (URI);
      Post.Set_Author (Ctx.Get_User);
      Post.Save (DB);
      Ctx.Commit;

      Result := Post.Get_Id;
      Log.Info ("Post {0} created for user {1}",
                ADO.Identifier'Image (Result), ADO.Identifier'Image (User));
   end Create_Post;

   --  ------------------------------
   --  Update the post title and text associated with the blog post identified by Post.
   --  ------------------------------
   procedure Update_Post (Model   : in Blog_Service;
                          Post_Id : in ADO.Identifier;
                          Title   : in String;
                          Text    : in String) is
      Ctx   : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB    : Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Post  : AWA.Blogs.Models.Post_Ref;
      Found : Boolean;
   begin
      Ctx.Start;
      Post.Load (Session => DB, Id => Post_Id, Found => Found);
      if not Found then
         Log.Error ("Post {0} not found", ADO.Identifier'Image (Post_Id));
         raise Not_Found;
      end if;

      --  Check that the user has the update post permission on the given post.
      AWA.Permissions.Check (Permission => ACL_Update_Post.Permission,
                             Entity     => Post_Id);

      Post.Set_Title (Title);
      Post.Set_Text (Text);
      Post.Save (DB);
      Ctx.Commit;
   end Update_Post;

   --  ------------------------------
   --  Delete the post identified by the given identifier.
   --  ------------------------------
   procedure Delete_Post (Model   : in Blog_Service;
                          Post_Id : in ADO.Identifier) is
      Ctx   : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB    : Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Post  : AWA.Blogs.Models.Post_Ref;
   begin
      Ctx.Start;
      Post.Load (Session => DB, Id => Post_Id, Found => Found);
      if not Found then
         Log.Error ("Post {0} not found", ADO.Identifier'Image (Post_Id));
         raise Not_Found;
      end if;

      --  Check that the user has the delete post permission on the given post.
      AWA.Permissions.Check (Permission => ACL_Delete_Post.Permission,
                             Entity     => Post_Id);

      Post.Delete (Session => DB);
      Ctx.Commit;
   end Delete_Post;

end AWA.Blogs.Services;

-----------------------------------------------------------------------
--  awa-blogs-services -- Blogs and post management
--  Copyright (C) 2011 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 AWA.Blogs.Models;
with AWA.Services.Contexts;
with AWA.Permissions;
with AWA.Permissions.Services;

with ADO.Sessions;

with Ada.Calendar;

with Util.Log.Loggers;

--  The Blogs.Services package defines the service and operations to
--  create, update and delete a post.
package body AWA.Blogs.Services is

   use AWA.Services;
   use ADO.Sessions;
   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Blogs.Services");

   --  ------------------------------
   --  Create a new blog for the user workspace.
   --  ------------------------------
   procedure Create_Blog (Model        : in Blog_Service;
                          Workspace_Id : in ADO.Identifier;
                          Title        : in String;
                          Result       : out ADO.Identifier) is
      pragma Unreferenced (Model);
      use type ADO.Identifier;

      Ctx   : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      User  : constant ADO.Identifier := Ctx.Get_User_Identifier;
      DB    : Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Blog  : AWA.Blogs.Models.Blog_Ref;
   begin
      Log.Info ("Creating blog for user");

      --  Check that the user has the create blog permission on the given workspace.
      AWA.Permissions.Check (Permission => ACL_Create_Blog.Permission,
                             Entity     => Workspace_Id);

      Ctx.Start;
      Blog.Set_Name (Title);
      Blog.Save (DB);

      --  Add the permission for the user to use the new blog.
      AWA.Permissions.Services.Add_Permission (Session => DB,
                                               User    => User,
                                               Entity  => Blog);
      Ctx.Commit;

      Result := Blog.Get_Id;
      Log.Info ("Blog {0} created for user {1}",
                ADO.Identifier'Image (Result), ADO.Identifier'Image (User));
   end Create_Blog;

   --  ------------------------------
   --  Create a new post associated with the given blog identifier.
   --  ------------------------------
   procedure Create_Post (Model   : in Blog_Service;
                          Blog_Id : in ADO.Identifier;
                          Title   : in String;
                          URI     : in String;
                          Text    : in String;
                          Result  : out ADO.Identifier) is
      pragma Unreferenced (Model);
      use type ADO.Identifier;

      Ctx   : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      User  : constant ADO.Identifier := Ctx.Get_User_Identifier;
      DB    : Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Blog  : AWA.Blogs.Models.Blog_Ref;
      Post  : AWA.Blogs.Models.Post_Ref;
      Found : Boolean;
   begin
      Log.Debug ("Creating post for user");

      Ctx.Start;
      --  Get the blog instance.
      Blog.Load (Session => DB,
                 Id      => Blog_Id,
                 Found   => Found);
      if not Found then
         Log.Error ("Blog {0} not found", ADO.Identifier'Image (Blog_Id));
         raise Not_Found with "Blog not found";
      end if;

      --  Check that the user has the create post permission on the given blog.
      AWA.Permissions.Check (Permission => ACL_Create_Blog.Permission,
                             Entity     => Blog_Id);

      --  Build the new post.
      Post.Set_Title (Title);
      Post.Set_Text (Text);
      Post.Set_Create_Date (Ada.Calendar.Clock);
      Post.Set_Uri (URI);
      Post.Set_Author (Ctx.Get_User);
      Post.Save (DB);
      Ctx.Commit;

      Result := Post.Get_Id;
      Log.Info ("Post {0} created for user {1}",
                ADO.Identifier'Image (Result), ADO.Identifier'Image (User));
   end Create_Post;

   --  ------------------------------
   --  Update the post title and text associated with the blog post identified by Post.
   --  ------------------------------
   procedure Update_Post (Model   : in Blog_Service;
                          Post_Id : in ADO.Identifier;
                          Title   : in String;
                          Text    : in String) is
      pragma Unreferenced (Model);

      Ctx   : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB    : Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Post  : AWA.Blogs.Models.Post_Ref;
      Found : Boolean;
   begin
      Ctx.Start;
      Post.Load (Session => DB, Id => Post_Id, Found => Found);
      if not Found then
         Log.Error ("Post {0} not found", ADO.Identifier'Image (Post_Id));
         raise Not_Found;
      end if;

      --  Check that the user has the update post permission on the given post.
      AWA.Permissions.Check (Permission => ACL_Update_Post.Permission,
                             Entity     => Post_Id);

      Post.Set_Title (Title);
      Post.Set_Text (Text);
      Post.Save (DB);
      Ctx.Commit;
   end Update_Post;

   --  ------------------------------
   --  Delete the post identified by the given identifier.
   --  ------------------------------
   procedure Delete_Post (Model   : in Blog_Service;
                          Post_Id : in ADO.Identifier) is
      pragma Unreferenced (Model);

      Ctx   : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB    : Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Post  : AWA.Blogs.Models.Post_Ref;
      Found : Boolean;
   begin
      Ctx.Start;
      Post.Load (Session => DB, Id => Post_Id, Found => Found);
      if not Found then
         Log.Error ("Post {0} not found", ADO.Identifier'Image (Post_Id));
         raise Not_Found;
      end if;

      --  Check that the user has the delete post permission on the given post.
      AWA.Permissions.Check (Permission => ACL_Delete_Post.Permission,
                             Entity     => Post_Id);

      Post.Delete (Session => DB);
      Ctx.Commit;
   end Delete_Post;

end AWA.Blogs.Services;

Fix compilation of blog module

Fix compilation of blog module


-----------------------------------------------------------------------
--  security-permissions -- Definition of permissions
--  Copyright (C) 2010, 2011 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.Unchecked_Deallocation;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;

with Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Contexts;
with Security.Controllers;
with Security.Controllers.Roles;

--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.
package body Security.Permissions is

   use Util.Log;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Permissions");

   --  A global map to translate a string to a permission index.
   package Permission_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Permission_Index,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => "=");

   protected type Global_Index is
      --  Get the permission index
      function Get_Permission_Index (Name : in String) return Permission_Index;

      --  Get the last permission index registered in the global permission map.
      function Get_Last_Permission_Index return Permission_Index;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index);
   private
      Map        : Permission_Maps.Map;
      Next_Index : Permission_Index := Permission_Index'First;
   end Global_Index;

   protected body Global_Index is
      function Get_Permission_Index (Name : in String) return Permission_Index is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            return Permission_Maps.Element (Pos);
         else
            raise Invalid_Name with "There is no permission '" & Name & "'";
         end if;
      end Get_Permission_Index;

      --  Get the last permission index registered in the global permission map.
      function Get_Last_Permission_Index return Permission_Index is
      begin
         return Next_Index;
      end Get_Last_Permission_Index;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index) is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            Index := Permission_Maps.Element (Pos);
         else
            Index := Next_Index;
            Log.Debug ("Creating permission index {1} for {0}",
                       Name, Permission_Index'Image (Index));
            Map.Insert (Name, Index);
            Next_Index := Next_Index + 1;
         end if;
      end Add_Permission;

   end Global_Index;

   Permission_Indexes : Global_Index;

   --  ------------------------------
   --  Get the permission index associated with the name.
   --  ------------------------------
   function Get_Permission_Index (Name : in String) return Permission_Index is
   begin
      return Permission_Indexes.Get_Permission_Index (Name);
   end Get_Permission_Index;

   --  ------------------------------
   --  Get the last permission index registered in the global permission map.
   --  ------------------------------
   function Get_Last_Permission_Index return Permission_Index is
   begin
      return Permission_Indexes.Get_Last_Permission_Index;
   end Get_Last_Permission_Index;

   --  ------------------------------
   --  Add the permission name and allocate a unique permission index.
   --  ------------------------------
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index) is
   begin
      Permission_Indexes.Add_Permission (Name, Index);
   end Add_Permission;

   --  ------------------------------
   --  Find the access rule of the policy that matches the given URI.
   --  Returns the No_Rule value (disable access) if no rule is found.
   --  ------------------------------
   function Find_Access_Rule (Manager : in Permission_Manager;
                              URI     : in String) return Access_Rule_Ref is

      Matched : Boolean := False;
      Result  : Access_Rule_Ref;

      procedure Match (P : in Policy);

      procedure Match (P : in Policy) is
      begin
         if GNAT.Regexp.Match (URI, P.Pattern) then
            Matched := True;
            Result  := P.Rule;
         end if;
      end Match;

      Last : constant Natural := Manager.Policies.Last_Index;
   begin
      for I in 1 .. Last loop
         Manager.Policies.Query_Element (I, Match'Access);
         if Matched then
            return Result;
         end if;
      end loop;
      return Result;
   end Find_Access_Rule;

   procedure Add_Permission (Manager    : in out Permission_Manager;
                             Name       : in String;
                             Permission : in Controller_Access) is
      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

      Add_Permission (Name, Index);
      if Index >= Manager.Last_Index then
         declare
            Count : constant Permission_Index := Index + 32;
            Perms : constant Controller_Access_Array_Access
              := new Controller_Access_Array (0 .. Count);
         begin
            if Manager.Permissions /= null then
               Perms (Manager.Permissions'Range) := Manager.Permissions.all;
            end if;
            Manager.Permissions := Perms;
            Manager.Last_Index := Count;
         end;
      end if;
      Manager.Permissions (Index) := Permission;
   end Add_Permission;

   --  ------------------------------
   --  Returns True if the user has the permission to access the given URI permission.
   --  ------------------------------
   function Has_Permission (Manager    : in Permission_Manager;
                            Context    : in Security_Context_Access;
                            Permission : in URI_Permission'Class) return Boolean is
      Name  : constant String_Ref := To_String_Ref (Permission.URI);
      Ref   : constant Rules_Ref.Ref := Manager.Cache.Get;
      Rules : constant Rules_Access := Ref.Value;
      Pos   : constant Rules_Maps.Cursor := Rules.Map.Find (Name);
      Rule  : Access_Rule_Ref;
   begin
      --  If the rule is not in the cache, search for the access rule that
      --  matches our URI.  Update the cache.  This cache update is thread-safe
      --  as the cache map is never modified: a new cache map is installed.
      if not Rules_Maps.Has_Element (Pos) then
         declare
            New_Ref : constant Rules_Ref.Ref := Rules_Ref.Create;
         begin
            Rule := Manager.Find_Access_Rule (Permission.URI);
            New_Ref.Value.all.Map := Rules.Map;
            New_Ref.Value.all.Map.Insert (Name, Rule);
            Manager.Cache.Set (New_Ref);
         end;
      else
         Rule := Rules_Maps.Element (Pos);
      end if;

      --  Check if the user has one of the required permission.
      declare
         P       : constant Access_Rule_Access := Rule.Value;
         Granted : Boolean;
      begin
         if P /= null then
            for I in P.Permissions'Range loop
               Context.Has_Permission (P.Permissions (I), Granted);
               if Granted then
                  return True;
               end if;
            end loop;
         end if;
      end;
      return False;
   end Has_Permission;

   --  ------------------------------
   --  Returns True if the user has the given role permission.
   --  ------------------------------
   function Has_Permission (Manager    : in Permission_Manager;
                            User       : in Principal'Class;
                            Permission : in Permission_Type) return Boolean is
      pragma Unreferenced (Manager);
   begin
      --        return User.Has_Permission (Permission);
      return False;
   end Has_Permission;

   --  ------------------------------
   --  Get the security controller associated with the permission index Index.
   --  Returns null if there is no such controller.
   --  ------------------------------
   function Get_Controller (Manager : in Permission_Manager'Class;
                            Index   : in Permission_Index) return Controller_Access is
   begin
      if Index >= Manager.Last_Index then
         return null;
      else
         return Manager.Permissions (Index);
      end if;
   end Get_Controller;

   --  ------------------------------
   --  Get the role name.
   --  ------------------------------
   function Get_Role_Name (Manager : in Permission_Manager;
                           Role    : in Role_Type) return String is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      if Manager.Names (Role) = null then
         return "";
      else
         return Manager.Names (Role).all;
      end if;
   end Get_Role_Name;

   --  ------------------------------
   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   --  ------------------------------
   function Find_Role (Manager : in Permission_Manager;
                       Name    : in String) return Role_Type is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      Log.Debug ("Searching role {0}", Name);

      for I in Role_Type'First .. Manager.Next_Role loop
         exit when Manager.Names (I) = null;
         if Name = Manager.Names (I).all then
            return I;
         end if;
      end loop;

      Log.Debug ("Role {0} not found", Name);
      raise Invalid_Name;
   end Find_Role;

   --  ------------------------------
   --  Create a role
   --  ------------------------------
   procedure Create_Role (Manager : in out Permission_Manager;
                          Name    : in String;
                          Role    : out Role_Type) is
   begin
      Role := Manager.Next_Role;
      Log.Info ("Role {0} is {1}", Name, Role_Type'Image (Role));

      if Manager.Next_Role = Role_Type'Last then
         Log.Error ("Too many roles allocated.  Number of roles is {0}",
                    Role_Type'Image (Role_Type'Last));
      else
         Manager.Next_Role := Manager.Next_Role + 1;
      end if;
      Manager.Names (Role) := new String '(Name);
   end Create_Role;

   --  Grant the permission to access to the given URI to users having the To
   --  permissions.
   procedure Grant_URI_Permission (Manager : in out Permission_Manager;
                                   URI     : in String;
                                   To      : in String) is
   begin
      null;
   end Grant_URI_Permission;

   --  Grant the permission to access to the given Path to users having the To
   --  permissions.
   procedure Grant_File_Permission (Manager : in out Permission_Manager;
                                    Path    : in String;
                                    To      : in String) is
   begin
      null;
   end Grant_File_Permission;

   --  ------------------------------
   --  Get or build a permission type for the given name.
   --  ------------------------------
   procedure Add_Role_Type (Manager   : in out Permission_Manager;
                            Name      : in String;
                            Result    : out Role_Type) is
   begin
      Result := Manager.Find_Role (Name);

   exception
      when Invalid_Name =>
         Manager.Create_Role (Name, Result);
   end Add_Role_Type;

   type Policy_Fields is (FIELD_ID, FIELD_PERMISSION, FIELD_URL_PATTERN, FIELD_POLICY);

   procedure Set_Member (P     : in out Policy_Config;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object);

   procedure Process (Policy : in Policy_Config);

   procedure Set_Member (P     : in out Policy_Config;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_ID =>
            P.Id := Util.Beans.Objects.To_Integer (Value);

         when FIELD_PERMISSION =>
            P.Permissions.Append (Value);

         when FIELD_URL_PATTERN =>
            P.Patterns.Append (Value);

         when FIELD_POLICY =>
            Process (P);
            P.Id := 0;
            P.Permissions.Clear;
            P.Patterns.Clear;

      end case;
   end Set_Member;

   procedure Process (Policy : in Policy_Config) is
      Pol    : Security.Permissions.Policy;
      Count  : constant Natural := Natural (Policy.Permissions.Length);
      Rule   : constant Access_Rule_Ref := Access_Rule_Refs.Create (new Access_Rule (Count));
      Iter   : Util.Beans.Objects.Vectors.Cursor := Policy.Permissions.First;
      Pos    : Positive := 1;
   begin
      Pol.Rule := Rule;

      --  Step 1: Initialize the list of permission index in Access_Rule from the permission names.
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Perm : constant Util.Beans.Objects.Object := Util.Beans.Objects.Vectors.Element (Iter);
            Name : constant String := Util.Beans.Objects.To_String (Perm);
         begin
            Rule.Value.all.Permissions (Pos) := Get_Permission_Index (Name);
            Pos := Pos + 1;

         exception
            when Invalid_Name =>
               raise Util.Serialize.Mappers.Field_Error with "Invalid permission: " & Name;
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;

      --  Step 2: Create one policy for each URL pattern
      Iter := Policy.Patterns.First;
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Pattern : constant Util.Beans.Objects.Object
              := Util.Beans.Objects.Vectors.Element (Iter);
         begin
            Pol.Id   := Policy.Id;
            Pol.Pattern := GNAT.Regexp.Compile (Util.Beans.Objects.To_String (Pattern));
            Policy.Manager.Policies.Append (Pol);
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;
   end Process;

   package Policy_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Policy_Config,
                                               Element_Type_Access => Policy_Config_Access,
                                               Fields              => Policy_Fields,
                                               Set_Member          => Set_Member);

   Policy_Mapping        : aliased Policy_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the servlet and mapping rules context-param,
   --  filter-mapping and servlet-mapping.
   --  ------------------------------
   package body Reader_Config is
   begin
      Reader.Add_Mapping ("policy-rules", Policy_Mapping'Access);
      Reader.Add_Mapping ("module", Policy_Mapping'Access);
      Config.Manager := Manager;
      Policy_Mapper.Set_Context (Reader, Config'Unchecked_Access);
   end Reader_Config;

   --  ------------------------------
   --  Read the policy file
   --  ------------------------------
   procedure Read_Policy (Manager : in out Permission_Manager;
                          File    : in String) is

      use Util;

      Reader : Util.Serialize.IO.XML.Parser;

      package Policy_Config is
        new Reader_Config (Reader, Manager'Unchecked_Access);
      package Role_Config is
        new Security.Controllers.Roles.Reader_Config (Reader, Manager'Unchecked_Access);
      pragma Warnings (Off, Policy_Config);
      pragma Warnings (Off, Role_Config);
   begin
      Log.Info ("Reading policy file {0}", File);

      Reader.Parse (File);

   end Read_Policy;

   --  ------------------------------
   --  Initialize the permission manager.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out Permission_Manager) is
   begin
      Manager.Cache := new Rules_Ref.Atomic_Ref;
      Manager.Cache.Set (Rules_Ref.Create);
   end Initialize;

   --  ------------------------------
   --  Finalize the permission manager.
   --  ------------------------------
   overriding
   procedure Finalize (Manager : in out Permission_Manager) is
      use Ada.Strings.Unbounded;
      use Security.Controllers;

      procedure Free is
        new Ada.Unchecked_Deallocation (Rules_Ref.Atomic_Ref,
                                        Rules_Ref_Access);
      procedure Free is
        new Ada.Unchecked_Deallocation (Security.Controllers.Controller'Class,
                                        Security.Controllers.Controller_Access);
      procedure Free is
        new Ada.Unchecked_Deallocation (Controller_Access_Array,
                                        Controller_Access_Array_Access);

   begin
      Free (Manager.Cache);
      for I in Manager.Names'Range loop
         exit when Manager.Names (I) = null;
         Ada.Strings.Unbounded.Free (Manager.Names (I));
      end loop;

      if Manager.Permissions /= null then
         for I in Manager.Permissions.all'Range loop
            exit when Manager.Permissions (I) = null;

            --  SCz 2011-12-03: GNAT 2011 reports a compilation error:
            --  'missing "with" clause on package "Security.Controllers"'
            --  if we use the 'Security.Controller_Access' type, even if this "with" clause exist.
            --  gcc 4.4.3 under Ubuntu does not have this issue.
            --  We use the 'Security.Controllers.Controller_Access' type to avoid the compiler bug
            --  but we have to use a temporary variable and do some type conversion...
            declare
               P : Security.Controllers.Controller_Access := Manager.Permissions (I).all'Access;
            begin
               Free (P);
               Manager.Permissions (I) := null;
            end;
         end loop;
         Free (Manager.Permissions);
      end if;
   end Finalize;

   package body Permission_ACL is
      P : Permission_Index;

      function Permission return Permission_Index is
      begin
         return P;
      end Permission;

   begin
      Add_Permission (Name => Name, Index => P);
   end Permission_ACL;

   --  ------------------------------
   --  EL function to check if the given permission name is granted by the current
   --  security context.
   --  ------------------------------
   function Has_Permission (Value : in Util.Beans.Objects.Object)
                            return Util.Beans.Objects.Object is
      Name   : constant String := Util.Beans.Objects.To_String (Value);
   begin
      if Security.Contexts.Has_Permission (Name) then
         return Util.Beans.Objects.To_Object (True);
      else
         return Util.Beans.Objects.To_Object (False);
      end if;
   end Has_Permission;

   --  ------------------------------
   --  Register a set of functions in the namespace
   --  xmlns:fn="http://code.google.com/p/ada-asf/auth"
   --  Functions:
   --    hasPermission(NAME)   --  Returns True if the permission NAME is granted
   --  ------------------------------
--   procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class) is
--   begin
--      Mapper.Set_Function (Name      => HAS_PERMISSION_FN,
--                           Namespace => AUTH_NAMESPACE_URI,
--                           Func      => Has_Permission'Access);
--   end Set_Functions;

begin
   Policy_Mapping.Add_Mapping ("policy", FIELD_POLICY);
   Policy_Mapping.Add_Mapping ("policy/@id", FIELD_ID);
   Policy_Mapping.Add_Mapping ("policy/permission", FIELD_PERMISSION);
   Policy_Mapping.Add_Mapping ("policy/url-pattern", FIELD_URL_PATTERN);
end Security.Permissions;

-----------------------------------------------------------------------
--  security-permissions -- Definition of permissions
--  Copyright (C) 2010, 2011 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.Unchecked_Deallocation;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;

with Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Contexts;
with Security.Controllers;
with Security.Controllers.Roles;

--  The <b>Security.Permissions</b> package defines the different permissions that can be
--  checked by the access control manager.
package body Security.Permissions is

   use Util.Log;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Permissions");

   --  A global map to translate a string to a permission index.
   package Permission_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Permission_Index,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => "=");

   protected type Global_Index is
      --  Get the permission index
      function Get_Permission_Index (Name : in String) return Permission_Index;

      --  Get the last permission index registered in the global permission map.
      function Get_Last_Permission_Index return Permission_Index;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index);
   private
      Map        : Permission_Maps.Map;
      Next_Index : Permission_Index := Permission_Index'First;
   end Global_Index;

   protected body Global_Index is
      function Get_Permission_Index (Name : in String) return Permission_Index is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            return Permission_Maps.Element (Pos);
         else
            raise Invalid_Name with "There is no permission '" & Name & "'";
         end if;
      end Get_Permission_Index;

      --  Get the last permission index registered in the global permission map.
      function Get_Last_Permission_Index return Permission_Index is
      begin
         return Next_Index;
      end Get_Last_Permission_Index;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index) is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            Index := Permission_Maps.Element (Pos);
         else
            Index := Next_Index;
            Log.Debug ("Creating permission index {1} for {0}",
                       Name, Permission_Index'Image (Index));
            Map.Insert (Name, Index);
            Next_Index := Next_Index + 1;
         end if;
      end Add_Permission;

   end Global_Index;

   Permission_Indexes : Global_Index;

   --  ------------------------------
   --  Get the permission index associated with the name.
   --  ------------------------------
   function Get_Permission_Index (Name : in String) return Permission_Index is
   begin
      return Permission_Indexes.Get_Permission_Index (Name);
   end Get_Permission_Index;

   --  ------------------------------
   --  Get the last permission index registered in the global permission map.
   --  ------------------------------
   function Get_Last_Permission_Index return Permission_Index is
   begin
      return Permission_Indexes.Get_Last_Permission_Index;
   end Get_Last_Permission_Index;

   --  ------------------------------
   --  Add the permission name and allocate a unique permission index.
   --  ------------------------------
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index) is
   begin
      Permission_Indexes.Add_Permission (Name, Index);
   end Add_Permission;

   package body Permission_ACL is
      P : Permission_Index;

      function Permission return Permission_Index is
      begin
         return P;
      end Permission;

   begin
      Add_Permission (Name => Name, Index => P);
   end Permission_ACL;

end Security.Permissions;

Remove the implementation of old operations which are now in Security.Policy, Security.Policy.Roles and Security.Policy.URLs


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

--  == Permission ==
--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.  An application should declare each permission
--  by instantiating the <tt>Definition</tt> package:
--
--    package Perm_Create_Workspace is new Security.Permissions.Definition ("create-workspace");
--
--  This declares a permission that can be represented by "<tt>create-workspace</tt>" in
--  configuration files.  In Ada, the permission is used as follows:
--
--     Perm_Create_Workspace.Permission
--
package Security.Permissions is

   Invalid_Name   : exception;

   --  Max number of permissions supported by the implementation.
   MAX_PERMISSION : constant Natural := 255;

   type Permission_Index is new Natural range 0 .. MAX_PERMISSION;

   type Permission_Index_Array is array (Positive range <>) of Permission_Index;

   NONE : constant Permission_Index := Permission_Index'First;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  The permission root class.
   --  Each permission is represented by a Permission_Index number to provide a fast
   --  and efficient permission check.
   type Permission (Id : Permission_Index) is tagged limited null record;

   generic
      Name : String;
   package Definition is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Definition;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

   type Permission_Index_Set is private;

   --  Check if the permission index set contains the given permission index.
   function Has_Permission (Set   : in Permission_Index_Set;
                            Index : in Permission_Index) return Boolean;

   --  Add the permission index to the set.
   procedure Add_Permission (Set   : in out Permission_Index_Set;
                             Index : in Permission_Index);

   --  The empty set of permission indexes.
   EMPTY_SET : constant Permission_Index_Set;

private

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

   INDEX_SET_SIZE : constant Natural := (MAX_PERMISSION + 7) / 8;

   type Permission_Index_Set is array (0 .. INDEX_SET_SIZE - 1) of Interfaces.Unsigned_8;

   EMPTY_SET : constant Permission_Index_Set := (others => 0);

end Security.Permissions;

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

--  == Permission ==
--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.  An application should declare each permission
--  by instantiating the <tt>Definition</tt> package:
--
--    package Perm_Create_Workspace is new Security.Permissions.Definition ("create-workspace");
--
--  This declares a permission that can be represented by "<tt>create-workspace</tt>" in
--  configuration files.  In Ada, the permission is used as follows:
--
--     Perm_Create_Workspace.Permission
--
package Security.Permissions is

   Invalid_Name   : exception;

   --  Max number of permissions supported by the implementation.
   MAX_PERMISSION : constant Natural := 255;

   type Permission_Index is new Natural range 0 .. MAX_PERMISSION;

   type Permission_Index_Array is array (Positive range <>) of Permission_Index;

   NONE : constant Permission_Index := Permission_Index'First;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  Get the permission name given the index.
   function Get_Name (Index : in Permission_Index) return String;

   --  The permission root class.
   --  Each permission is represented by a Permission_Index number to provide a fast
   --  and efficient permission check.
   type Permission (Id : Permission_Index) is tagged limited null record;

   generic
      Name : String;
   package Definition is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Definition;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

   type Permission_Index_Set is private;

   --  Check if the permission index set contains the given permission index.
   function Has_Permission (Set   : in Permission_Index_Set;
                            Index : in Permission_Index) return Boolean;

   --  Add the permission index to the set.
   procedure Add_Permission (Set   : in out Permission_Index_Set;
                             Index : in Permission_Index);

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

   --  The empty set of permission indexes.
   EMPTY_SET : constant Permission_Index_Set;

private

   INDEX_SET_SIZE : constant Natural := (MAX_PERMISSION + 7) / 8;

   type Permission_Index_Set is array (0 .. INDEX_SET_SIZE - 1) of Interfaces.Unsigned_8;

   EMPTY_SET : constant Permission_Index_Set := (others => 0);

end Security.Permissions;

Declare the Get_Name function Make the Get_Last_Permission function public


-----------------------------------------------------------------------
--  security-permissions -- Definition of permissions
--  Copyright (C) 2010, 2011, 2012, 2016 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.
-----------------------------------------------------------------------
private with Interfaces;

--  == Permission ==
--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.  An application should declare each permission
--  by instantiating the <tt>Definition</tt> package:
--
--    package Perm_Create_Workspace is new Security.Permissions.Definition ("create-workspace");
--
--  This declares a permission that can be represented by "<tt>create-workspace</tt>" in
--  configuration files.  In Ada, the permission is used as follows:
--
--     Perm_Create_Workspace.Permission
--
package Security.Permissions is

   Invalid_Name   : exception;

   --  Max number of permissions supported by the implementation.
   MAX_PERMISSION : constant Natural := 256;

   type Permission_Index is new Natural range 0 .. MAX_PERMISSION;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  The permission root class.
   --  Each permission is represented by a Permission_Index number to provide a fast
   --  and efficient permission check.
   type Permission (Id : Permission_Index) is tagged limited null record;

   generic
      Name : String;
   package Definition is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Definition;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

   type Permission_Index_Set is private;

   --  Check if the permission index set contains the given permission index.
   function Has_Permission (Set   : in Permission_Index_Set;
                            Index : in Permission_Index) return Boolean;

private

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

   INDEX_SET_SIZE : constant Natural := (MAX_PERMISSION + 7) / 8;

   type Permission_Index_Set is array (1 .. INDEX_SET_SIZE) of Interfaces.Unsigned_8;

end Security.Permissions;

-----------------------------------------------------------------------
--  security-permissions -- Definition of permissions
--  Copyright (C) 2010, 2011, 2012, 2016 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.
-----------------------------------------------------------------------
private with Interfaces;

--  == Permission ==
--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.  An application should declare each permission
--  by instantiating the <tt>Definition</tt> package:
--
--    package Perm_Create_Workspace is new Security.Permissions.Definition ("create-workspace");
--
--  This declares a permission that can be represented by "<tt>create-workspace</tt>" in
--  configuration files.  In Ada, the permission is used as follows:
--
--     Perm_Create_Workspace.Permission
--
package Security.Permissions is

   Invalid_Name   : exception;

   --  Max number of permissions supported by the implementation.
   MAX_PERMISSION : constant Natural := 256;

   type Permission_Index is new Natural range 0 .. MAX_PERMISSION;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  The permission root class.
   --  Each permission is represented by a Permission_Index number to provide a fast
   --  and efficient permission check.
   type Permission (Id : Permission_Index) is tagged limited null record;

   generic
      Name : String;
   package Definition is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Definition;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

   type Permission_Index_Set is private;

   --  Check if the permission index set contains the given permission index.
   function Has_Permission (Set   : in Permission_Index_Set;
                            Index : in Permission_Index) return Boolean;

   --  Add the permission index to the set.
   procedure Add_Permission (Set   : in out Permission_Index_Set;
                             Index : in Permission_Index);

private

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

   INDEX_SET_SIZE : constant Natural := (MAX_PERMISSION + 7) / 8;

   type Permission_Index_Set is array (1 .. INDEX_SET_SIZE) of Interfaces.Unsigned_8;

end Security.Permissions;

Declare the Add_Permission procedure to add a permission index to the set