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

with Ada.Finalization;

with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;

with Security.Permissions;
limited with Security.Controllers;
limited with Security.Contexts;

--  == Security Policies ==
--  The Security Policy defines and implements the set of security rules that specify
--  how to protect the system or resources. The <tt>Policy_Manager</tt> maintains
--  the security policies.  These policies are registered when an application starts,
--  before reading the policy configuration files.
--
--  [[images/PolicyModel.png]]
--
--  While the policy configuration files are processed, the policy instances that have been
--  registered will create a security controller and bind it to a given permission.  After
--  successful initialization, the <tt>Policy_Manager</tt> contains a list of securiy
--  controllers which are associated with each permission defined by the application.
--
--  === Authenticated Permission ===
--  The `auth-permission` is a pre-defined permission that can be configured in the XML
--  configuration.  Basically the permission is granted if the security context has a principal.
--  Otherwise the permission is denied.  The permission is assigned a name and is declared
--  as follows:
--
--    <policy-rules>
--      <auth-permission>
--        <name>view-profile</name>
--      </auth-permission>
--    </policy-rules>
--
--  This example defines the `view-profile` permission.
--
--  === Grant Permission ===
--  The `grant-permission` is another pre-defined permission that gives the permission whatever
--  the security context.  The permission is defined as follows:
--
--    <policy-rules>
--      <grant-permission>
--        <name>anonymous</name>
--      </grant-permission>
--    </policy-rules>
--
--  This example defines the `anonymous` permission.
--
--  @include security-policies-roles.ads
--  @include security-policies-urls.ads
---  @include security-controllers.ads
package Security.Policies is

   type Security_Context_Access is access all Contexts.Security_Context'Class;

   type Controller_Access is access all Security.Controllers.Controller'Class;

   type Controller_Access_Array is
     array (Permissions.Permission_Index range <>) of Controller_Access;

   type Policy_Index is new Positive;

   type Policy_Context is limited interface;
   type Policy_Context_Access is access all Policy_Context'Class;

   type Policy_Context_Array is
     array (Policy_Index range <>) of Policy_Context_Access;
   type Policy_Context_Array_Access is access Policy_Context_Array;

   --  ------------------------------
   --  Security policy
   --  ------------------------------
   type Policy is abstract new Ada.Finalization.Limited_Controlled with private;
   type Policy_Access is access all Policy'Class;

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

   --  Get the policy index.
   function Get_Policy_Index (From : in Policy'Class) return Policy_Index;
   pragma Inline (Get_Policy_Index);

   --  Prepare the XML parser to read the policy configuration.
   procedure Prepare_Config (Pol     : in out Policy;
                             Reader  : in out Util.Serialize.IO.XML.Parser) is null;

   --  Finish reading the XML policy configuration.  The security policy implementation can use
   --  this procedure to perform any configuration setup after the configuration is parsed.
   procedure Finish_Config (Into    : in out Policy;
                            Reader  : in out Util.Serialize.IO.XML.Parser) is null;

   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   procedure Add_Permission (Manager    : in out Policy;
                             Name       : in String;
                             Permission : in Controller_Access);

   Invalid_Name : exception;

   Policy_Error : exception;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.
   type Policy_Manager (Max_Policies : Policy_Index) is
     new Ada.Finalization.Limited_Controlled with private;
   type Policy_Manager_Access is access all Policy_Manager'Class;

   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   function Get_Policy (Manager : in Policy_Manager;
                        Name    : in String) return Policy_Access;

   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access);

   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access);

   --  Checks whether the permission defined by the Permission controller data is granted
   --  by the security context passed in Context.
   --  Returns true if such permission is granted.
   function Has_Permission (Manager    : in Policy_Manager;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean;

   --  Returns True if the security controller is defined for the given permission index.
   function Has_Controller (Manager : in Policy_Manager;
                            Index   : in Permissions.Permission_Index) return Boolean;

   --  Create the policy contexts to be associated with the security context.
   function Create_Policy_Contexts (Manager : in Policy_Manager)
                                    return Policy_Context_Array_Access;

   --  Prepare the XML parser to read the policy configuration.
   procedure Prepare_Config (Manager : in out Policy_Manager;
                             Reader  : in out Util.Serialize.IO.XML.Parser);

   --  Finish reading the XML policy configuration.  The security policy implementation can use
   --  this procedure to perform any configuration setup after the configuration is parsed.
   procedure Finish_Config (Manager : in out Policy_Manager;
                            Reader  : in out Util.Serialize.IO.XML.Parser);

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

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out Policy_Manager);

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager);

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------
   type Policy_Config is record
      Id          : Natural := 0;
      Permissions : Util.Beans.Objects.Vectors.Vector;
      Patterns    : Util.Beans.Objects.Vectors.Vector;
      Manager     : Policy_Manager_Access;
   end record;
   type Policy_Config_Access is access all Policy_Config;

   --  Setup the XML parser to read the policy description.  For example:
   --
   --  <policy id='1'>
   --     <permission>create-workspace</permission>
   --     <permission>admin</permission>
   --     <url-pattern>/workspace/create</url-pattern>
   --     <url-pattern>/workspace/setup/*</url-pattern>
   --  </policy>
   --
   --  This policy gives access to the URL that match one of the URL pattern if the
   --  security context has the permission create-workspace or admin.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Manager : in Policy_Manager_Access;
   package Reader_Config is
      Config : aliased Policy_Config;
   end Reader_Config;

private

   subtype Permission_Index is Permissions.Permission_Index;

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

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type Policy_Access_Array is array (Policy_Index range <>) of Policy_Access;

   type Policy is abstract new Ada.Finalization.Limited_Controlled with record
      Manager : Policy_Manager_Access;
      Index   : Policy_Index := Policy_Index'First;
   end record;

   type Policy_Manager (Max_Policies : Policy_Index) is
     new Ada.Finalization.Limited_Controlled with record
      Permissions  : Controller_Access_Array_Access;
      Last_Index   : Permission_Index := Permission_Index'First;

      --  The security policies.
      Policies     : Policy_Access_Array (1 .. Max_Policies);
   end record;

end Security.Policies;

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

with Ada.Finalization;

with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;

with Security.Permissions;
with Util.Serialize.Mappers;
limited with Security.Controllers;
limited with Security.Contexts;

--  == Security Policies ==
--  The Security Policy defines and implements the set of security rules that specify
--  how to protect the system or resources. The <tt>Policy_Manager</tt> maintains
--  the security policies.  These policies are registered when an application starts,
--  before reading the policy configuration files.
--
--  [[images/PolicyModel.png]]
--
--  While the policy configuration files are processed, the policy instances that have been
--  registered will create a security controller and bind it to a given permission.  After
--  successful initialization, the <tt>Policy_Manager</tt> contains a list of securiy
--  controllers which are associated with each permission defined by the application.
--
--  === Authenticated Permission ===
--  The `auth-permission` is a pre-defined permission that can be configured in the XML
--  configuration.  Basically the permission is granted if the security context has a principal.
--  Otherwise the permission is denied.  The permission is assigned a name and is declared
--  as follows:
--
--    <policy-rules>
--      <auth-permission>
--        <name>view-profile</name>
--      </auth-permission>
--    </policy-rules>
--
--  This example defines the `view-profile` permission.
--
--  === Grant Permission ===
--  The `grant-permission` is another pre-defined permission that gives the permission whatever
--  the security context.  The permission is defined as follows:
--
--    <policy-rules>
--      <grant-permission>
--        <name>anonymous</name>
--      </grant-permission>
--    </policy-rules>
--
--  This example defines the `anonymous` permission.
--
--  @include security-policies-roles.ads
--  @include security-policies-urls.ads
---  @include security-controllers.ads
package Security.Policies is

   type Security_Context_Access is access all Contexts.Security_Context'Class;

   type Controller_Access is access all Security.Controllers.Controller'Class;

   type Controller_Access_Array is
     array (Permissions.Permission_Index range <>) of Controller_Access;

   type Policy_Index is new Positive;

   type Policy_Context is limited interface;
   type Policy_Context_Access is access all Policy_Context'Class;

   type Policy_Context_Array is
     array (Policy_Index range <>) of Policy_Context_Access;
   type Policy_Context_Array_Access is access Policy_Context_Array;

   --  ------------------------------
   --  Security policy
   --  ------------------------------
   type Policy is abstract new Ada.Finalization.Limited_Controlled with private;
   type Policy_Access is access all Policy'Class;

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

   --  Get the policy index.
   function Get_Policy_Index (From : in Policy'Class) return Policy_Index;
   pragma Inline (Get_Policy_Index);

   --  Prepare the XML parser to read the policy configuration.
   procedure Prepare_Config (Pol     : in out Policy;
                             Mapper  : in out Util.Serialize.Mappers.Processing) is null;

   --  Finish reading the XML policy configuration.  The security policy implementation can use
   --  this procedure to perform any configuration setup after the configuration is parsed.
   procedure Finish_Config (Into    : in out Policy;
                            Reader  : in out Util.Serialize.IO.XML.Parser) is null;

   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   procedure Add_Permission (Manager    : in out Policy;
                             Name       : in String;
                             Permission : in Controller_Access);

   Invalid_Name : exception;

   Policy_Error : exception;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.
   type Policy_Manager (Max_Policies : Policy_Index) is
     new Ada.Finalization.Limited_Controlled with private;
   type Policy_Manager_Access is access all Policy_Manager'Class;

   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   function Get_Policy (Manager : in Policy_Manager;
                        Name    : in String) return Policy_Access;

   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access);

   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access);

   --  Checks whether the permission defined by the Permission controller data is granted
   --  by the security context passed in Context.
   --  Returns true if such permission is granted.
   function Has_Permission (Manager    : in Policy_Manager;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean;

   --  Returns True if the security controller is defined for the given permission index.
   function Has_Controller (Manager : in Policy_Manager;
                            Index   : in Permissions.Permission_Index) return Boolean;

   --  Create the policy contexts to be associated with the security context.
   function Create_Policy_Contexts (Manager : in Policy_Manager)
                                    return Policy_Context_Array_Access;

   --  Prepare the XML parser to read the policy configuration.
   procedure Prepare_Config (Manager : in out Policy_Manager;
                             Mapper  : in out Util.Serialize.Mappers.Processing);

   --  Finish reading the XML policy configuration.  The security policy implementation can use
   --  this procedure to perform any configuration setup after the configuration is parsed.
   procedure Finish_Config (Manager : in out Policy_Manager;
                            Reader  : in out Util.Serialize.IO.XML.Parser);

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

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out Policy_Manager);

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager);

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------
   type Policy_Config is record
      Id          : Natural := 0;
      Permissions : Util.Beans.Objects.Vectors.Vector;
      Patterns    : Util.Beans.Objects.Vectors.Vector;
      Manager     : Policy_Manager_Access;
   end record;
   type Policy_Config_Access is access all Policy_Config;

   --  Setup the XML parser to read the policy description.  For example:
   --
   --  <policy id='1'>
   --     <permission>create-workspace</permission>
   --     <permission>admin</permission>
   --     <url-pattern>/workspace/create</url-pattern>
   --     <url-pattern>/workspace/setup/*</url-pattern>
   --  </policy>
   --
   --  This policy gives access to the URL that match one of the URL pattern if the
   --  security context has the permission create-workspace or admin.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Manager : in Policy_Manager_Access;
   package Reader_Config is
      Config : aliased Policy_Config;
   end Reader_Config;

private

   subtype Permission_Index is Permissions.Permission_Index;

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

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type Policy_Access_Array is array (Policy_Index range <>) of Policy_Access;

   type Policy is abstract new Ada.Finalization.Limited_Controlled with record
      Manager : Policy_Manager_Access;
      Index   : Policy_Index := Policy_Index'First;
   end record;

   type Policy_Manager (Max_Policies : Policy_Index) is
     new Ada.Finalization.Limited_Controlled with record
      Permissions  : Controller_Access_Array_Access;
      Last_Index   : Permission_Index := Permission_Index'First;

      --  The security policies.
      Policies     : Policy_Access_Array (1 .. Max_Policies);
   end record;

end Security.Policies;

Change the Mapper parameter to use the Mappers.Processing type


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

with Gen.Configs;
with Gen.Utils;
with Gen.Model.Tables;
with Gen.Model.Queries;
with Gen.Model.Mappings;

with Util.Log.Loggers;
with Util.Encoders.HMAC.SHA1;

--  The Gen.Artifacts.Query package is an artifact for the generation of
--  data structures returned by queries.
package body Gen.Artifacts.Query is

   use Ada.Strings.Unbounded;
   use Gen.Model;
   use Gen.Model.Tables;
   use Gen.Model.Queries;
   use Gen.Configs;

   use type DOM.Core.Node;
   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Artifacts.Query");

   --  ------------------------------
   --  After the configuration file is read, processes the node whose root
   --  is passed in Node and initializes the Model with the information.
   --  ------------------------------
   procedure Initialize (Handler : in out Artifact;
                         Path    : in String;
                         Node    : in DOM.Core.Node;
                         Model   : in out Gen.Model.Packages.Model_Definition'Class;
                         Context : in out Generator'Class) is

      procedure Register_Column (Table  : in out Query_Definition;
                                 Column : in DOM.Core.Node);

      procedure Register_Columns (Table : in out Query_Definition;
                                  Node  : in DOM.Core.Node);

      procedure Register_Mapping (Query : in out Gen.Model.Queries.Query_Definition;
                                  Node  : in DOM.Core.Node);

      procedure Register_Mapping (Model : in out Gen.Model.Packages.Model_Definition;
                                  Node  : in DOM.Core.Node);

      procedure Register_Query (Query : in out Gen.Model.Queries.Query_Definition;
                                Node  : in DOM.Core.Node);

      Hash : Unbounded_String;

      --  ------------------------------
      --  Register the column definition in the table
      --  ------------------------------
      procedure Register_Column (Table  : in out Query_Definition;
                                 Column : in DOM.Core.Node) is
         Name  : constant Unbounded_String := Gen.Utils.Get_Attribute (Column, "name");
         C     : constant Column_Definition_Access := new Column_Definition;
      begin
         C.Initialize (Name, Column);
         C.Number := Table.Members.Get_Count;
         Table.Members.Append (C);

         C.Type_Name := To_Unbounded_String (Gen.Utils.Get_Normalized_Type (Column, "type"));

         C.Is_Inserted := False;
         C.Is_Updated  := False;
         C.Not_Null    := False;
         C.Unique      := False;

         --  Construct the hash for this column mapping.
         Append (Hash, ",type=");
         Append (Hash, C.Type_Name);
         Append (Hash, ",name=");
         Append (Hash, Name);
      end Register_Column;

      --  ------------------------------
      --  Register all the columns defined in the table
      --  ------------------------------
      procedure Register_Columns (Table : in out Query_Definition;
                                  Node  : in DOM.Core.Node) is
         procedure Iterate is new Gen.Utils.Iterate_Nodes (T       => Query_Definition,
                                                           Process => Register_Column);
      begin
         Log.Debug ("Register columns from query {0}", Table.Name);

         Iterate (Table, Node, "property");
      end Register_Columns;

      --  ------------------------------
      --  Register a new class definition in the model.
      --  ------------------------------
      procedure Register_Mapping (Query : in out Gen.Model.Queries.Query_Definition;
                                  Node  : in DOM.Core.Node) is
         Name  : constant Unbounded_String := Gen.Utils.Get_Attribute (Node, "name");
      begin
         Query.Initialize (Name, Node);
         Query.Set_Table_Name (To_String (Name));

         if Name /= "" then
            Query.Name := Name;
         else
            Query.Name := To_Unbounded_String (Gen.Utils.Get_Query_Name (Path));
         end if;

         --  Construct the hash for this column mapping.
         Append (Hash, "class=");
         Append (Hash, Query.Name);

         Log.Debug ("Register query {0} with type {1}", Query.Name, Query.Type_Name);
         Register_Columns (Query, Node);
      end Register_Mapping;

      --  ------------------------------
      --  Register a new query.
      --  ------------------------------
      procedure Register_Query (Query : in out Gen.Model.Queries.Query_Definition;
                                Node  : in DOM.Core.Node) is
         Name : constant Unbounded_String := Gen.Utils.Get_Attribute (Node, "name");
         C    : Column_Definition_Access;
      begin
         Query.Add_Query (Name, C);
      end Register_Query;

      --  ------------------------------
      --  Register a model mapping
      --  ------------------------------
      procedure Register_Mapping (Model : in out Gen.Model.Packages.Model_Definition;
                                  Node  : in DOM.Core.Node) is
         procedure Iterate_Mapping is
           new Gen.Utils.Iterate_Nodes (T => Gen.Model.Queries.Query_Definition,
                                        Process => Register_Mapping);
         procedure Iterate_Query is
           new Gen.Utils.Iterate_Nodes (T => Gen.Model.Queries.Query_Definition,
                                        Process => Register_Query);

         Table : constant Query_Definition_Access := new Query_Definition;
         Pkg   : constant Unbounded_String := Gen.Utils.Get_Attribute (Node, "package");
         Name  : constant Unbounded_String := Gen.Utils.Get_Attribute (Node, "table");
      begin
         Table.Initialize (Name, Node);
         Table.File_Name := To_Unbounded_String (Ada.Directories.Simple_Name (Path));
         Table.Pkg_Name  := Pkg;
         Iterate_Mapping (Query_Definition (Table.all), Node, "class");
         Iterate_Query (Query_Definition (Table.all), Node, "query");
         if Length (Table.Pkg_Name) = 0 then
            Context.Error ("Missing or empty package attribute");
         else
            Model.Register_Query (Table);
         end if;

         Log.Info ("Query hash for {0} is {1}", Path, To_String (Hash));
         Table.Sha1 := Util.Encoders.HMAC.SHA1.Sign (Key  => "ADO.Queries",
                                                     Data => To_String (Hash));
      end Register_Mapping;

      procedure Iterate is new Gen.Utils.Iterate_Nodes (T => Gen.Model.Packages.Model_Definition,
                                                        Process => Register_Mapping);

   begin
      Log.Debug ("Initializing query artifact for the configuration");

      Gen.Artifacts.Artifact (Handler).Initialize (Path, Node, Model, Context);
      Iterate (Gen.Model.Packages.Model_Definition (Model), Node, "query-mapping");
   end Initialize;

   --  ------------------------------
   --  Prepare the generation of the package:
   --  o identify the column types which are used
   --  o build a list of package for the with clauses.
   --  ------------------------------
   overriding
   procedure Prepare (Handler : in out Artifact;
                      Model   : in out Gen.Model.Packages.Model_Definition'Class;
                      Context : in out Generator'Class) is
      pragma Unreferenced (Handler);
   begin
      Log.Debug ("Preparing the model for query");

      if Model.Has_Packages then
         Context.Add_Generation (Name => GEN_PACKAGE_SPEC, Mode => ITERATION_PACKAGE,
                                 Mapping => Gen.Model.Mappings.ADA_MAPPING);
         Context.Add_Generation (Name => GEN_PACKAGE_BODY, Mode => ITERATION_PACKAGE,
                                 Mapping => Gen.Model.Mappings.ADA_MAPPING);
      end if;
   end Prepare;

end Gen.Artifacts.Query;

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

with Gen.Configs;
with Gen.Utils;
with Gen.Model.Tables;
with Gen.Model.Queries;
with Gen.Model.Mappings;

with Util.Log.Loggers;
with Util.Encoders.HMAC.SHA1;

--  The Gen.Artifacts.Query package is an artifact for the generation of
--  data structures returned by queries.
package body Gen.Artifacts.Query is

   use Ada.Strings.Unbounded;
   use Gen.Model;
   use Gen.Model.Tables;
   use Gen.Model.Queries;
   use Gen.Configs;

   use type DOM.Core.Node;
   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Artifacts.Query");

   --  ------------------------------
   --  After the configuration file is read, processes the node whose root
   --  is passed in Node and initializes the Model with the information.
   --  ------------------------------
   procedure Initialize (Handler : in out Artifact;
                         Path    : in String;
                         Node    : in DOM.Core.Node;
                         Model   : in out Gen.Model.Packages.Model_Definition'Class;
                         Context : in out Generator'Class) is

      procedure Register_Column (Table  : in out Query_Definition;
                                 Column : in DOM.Core.Node);

      procedure Register_Columns (Table : in out Query_Definition;
                                  Node  : in DOM.Core.Node);

      procedure Register_Mapping (Query : in out Gen.Model.Queries.Query_Definition;
                                  Node  : in DOM.Core.Node);

      procedure Register_Mapping (Model : in out Gen.Model.Packages.Model_Definition;
                                  Node  : in DOM.Core.Node);

      procedure Register_Query (Query : in out Gen.Model.Queries.Query_Definition;
                                Node  : in DOM.Core.Node);

      Hash : Unbounded_String;

      --  ------------------------------
      --  Register the column definition in the table
      --  ------------------------------
      procedure Register_Column (Table  : in out Query_Definition;
                                 Column : in DOM.Core.Node) is
         Name  : constant Unbounded_String := Gen.Utils.Get_Attribute (Column, "name");
         C     : Column_Definition_Access;
      begin
         Table.Add_Column (Name, C);
         C.Initialize (Name, Column);

         C.Type_Name := To_Unbounded_String (Gen.Utils.Get_Normalized_Type (Column, "type"));

         C.Is_Inserted := False;
         C.Is_Updated  := False;
         C.Not_Null    := False;
         C.Unique      := False;

         --  Construct the hash for this column mapping.
         Append (Hash, ",type=");
         Append (Hash, C.Type_Name);
         Append (Hash, ",name=");
         Append (Hash, Name);
      end Register_Column;

      --  ------------------------------
      --  Register all the columns defined in the table
      --  ------------------------------
      procedure Register_Columns (Table : in out Query_Definition;
                                  Node  : in DOM.Core.Node) is
         procedure Iterate is new Gen.Utils.Iterate_Nodes (T       => Query_Definition,
                                                           Process => Register_Column);
      begin
         Log.Debug ("Register columns from query {0}", Table.Name);

         Iterate (Table, Node, "property");
      end Register_Columns;

      --  ------------------------------
      --  Register a new class definition in the model.
      --  ------------------------------
      procedure Register_Mapping (Query : in out Gen.Model.Queries.Query_Definition;
                                  Node  : in DOM.Core.Node) is
         Name  : constant Unbounded_String := Gen.Utils.Get_Attribute (Node, "name");
      begin
         Query.Initialize (Name, Node);
         Query.Set_Table_Name (To_String (Name));

         if Name /= "" then
            Query.Name := Name;
         else
            Query.Name := To_Unbounded_String (Gen.Utils.Get_Query_Name (Path));
         end if;

         --  Construct the hash for this column mapping.
         Append (Hash, "class=");
         Append (Hash, Query.Name);

         Log.Debug ("Register query {0} with type {1}", Query.Name, Query.Type_Name);
         Register_Columns (Query, Node);
      end Register_Mapping;

      --  ------------------------------
      --  Register a new query.
      --  ------------------------------
      procedure Register_Query (Query : in out Gen.Model.Queries.Query_Definition;
                                Node  : in DOM.Core.Node) is
         Name : constant Unbounded_String := Gen.Utils.Get_Attribute (Node, "name");
         C    : Column_Definition_Access;
      begin
         Query.Add_Query (Name, C);
      end Register_Query;

      --  ------------------------------
      --  Register a model mapping
      --  ------------------------------
      procedure Register_Mapping (Model : in out Gen.Model.Packages.Model_Definition;
                                  Node  : in DOM.Core.Node) is
         procedure Iterate_Mapping is
           new Gen.Utils.Iterate_Nodes (T => Gen.Model.Queries.Query_Definition,
                                        Process => Register_Mapping);
         procedure Iterate_Query is
           new Gen.Utils.Iterate_Nodes (T => Gen.Model.Queries.Query_Definition,
                                        Process => Register_Query);

         Table : constant Query_Definition_Access := new Query_Definition;
         Pkg   : constant Unbounded_String := Gen.Utils.Get_Attribute (Node, "package");
         Name  : constant Unbounded_String := Gen.Utils.Get_Attribute (Node, "table");
      begin
         Table.Initialize (Name, Node);
         Table.File_Name := To_Unbounded_String (Ada.Directories.Simple_Name (Path));
         Table.Pkg_Name  := Pkg;
         Iterate_Mapping (Query_Definition (Table.all), Node, "class");
         Iterate_Query (Query_Definition (Table.all), Node, "query");
         if Length (Table.Pkg_Name) = 0 then
            Context.Error ("Missing or empty package attribute");
         else
            Model.Register_Query (Table);
         end if;

         Log.Info ("Query hash for {0} is {1}", Path, To_String (Hash));
         Table.Sha1 := Util.Encoders.HMAC.SHA1.Sign (Key  => "ADO.Queries",
                                                     Data => To_String (Hash));
      end Register_Mapping;

      procedure Iterate is new Gen.Utils.Iterate_Nodes (T => Gen.Model.Packages.Model_Definition,
                                                        Process => Register_Mapping);

   begin
      Log.Debug ("Initializing query artifact for the configuration");

      Gen.Artifacts.Artifact (Handler).Initialize (Path, Node, Model, Context);
      Iterate (Gen.Model.Packages.Model_Definition (Model), Node, "query-mapping");
   end Initialize;

   --  ------------------------------
   --  Prepare the generation of the package:
   --  o identify the column types which are used
   --  o build a list of package for the with clauses.
   --  ------------------------------
   overriding
   procedure Prepare (Handler : in out Artifact;
                      Model   : in out Gen.Model.Packages.Model_Definition'Class;
                      Context : in out Generator'Class) is
      pragma Unreferenced (Handler);
   begin
      Log.Debug ("Preparing the model for query");

      if Model.Has_Packages then
         Context.Add_Generation (Name => GEN_PACKAGE_SPEC, Mode => ITERATION_PACKAGE,
                                 Mapping => Gen.Model.Mappings.ADA_MAPPING);
         Context.Add_Generation (Name => GEN_PACKAGE_BODY, Mode => ITERATION_PACKAGE,
                                 Mapping => Gen.Model.Mappings.ADA_MAPPING);
      end if;
   end Prepare;

end Gen.Artifacts.Query;

Use Add_Column to create a new column in a table


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

with Ada.Containers.Hashed_Maps;
with Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Hash;

with Util.Beans.Objects;

with Gen.Model.List;
with Gen.Model.Packages;
with Gen.Model.Mappings;
with Gen.Model.Operations;
package Gen.Model.Tables is

   use Ada.Strings.Unbounded;

   type Table_Definition;
   type Table_Definition_Access is access all Table_Definition'Class;

   --  ------------------------------
   --  Column Definition
   --  ------------------------------
   type Column_Definition is new Definition with record
      Number : Natural := 0;
      Table  : Table_Definition_Access;

      --  Whether the column must not be null in the database
      Not_Null : Boolean := False;

      --  Whether the column must be unique
      Unique   : Boolean := False;

      --  The column type name.
      Type_Name : Unbounded_String;

      --  The SQL type associated with the column.
      Sql_Type : Unbounded_String;

      --  The SQL name associated with the column.
      Sql_Name : Unbounded_String;

      --  True if this column is the optimistic locking version column.
      Is_Version : Boolean := False;

      --  True if this column is the primary key column.
      Is_Key : Boolean := False;

      --  True if the column can be read by the application.
      Is_Readable  : Boolean := True;

      --  True if the column is included in the insert statement
      Is_Inserted  : Boolean := True;

      --  True if the column is included in the update statement
      Is_Updated   : Boolean := True;

      --  True if the Ada mapping must use the foreign key type.
      Use_Foreign_Key_Type : Boolean := False;

      --  The class generator to use for this column.
      Generator    : Util.Beans.Objects.Object;
   end record;
   type Column_Definition_Access is access all Column_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Column_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Column_Definition);

   --  Returns true if the column type is a basic type.
   function Is_Basic_Type (From : Column_Definition) return Boolean;

   --  Returns the column type.
   function Get_Type (From : Column_Definition) return String;

   --  Returns the column type mapping.
   function Get_Type_Mapping (From : in Column_Definition)
                              return Gen.Model.Mappings.Mapping_Definition_Access;

   package Column_List is new Gen.Model.List (T         => Column_Definition,
                                              T_Access  => Column_Definition_Access);

   --  ------------------------------
   --  Association Definition
   --  ------------------------------
   type Association_Definition is new Column_Definition with private;
   type Association_Definition_Access is access all Association_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Association_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   package Operation_List is
     new Gen.Model.List (T         => Gen.Model.Operations.Operation_Definition,
                         T_Access  => Gen.Model.Operations.Operation_Definition_Access);

   --  ------------------------------
   --  Table Definition
   --  ------------------------------
   type Table_Definition is new Mappings.Mapping_Definition with record
      Members        : aliased Column_List.List_Definition;
      Members_Bean   : Util.Beans.Objects.Object;
      Operations     : aliased Operation_List.List_Definition;
      Operations_Bean : Util.Beans.Objects.Object;
      Parent         : Table_Definition_Access;
      Package_Def    : Gen.Model.Packages.Package_Definition_Access;
      Type_Name      : Unbounded_String;
      Pkg_Name       : Unbounded_String;
      Table_Name     : Unbounded_String;
      Version_Column : Column_Definition_Access;
      Id_Column      : Column_Definition_Access;
      Has_Associations : Boolean := False;

      --  Controls whether the <tt>Vector</tt> type and the <tt>List</tt> procedure must
      --  be generated.
      Has_List         : Boolean := True;
   end record;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Table_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Table_Definition);

   --  Initialize the table definition instance.
   overriding
   procedure Initialize (O : in out Table_Definition);

   --  Create a table with the given name.
   function Create_Table (Name : in Unbounded_String) return Table_Definition_Access;

   --  Create a table column with the given name and add it to the table.
   procedure Add_Column (Table  : in out Table_Definition;
                         Name   : in Unbounded_String;
                         Column : out Column_Definition_Access);

   --  Create a table association with the given name and add it to the table.
   procedure Add_Association (Table  : in out Table_Definition;
                              Name   : in Unbounded_String;
                              Assoc  : out Association_Definition_Access);

   --  Set the table name and determines the package name.
   procedure Set_Table_Name (Table : in out Table_Definition;
                             Name  : in String);

   package Table_Map is
     new Ada.Containers.Hashed_Maps (Key_Type        => Unbounded_String,
                                     Element_Type    => Table_Definition_Access,
                                     Hash            => Ada.Strings.Unbounded.Hash,
                                     Equivalent_Keys => "=");

   subtype Table_Cursor is Table_Map.Cursor;

   --  Returns true if the table cursor contains a valid table
   function Has_Element (Position : Table_Cursor) return Boolean
     renames Table_Map.Has_Element;

   --  Returns the table definition.
   function Element (Position : Table_Cursor) return Table_Definition_Access
     renames Table_Map.Element;

   --  Move the iterator to the next table definition.
   procedure Next (Position : in out Table_Cursor)
     renames Table_Map.Next;

private

   type Association_Definition is new Column_Definition with null record;

end Gen.Model.Tables;

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

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;
with Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Hash;

with Util.Beans.Objects;

with Gen.Model.List;
with Gen.Model.Packages;
with Gen.Model.Mappings;
with Gen.Model.Operations;
package Gen.Model.Tables is

   use Ada.Strings.Unbounded;

   type Table_Definition;
   type Table_Definition_Access is access all Table_Definition'Class;

   --  ------------------------------
   --  Column Definition
   --  ------------------------------
   type Column_Definition is new Definition with record
      Number : Natural := 0;
      Table  : Table_Definition_Access;

      --  Whether the column must not be null in the database
      Not_Null : Boolean := False;

      --  Whether the column must be unique
      Unique   : Boolean := False;

      --  The column type name.
      Type_Name : Unbounded_String;

      --  The SQL type associated with the column.
      Sql_Type : Unbounded_String;

      --  The SQL name associated with the column.
      Sql_Name : Unbounded_String;

      --  True if this column is the optimistic locking version column.
      Is_Version : Boolean := False;

      --  True if this column is the primary key column.
      Is_Key : Boolean := False;

      --  True if the column can be read by the application.
      Is_Readable  : Boolean := True;

      --  True if the column is included in the insert statement
      Is_Inserted  : Boolean := True;

      --  True if the column is included in the update statement
      Is_Updated   : Boolean := True;

      --  True if the Ada mapping must use the foreign key type.
      Use_Foreign_Key_Type : Boolean := False;

      --  The class generator to use for this column.
      Generator    : Util.Beans.Objects.Object;
   end record;
   type Column_Definition_Access is access all Column_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Column_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Column_Definition);

   --  Returns true if the column type is a basic type.
   function Is_Basic_Type (From : Column_Definition) return Boolean;

   --  Returns the column type.
   function Get_Type (From : Column_Definition) return String;

   --  Returns the column type mapping.
   function Get_Type_Mapping (From : in Column_Definition)
                              return Gen.Model.Mappings.Mapping_Definition_Access;

   package Column_List is new Gen.Model.List (T         => Column_Definition,
                                              T_Access  => Column_Definition_Access);

   --  ------------------------------
   --  Association Definition
   --  ------------------------------
   type Association_Definition is new Column_Definition with private;
   type Association_Definition_Access is access all Association_Definition'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Association_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   package Operation_List is
     new Gen.Model.List (T         => Gen.Model.Operations.Operation_Definition,
                         T_Access  => Gen.Model.Operations.Operation_Definition_Access);

   package Table_Vectors is new Ada.Containers.Vectors (Index_Type   => Positive,
                                                        Element_Type => Table_Definition_Access);
   --  ------------------------------
   --  Table Definition
   --  ------------------------------
   type Table_Definition is new Mappings.Mapping_Definition with record
      Members        : aliased Column_List.List_Definition;
      Members_Bean   : Util.Beans.Objects.Object;
      Operations     : aliased Operation_List.List_Definition;
      Operations_Bean : Util.Beans.Objects.Object;
      Parent         : Table_Definition_Access;
      Package_Def    : Gen.Model.Packages.Package_Definition_Access;
      Type_Name      : Unbounded_String;
      Pkg_Name       : Unbounded_String;
      Table_Name     : Unbounded_String;
      Version_Column : Column_Definition_Access;
      Id_Column      : Column_Definition_Access;
      Has_Associations : Boolean := False;

      --  The list of tables that this table depends on.
      Dependencies     : Table_Vectors.Vector;

      --  Controls whether the <tt>Vector</tt> type and the <tt>List</tt> procedure must
      --  be generated.
      Has_List         : Boolean := True;
   end record;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Table_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Table_Definition);

   --  Initialize the table definition instance.
   overriding
   procedure Initialize (O : in out Table_Definition);

   --  Collect the dependencies to other tables.
   procedure Collect_Dependencies (O : in out Table_Definition);

   type Dependency_Type is (NONE, FORWARD, BACKWARD);  -- CIRCULAR is not yet managed.

   --  Get the dependency between the two tables.
   --  Returns NONE if both table don't depend on each other.
   --  Returns FORWARD if the <tt>Left</tt> table depends on <tt>Right</tt>.
   --  Returns BACKWARD if the <tt>Right</tt> table depends on <tt>Left</tt>.
   function Depends_On (Left, Right : in Table_Definition_Access) return Dependency_Type;

   --  Create a table with the given name.
   function Create_Table (Name : in Unbounded_String) return Table_Definition_Access;

   --  Create a table column with the given name and add it to the table.
   procedure Add_Column (Table  : in out Table_Definition;
                         Name   : in Unbounded_String;
                         Column : out Column_Definition_Access);

   --  Create a table association with the given name and add it to the table.
   procedure Add_Association (Table  : in out Table_Definition;
                              Name   : in Unbounded_String;
                              Assoc  : out Association_Definition_Access);

   --  Set the table name and determines the package name.
   procedure Set_Table_Name (Table : in out Table_Definition;
                             Name  : in String);

   package Table_Map is
     new Ada.Containers.Hashed_Maps (Key_Type        => Unbounded_String,
                                     Element_Type    => Table_Definition_Access,
                                     Hash            => Ada.Strings.Unbounded.Hash,
                                     Equivalent_Keys => "=");

   subtype Table_Cursor is Table_Map.Cursor;

   --  Returns true if the table cursor contains a valid table
   function Has_Element (Position : Table_Cursor) return Boolean
     renames Table_Map.Has_Element;

   --  Returns the table definition.
   function Element (Position : Table_Cursor) return Table_Definition_Access
     renames Table_Map.Element;

   --  Move the iterator to the next table definition.
   procedure Next (Position : in out Table_Cursor)
     renames Table_Map.Next;

private

   type Association_Definition is new Column_Definition with null record;

end Gen.Model.Tables;

Add support to manage table dependencies - keep the dependencies for each table, - new operation Depends_On to get the dependency status bewteen two tables


--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

with Definitions;  use Definitions;

with HelperText;
private with Utilities;

package Parameters is

   package HT renames HelperText;

   no_ccache     : constant String := "none";
   no_unkindness : constant String := "none";
   raven_confdir : constant String := host_localbase & "/etc/ravenadm";

   type configuration_record is
      record
         profile         : HT.Text;
         dir_sysroot     : HT.Text;
         dir_toolchain   : HT.Text;
         dir_localbase   : HT.Text;
         dir_conspiracy  : HT.Text;
         dir_unkindness  : HT.Text;
         dir_distfiles   : HT.Text;
         dir_packages    : HT.Text;
         dir_ccache      : HT.Text;
         dir_buildbase   : HT.Text;
         dir_logs        : HT.Text;
         num_builders    : builders;
         jobs_limit      : builders;
         avoid_tmpfs     : Boolean;
         record_options  : Boolean;
         avec_ncurses    : Boolean;
         defer_prebuilt  : Boolean;

         --  Computed, not saved
         number_cores    : cpu_range;
         dir_repository  : HT.Text;
         sysroot_pkg8    : HT.Text;
      end record;

   configuration  : configuration_record;
   active_profile : HT.Text;

   --  This procedure will create a default configuration file if one
   --  does not already exist, otherwise it will it load it.  In every case,
   --  the "configuration" record will be populated after this is run.
   --  returns "True" on success
   function load_configuration return Boolean;

   --  Maybe a previously valid directory path has been removed.  This
   --  function returns true when all the paths still work.
   --  The configuration must be loaded before it's run, of course.
   function all_paths_valid return Boolean;

   --  Return true if the localbase is set to someplace it really shouldn't be
   function forbidden_localbase (candidate : String) return Boolean;

   --  Return a profile record filled with dynamic defaults.
   function default_profile (new_profile : String) return configuration_record;

   --  Delete any existing profile data and create a new profile.
   --  Typically a save operation follows.
   procedure insert_profile (confrec : configuration_record);

   --  Create or overwrite a complete ravenadm.ini file using internal data at IFM
   procedure rewrite_configuration;

   --  Return True if 3 or more sections exist (1 is global, the rest must be profiles)
   function alternative_profiles_exist return Boolean;

   --  Return a LF-delimited list of profiles contained in ravenadm.ini
   function list_profiles return String;

   --  Remove an entire profile from the configuration and save it.
   procedure delete_profile (profile : String);

   --  Updates master section with new profile name and initiates a transfer
   procedure switch_profile (to_profile : String);

private

   package UTL renames Utilities;

   memory_probe : exception;
   profile_DNE  : exception;

   memory_megs   : Natural := 0;

    --  Default Sizing by number of CPUS
   --      1 CPU ::  1 Builder,  1 job  per builder
   --    2/3 CPU ::  2 builders, 2 jobs per builder
   --    4/5 CPU ::  3 builders, 3 jobs per builder
   --    6/7 CPU ::  4 builders, 3 jobs per builder
   --    8/9 CPU ::  6 builders, 4 jobs per builder
   --  10/11 CPU ::  8 builders, 4 jobs per builder
   --    12+ CPU :: floor (75% * CPU), 5 jobs per builder

   Field_01 : constant String := "directory_sysroot";
   Field_16 : constant String := "directory_toolchain";
   Field_02 : constant String := "directory_localbase";
   Field_03 : constant String := "directory_conspiracy";
   Field_04 : constant String := "directory_unkindness";
   Field_05 : constant String := "directory_distfiles";
   Field_06 : constant String := "directory_packages";
   Field_07 : constant String := "directory_ccache";
   Field_08 : constant String := "directory_buildbase";
   Field_09 : constant String := "directory_logs";
   Field_10 : constant String := "number_of_builders";
   Field_11 : constant String := "max_jobs_per_builder";
   Field_12 : constant String := "avoid_tmpfs";
   Field_13 : constant String := "record_default_options";
   Field_14 : constant String := "display_with_ncurses";
   Field_15 : constant String := "leverage_prebuilt";

   global_01 : constant String := "profile_selected";
   global_02 : constant String := "url_conspiracy";

   first_profile : constant String := "primary";
   raven_var     : constant String := "/var/ravenports";

   master_section : constant String := "Global Configuration";
   pri_packages   : constant String := raven_var & "/[X]_packages";
   pri_logs       : constant String := raven_var & "/logs/[X]";
   pri_buildbase  : constant String := "/usr/obj/ravenports";
   ravenadm_ini   : constant String := "ravenadm.ini";
   conf_location  : constant String := raven_confdir & "/" & ravenadm_ini;
   std_localbase  : constant String := "/raven";
   std_distfiles  : constant String := raven_var & "/distfiles";
   std_conspiracy : constant String := raven_var & "/conspiracy";
   std_sysroot    : constant String := std_localbase & "/share/raven-sysroot/" &
                                       UTL.mixed_opsys (platform_type);
   std_toolchain  : constant String := std_localbase & "/toolchain";

   procedure query_physical_memory;
   procedure query_physical_memory_linux;
   procedure query_physical_memory_sunos;
   function enough_memory (num_builders : builders) return Boolean;

   procedure default_parallelism
     (num_cores        : cpu_range;
      num_builders     : out Integer;
      jobs_per_builder : out Integer);

   --  Copy from IFM to configuration record, updating type as necessary.
   --  If values are missing, use default values.
   --  If profile in global does not exist, throw exception
   procedure transfer_configuration;

   --  Determine and store number of cores.  It's needed for dynamic configuration and
   --  the value is used in the build cycle as well.
   procedure set_cores;

   --  Platform-specific routines to determine ncpu
   function get_number_cpus return Positive;

   --  Updates the global section to indicate active profile
   procedure change_active_profile (new_active_profile : String);

end Parameters;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

with Definitions;  use Definitions;

with HelperText;
private with Utilities;

package Parameters is

   package HT renames HelperText;

   no_ccache     : constant String := "none";
   no_unkindness : constant String := "none";
   raven_confdir : constant String := host_localbase & "/etc/ravenadm";

   type configuration_record is
      record
         profile         : HT.Text;
         dir_sysroot     : HT.Text;
         dir_toolchain   : HT.Text;
         dir_localbase   : HT.Text;
         dir_conspiracy  : HT.Text;
         dir_unkindness  : HT.Text;
         dir_distfiles   : HT.Text;
         dir_packages    : HT.Text;
         dir_ccache      : HT.Text;
         dir_buildbase   : HT.Text;
         dir_logs        : HT.Text;
         num_builders    : builders;
         jobs_limit      : builders;
         avoid_tmpfs     : Boolean;
         record_options  : Boolean;
         avec_ncurses    : Boolean;
         defer_prebuilt  : Boolean;

         --  Computed, not saved
         number_cores    : cpu_range;
         dir_repository  : HT.Text;
         sysroot_pkg8    : HT.Text;
      end record;

   configuration  : configuration_record;
   active_profile : HT.Text;

   --  This procedure will create a default configuration file if one
   --  does not already exist, otherwise it will it load it.  In every case,
   --  the "configuration" record will be populated after this is run.
   --  returns "True" on success
   function load_configuration return Boolean;

   --  Maybe a previously valid directory path has been removed.  This
   --  function returns true when all the paths still work.
   --  The configuration must be loaded before it's run, of course.
   function all_paths_valid return Boolean;

   --  Return true if the localbase is set to someplace it really shouldn't be
   function forbidden_localbase (candidate : String) return Boolean;

   --  Return a profile record filled with dynamic defaults.
   function default_profile (new_profile : String) return configuration_record;

   --  Delete any existing profile data and create a new profile.
   --  Typically a save operation follows.
   procedure insert_profile (confrec : configuration_record);

   --  Create or overwrite a complete ravenadm.ini file using internal data at IFM
   procedure rewrite_configuration;

   --  Return True if 3 or more sections exist (1 is global, the rest must be profiles)
   function alternative_profiles_exist return Boolean;

   --  Return a LF-delimited list of profiles contained in ravenadm.ini
   function list_profiles return String;

   --  Remove an entire profile from the configuration and save it.
   procedure delete_profile (profile : String);

   --  Updates master section with new profile name and initiates a transfer
   procedure switch_profile (to_profile : String);

private

   package UTL renames Utilities;

   memory_probe : exception;
   profile_DNE  : exception;

   memory_megs   : Natural := 0;

    --  Default Sizing by number of CPUS
   --      1 CPU ::  1 Builder,  1 job  per builder
   --    2/3 CPU ::  2 builders, 2 jobs per builder
   --    4/5 CPU ::  3 builders, 3 jobs per builder
   --    6/7 CPU ::  4 builders, 3 jobs per builder
   --    8/9 CPU ::  6 builders, 4 jobs per builder
   --  10/11 CPU ::  8 builders, 4 jobs per builder
   --    12+ CPU :: floor (75% * CPU), 5 jobs per builder

   Field_01 : constant String := "directory_sysroot";
   Field_16 : constant String := "directory_toolchain";
   Field_02 : constant String := "directory_localbase";
   Field_03 : constant String := "directory_conspiracy";
   Field_04 : constant String := "directory_unkindness";
   Field_05 : constant String := "directory_distfiles";
   Field_06 : constant String := "directory_packages";
   Field_07 : constant String := "directory_ccache";
   Field_08 : constant String := "directory_buildbase";
   Field_09 : constant String := "directory_logs";
   Field_10 : constant String := "number_of_builders";
   Field_11 : constant String := "max_jobs_per_builder";
   Field_12 : constant String := "avoid_tmpfs";
   Field_13 : constant String := "record_default_options";
   Field_14 : constant String := "display_with_ncurses";
   Field_15 : constant String := "leverage_prebuilt";

   global_01 : constant String := "profile_selected";
   global_02 : constant String := "url_conspiracy";

   first_profile : constant String := "primary";
   raven_var     : constant String := "/var/ravenports";

   master_section : constant String := "Global Configuration";
   pri_packages   : constant String := raven_var & "/[X]_packages";
   pri_logs       : constant String := raven_var & "/logs/[X]";
   pri_buildbase  : constant String := "/usr/obj/ravenports";
   ravenadm_ini   : constant String := "ravenadm.ini";
   conf_location  : constant String := raven_confdir & "/" & ravenadm_ini;
   std_localbase  : constant String := "/raven";
   std_distfiles  : constant String := raven_var & "/distfiles";
   std_conspiracy : constant String := raven_var & "/conspiracy";
   std_sysroot    : constant String := std_localbase & "/share/raven/sysroot/" &
                                       UTL.mixed_opsys (platform_type);
   std_toolchain  : constant String := std_localbase & "/share/raven/toolchain";

   procedure query_physical_memory;
   procedure query_physical_memory_linux;
   procedure query_physical_memory_sunos;
   function enough_memory (num_builders : builders) return Boolean;

   procedure default_parallelism
     (num_cores        : cpu_range;
      num_builders     : out Integer;
      jobs_per_builder : out Integer);

   --  Copy from IFM to configuration record, updating type as necessary.
   --  If values are missing, use default values.
   --  If profile in global does not exist, throw exception
   procedure transfer_configuration;

   --  Determine and store number of cores.  It's needed for dynamic configuration and
   --  the value is used in the build cycle as well.
   procedure set_cores;

   --  Platform-specific routines to determine ncpu
   function get_number_cpus return Positive;

   --  Updates the global section to indicate active profile
   procedure change_active_profile (new_active_profile : String);

end Parameters;

Adjust 2 defaults (sysroot and toolchain)


-----------------------------------------------------------------------
--  ADO Tests -- Database sequence generator
--  Copyright (C) 2009, 2010, 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 ADO.Sessions.Factory;

package body Regtests is

   Factory    : aliased ADO.Sessions.Factory.Session_Factory;
   Controller : aliased ADO.Sessions.Sources.Data_Source;

   --  ------------------------------
   --  Get the database manager to be used for the unit tests
   --  ------------------------------
   function Get_Controller return ADO.Sessions.Sources.Data_Source'Class is
   begin
      return Controller;
   end Get_Controller;

   --  ------------------------------
   --  Get the readonly connection database to be used for the unit tests
   --  ------------------------------
   function Get_Database return ADO.Sessions.Session is
   begin
      return Factory.Get_Session;
   end Get_Database;

   --  ------------------------------
   --  Get the writeable connection database to be used for the unit tests
   --  ------------------------------
   function Get_Master_Database return ADO.Sessions.Master_Session is
   begin
      return Factory.Get_Master_Session;
   end Get_Master_Database;

   --  ------------------------------
   --  Initialize the test database
   --  ------------------------------
   procedure Initialize (Name : in String) is
   begin
      Controller.Set_Connection (Name);
      Factory.Create (Controller);
   end Initialize;

end Regtests;

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

with ADO.Sessions.Factory;

package body Regtests is

   Factory    : aliased ADO.Sessions.Factory.Session_Factory;
   Controller : aliased ADO.Sessions.Sources.Data_Source;

   --  ------------------------------
   --  Get the database manager to be used for the unit tests
   --  ------------------------------
   function Get_Controller return ADO.Sessions.Sources.Data_Source'Class is
   begin
      return Controller;
   end Get_Controller;

   --  ------------------------------
   --  Get the readonly connection database to be used for the unit tests
   --  ------------------------------
   function Get_Database return ADO.Sessions.Session is
   begin
      return Factory.Get_Session;
   end Get_Database;

   --  ------------------------------
   --  Get the writeable connection database to be used for the unit tests
   --  ------------------------------
   function Get_Master_Database return ADO.Sessions.Master_Session is
   begin
      return Factory.Get_Master_Session;
   end Get_Master_Database;

   --  ------------------------------
   --  Set the audit manager on the factory.
   --  ------------------------------
   procedure Set_Audit_Manager (Manager : in ADO.Audits.Audit_Manager_Access) is
   begin
      Factory.Set_Audit_Manager (Manager);
   end Set_Audit_Manager;

   --  ------------------------------
   --  Initialize the test database
   --  ------------------------------
   procedure Initialize (Name : in String) is
   begin
      Controller.Set_Connection (Name);
      Factory.Create (Controller);
   end Initialize;

end Regtests;

Implement the Set_Audit_Manager procedure


-----------------------------------------------------------------------
--  awa-wikis-previews -- Wiki preview management
--  Copyright (C) 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 ASF.Applications;

with AWA.Modules;
with AWA.Jobs.Services;
with AWA.Jobs.Modules;
with AWA.Wikis.Modules;
with AWA.Wikis.Models;

--  == Wiki Preview Module ==
--  The <tt>AWA.Wikis.Previews</tt> package implements a preview image generation for a wiki page.
--  This module is optional, it is possible to use the wikis without preview support.  When the
--  module is registered, it listens to wiki page lifecycle events.  When a new wiki content is
--  changed, it triggers a job to make the preview.  The preview job uses the
--  <tt>wkhtmotoimage</tt> external program to make the preview image.
package AWA.Wikis.Previews is

   --  The name under which the module is registered.
   NAME : constant String := "wiki-previews";

   --  The worker procedure that performs the preview job.
   procedure Preview_Worker (Job : in out AWA.Jobs.Services.Abstract_Job_Type'Class);

   --  Preview job definition.
   package Preview_Job_Definition is new AWA.Jobs.Services.Work_Definition (Preview_Worker'Access);

   --  ------------------------------
   --  Preview wiki module
   --  ------------------------------
   type Preview_Module is new AWA.Modules.Module
     and AWA.Wikis.Modules.Wiki_Lifecycle.Listener with private;
   type Preview_Module_Access is access all Preview_Module'Class;

   --  Initialize the preview wiki module.
   overriding
   procedure Initialize (Plugin : in out Preview_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  The `On_Create` procedure is called by `Notify_Create` to notify the creation of the page.
   overriding
   procedure On_Create (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  The `On_Update` procedure is called by `Notify_Update` to notify the update of the page.
   overriding
   procedure On_Update (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  The `On_Delete` procedure is called by `Notify_Delete` to notify the deletion of the page.
   overriding
   procedure On_Delete (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  Create a preview job and schedule the job to generate a new thumbnail preview for the page.
   procedure Make_Preview_Job (Plugin : in Preview_Module;
                               Page   : in AWA.Wikis.Models.Wiki_Page_Ref'Class);

private

   type Preview_Module is new AWA.Modules.Module
     and AWA.Wikis.Modules.Wiki_Lifecycle.Listener with record
      Job_Module : AWA.Jobs.Modules.Job_Module_Access;
   end record;

end AWA.Wikis.Previews;

-----------------------------------------------------------------------
--  awa-wikis-previews -- Wiki preview management
--  Copyright (C) 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 EL.Expressions;

with ASF.Applications;

with AWA.Modules;
with AWA.Jobs.Services;
with AWA.Jobs.Modules;
with AWA.Wikis.Modules;
with AWA.Wikis.Models;

--  == Wiki Preview Module ==
--  The <tt>AWA.Wikis.Previews</tt> package implements a preview image generation for a wiki page.
--  This module is optional, it is possible to use the wikis without preview support.  When the
--  module is registered, it listens to wiki page lifecycle events.  When a new wiki content is
--  changed, it triggers a job to make the preview.  The preview job uses the
--  <tt>wkhtmotoimage</tt> external program to make the preview image.
package AWA.Wikis.Previews is

   --  The name under which the module is registered.
   NAME : constant String := "wiki-previews";

   --  The configuration parameter that defines how to build the wiki preview template path.
   PARAM_PREVIEW_TEMPLATE : constant String := "wiki.preview.template";

   --  The configuration parameter to build the preview command to execute.
   PARAM_PREVIEW_COMMAND : constant String := "wiki.preview.command";

   --  The worker procedure that performs the preview job.
   procedure Preview_Worker (Job : in out AWA.Jobs.Services.Abstract_Job_Type'Class);

   --  Preview job definition.
   package Preview_Job_Definition is new AWA.Jobs.Services.Work_Definition (Preview_Worker'Access);

   --  ------------------------------
   --  Preview wiki module
   --  ------------------------------
   type Preview_Module is new AWA.Modules.Module
     and AWA.Wikis.Modules.Wiki_Lifecycle.Listener with private;
   type Preview_Module_Access is access all Preview_Module'Class;

   --  Initialize the preview wiki module.
   overriding
   procedure Initialize (Plugin : in out Preview_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  The `On_Create` procedure is called by `Notify_Create` to notify the creation of the page.
   overriding
   procedure On_Create (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  The `On_Update` procedure is called by `Notify_Update` to notify the update of the page.
   overriding
   procedure On_Update (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  The `On_Delete` procedure is called by `Notify_Delete` to notify the deletion of the page.
   overriding
   procedure On_Delete (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  Create a preview job and schedule the job to generate a new thumbnail preview for the page.
   procedure Make_Preview_Job (Plugin : in Preview_Module;
                               Page   : in AWA.Wikis.Models.Wiki_Page_Ref'Class);

private

   type Preview_Module is new AWA.Modules.Module
     and AWA.Wikis.Modules.Wiki_Lifecycle.Listener with record
      Template   : EL.Expressions.Expression;
      Command    : EL.Expressions.Expression;
      Job_Module : AWA.Jobs.Modules.Job_Module_Access;
   end record;

end AWA.Wikis.Previews;

Define PARAM_PREVIEW_TEMPLATE and PARAM_PREVIEW_COMMAND


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

with Ada.Calendar;
with Ada.Calendar.Formatting;
with Ada.Calendar.Arithmetic;
with Ada.Calendar.Time_Zones;

--  = Date Utilities =
--  The `Util.Dates` package provides various date utilities to help in formatting and parsing
--  dates in various standard formats.  It completes the standard `Ada.Calendar.Formatting` and
--  other packages by implementing specific formatting and parsing.
--
--  == Date Operations ==
--  Several operations allow to compute from a given date:
--
--    * `Get_Day_Start`: The start of the day (0:00),
--    * `Get_Day_End`: The end of the day (23:59:59),
--    * `Get_Week_Start`: The start of the week,
--    * `Get_Week_End`: The end of the week,
--    * `Get_Month_Start`: The start of the month,
--    * `Get_Month_End`: The end of the month
--
--  The `Date_Record` type represents a date in a split format allowing
--  to access easily the day, month, hour and other information.
--
--    Now        : Ada.Calendar.Time := Ada.Calendar.Clock;
--    Week_Start : Ada.Calendar.Time := Get_Week_Start (Now);
--    Week_End   : Ada.Calendar.Time := Get_Week_End (Now);
--
--  @include util-dates-rfc7231.ads
--  @include util-dates-iso8601.ads
--  @include util-dates-formats.ads
package Util.Dates is

   --  The Unix equivalent of 'struct tm'.
   type Date_Record is record
      Date        : Ada.Calendar.Time;
      Year        : Ada.Calendar.Year_Number := 1901;
      Month       : Ada.Calendar.Month_Number := 1;
      Month_Day   : Ada.Calendar.Day_Number := 1;
      Day         : Ada.Calendar.Formatting.Day_Name := Ada.Calendar.Formatting.Tuesday;
      Hour        : Ada.Calendar.Formatting.Hour_Number := 0;
      Minute      : Ada.Calendar.Formatting.Minute_Number := 0;
      Second      : Ada.Calendar.Formatting.Second_Number := 0;
      Sub_Second  : Ada.Calendar.Formatting.Second_Duration := 0.0;
      Time_Zone   : Ada.Calendar.Time_Zones.Time_Offset := 0;
      Leap_Second : Boolean := False;
   end record;

   --  Split the date into a date record (See Ada.Calendar.Formatting.Split).
   procedure Split (Into       : out Date_Record;
                    Date       : in Ada.Calendar.Time;
                    Time_Zone  : in Ada.Calendar.Time_Zones.Time_Offset := 0);

   --  Returns true if the given year is a leap year.
   function Is_Leap_Year (Year : in Ada.Calendar.Year_Number) return Boolean;

   --  Get the number of days in the given year.
   function Get_Day_Count (Year : in Ada.Calendar.Year_Number)
                           return Ada.Calendar.Arithmetic.Day_Count;

   --  Get the number of days in the given month.
   function Get_Day_Count (Year  : in Ada.Calendar.Year_Number;
                           Month : in Ada.Calendar.Month_Number)
                           return Ada.Calendar.Arithmetic.Day_Count;

   --  Get a time representing the given date at 00:00:00.
   function Get_Day_Start (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Day_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the given date at 23:59:59.
   function Get_Day_End (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Day_End (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the beginning of the week at 00:00:00.
   function Get_Week_Start (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Week_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the end of the week at 23:59:99.
   function Get_Week_End (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Week_End (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the beginning of the month at 00:00:00.
   function Get_Month_Start (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Month_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the end of the month at 23:59:59.
   function Get_Month_End (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Month_End (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

end Util.Dates;

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

with Ada.Calendar;
with Ada.Calendar.Formatting;
with Ada.Calendar.Arithmetic;
with Ada.Calendar.Time_Zones;

--  = Date Utilities =
--  The `Util.Dates` package provides various date utilities to help in formatting and parsing
--  dates in various standard formats.  It completes the standard `Ada.Calendar.Formatting` and
--  other packages by implementing specific formatting and parsing.
--
--  == Date Operations ==
--  Several operations allow to compute from a given date:
--
--    * `Get_Day_Start`: The start of the day (0:00),
--    * `Get_Day_End`: The end of the day (23:59:59),
--    * `Get_Week_Start`: The start of the week,
--    * `Get_Week_End`: The end of the week,
--    * `Get_Month_Start`: The start of the month,
--    * `Get_Month_End`: The end of the month
--
--  The `Date_Record` type represents a date in a split format allowing
--  to access easily the day, month, hour and other information.
--
--    Now        : Ada.Calendar.Time := Ada.Calendar.Clock;
--    Week_Start : Ada.Calendar.Time := Get_Week_Start (Now);
--    Week_End   : Ada.Calendar.Time := Get_Week_End (Now);
--
--  @include util-dates-rfc7231.ads
--  @include util-dates-iso8601.ads
--  @include util-dates-formats.ads
package Util.Dates is

   --  The Unix equivalent of 'struct tm'.
   type Date_Record is record
      Date        : Ada.Calendar.Time;
      Year        : Ada.Calendar.Year_Number := 1901;
      Month       : Ada.Calendar.Month_Number := 1;
      Month_Day   : Ada.Calendar.Day_Number := 1;
      Day         : Ada.Calendar.Formatting.Day_Name := Ada.Calendar.Formatting.Tuesday;
      Hour        : Ada.Calendar.Formatting.Hour_Number := 0;
      Minute      : Ada.Calendar.Formatting.Minute_Number := 0;
      Second      : Ada.Calendar.Formatting.Second_Number := 0;
      Sub_Second  : Ada.Calendar.Formatting.Second_Duration := 0.0;
      Time_Zone   : Ada.Calendar.Time_Zones.Time_Offset := 0;
      Leap_Second : Boolean := False;
   end record;

   --  Split the date into a date record (See Ada.Calendar.Formatting.Split).
   procedure Split (Into       : out Date_Record;
                    Date       : in Ada.Calendar.Time;
                    Time_Zone  : in Ada.Calendar.Time_Zones.Time_Offset := 0);

   --  Return the date from the date record (See Ada.Calendar.Formatting.Time_Of).
   function Time_Of (Date : in Date_Record) return Ada.Calendar.Time;

   --  Returns true if the given year is a leap year.
   function Is_Leap_Year (Year : in Ada.Calendar.Year_Number) return Boolean;

   --  Get the number of days in the given year.
   function Get_Day_Count (Year : in Ada.Calendar.Year_Number)
                           return Ada.Calendar.Arithmetic.Day_Count;

   --  Get the number of days in the given month.
   function Get_Day_Count (Year  : in Ada.Calendar.Year_Number;
                           Month : in Ada.Calendar.Month_Number)
                           return Ada.Calendar.Arithmetic.Day_Count;

   --  Get a time representing the given date at 00:00:00.
   function Get_Day_Start (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Day_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the given date at 23:59:59.
   function Get_Day_End (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Day_End (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the beginning of the week at 00:00:00.
   function Get_Week_Start (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Week_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the end of the week at 23:59:99.
   function Get_Week_End (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Week_End (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the beginning of the month at 00:00:00.
   function Get_Month_Start (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Month_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the end of the month at 23:59:59.
   function Get_Month_End (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Month_End (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

end Util.Dates;

Declare Time_Of function to convert a Date_Record into a Time