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

--  == Auth ==
--  The Security.Auth package implements an authentication framework that is
--  suitable for OpenID 2.0, OAuth 2.0 and later for OpenID Connect.  It allows an application
--  to authenticate users using an external authorization server such as Google, Facebook,
--  Google +, Twitter and others.
--
--  See OpenID Authentication 2.0 - Final
--  http://openid.net/specs/openid-authentication-2_0.html
--
--  See OpenID Connect Standard 1.0
--  http://openid.net/specs/openid-connect-standard-1_0.html
--
--  See Facebook API: The Login Flow for Web (without JavaScript SDK)
--  https://developers.facebook.com/docs/facebook-login/login-flow-for-web-no-jssdk/
--
--  Despite their subtle differences, all these authentication frameworks share almost
--  a common flow.  The API provided by Security.Auth defines an abstraction suitable
--  for all these frameworks.
--
--  There are basically two steps that an application must implement:
--
--    * Discovery: to resolve and use the OpenID provider and redirect the user to the
--      provider authentication form.
--    * Verify: to decode the authentication and check its result.
--
--  [http://ada-security.googlecode.com/svn/wiki/OpenID.png]
--
--  The authentication process is the following:
--
--    * The application should redirect the user to the authentication URL.
--    * The OpenID provider authenticate the user and redirects the user to the callback CB.
--    * The association is decoded from the callback parameter.
--    * The Verify procedure is called with the association to check the result and
--      obtain the authentication results.
--
--  === Initialization ===
--  The initialization process must be done before each two steps (discovery and verify).
--  The Authentication manager must be declared and configured.
--
--    Mgr   : Security.Auth.Manager;
--
--  For the configuration, the Initialize procedure is called to configure
--  the Auth realm and set the authentication return callback URL.  The return callback
--  must be a valid URL that is based on the realm.  Example:
--
--    Mgr.Initialize (Name      => "http://app.site.com/auth",
--                    Return_To => "http://app.site.com/auth/verify",
--                    Realm     => "openid");
--
--  After this initialization, the authentication manager can be used in the authentication
--  process.
--
--  @include security-auth-openid.ads
--  @include security-auth-oauth.ads
--
--  === Discovery: creating the authentication URL ===
--  The first step is to create an authentication URL to which the user must be redirected.
--  In this step, we have to create an OpenID manager, discover the OpenID provider,
--  do the association and get an End_Point.  The OpenID provider is specified as an
--  URL, below is an example for Google OpenID:
--
--    Provider : constant String := "https://www.google.com/accounts/o8/id";
--    OP       : Security.Auth.End_Point;
--    Assoc    : constant Security.Auth.Association_Access := new Security.Auth.Association;
--
--  The following steps are performed:
--
--    * The Discover procedure is called to retrieve from the OpenID provider the XRDS
--      stream and identify the provider.  An End_Point is returned in <tt>OP</tt>.
--    * The Associate procedure is called to make the association with the End_Point.
--      The Association record holds session, and authentication.
--
--    Mgr.Discover (Provider, OP);  --  Yadis discovery (get the XRDS file).
--    Mgr.Associate (OP, Assoc.all);--  Associate and get an end-point with a key.
--
--  After this first step, you must manage to save the association in the HTTP session.
--  Then you must redirect to the authentication URL that is obtained by using:
--
--    Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc.all);
--
--  === Verify: acknowledge the authentication in the callback URL ===
--  The second step is done when the user has finished the authentication successfully or not.
--  For this step, the application must get back the association that was saved in the session.
--  It must also prepare a parameters object that allows the OpenID framework to get the
--  URI parameters from the return callback.
--
--    Assoc      : Association_Access := ...;  --  Get the association saved in the session.
--    Credential : Security.Auth.Authentication;
--    Params     : Auth_Params;
--
--  The auth manager must be initialized and the Verify procedure is called with
--  the association, parameters and the authentication result.  The Get_Status function
--  must be used to check that the authentication succeeded.
--
--    Mgr.Verify (Assoc.all, Params, Credential);
--    if Security.Auth.Get_Status (Credential) = Security.Auth.AUTHENTICATED then ...  -- Success.
--
--  === Principal creation ===
--  After the user is successfully authenticated, a user principal can be created and saved in
--  the session.  The user principal can then be used to assign permissions to that user and
--  enforce the application permissions using the security policy manger.
--
--    P : Security.Auth.Principal_Access := Security.Auth.Create_Principal (Credential);
--
package Security.Auth is

   --  Use an authentication server implementing OpenID 2.0.
   PROVIDER_OPENID   : constant String := "openid";

   --  Use the Facebook OAuth 2.0 - draft 12 authentication server.
   PROVIDER_FACEBOOK : constant String := "facebook";

   Invalid_End_Point : exception;

   Service_Error     : exception;

   type Parameters is limited interface;

   function Get_Parameter (Params : in Parameters;
                           Name   : in String) return String is abstract;

   --  ------------------------------
   --  Auth provider
   --  ------------------------------
   --  The End_Point represents the authentication provider that will authenticate
   --  the user.
   type End_Point is private;

   function To_String (OP : End_Point) return String;

   --  ------------------------------
   --  Association
   --  ------------------------------
   --  The association contains the shared secret between the relying party
   --  and the authentication provider.  The association can be cached and reused to authenticate
   --  different users using the same authentication provider.  The association also has an
   --  expiration date.
   type Association is private;

   --  Get the provider.
   function Get_Provider (Assoc : in Association) return String;

   --  Dump the association as a string (for debugging purposes)
   function To_String (Assoc : Association) return String;

   type Auth_Result is (AUTHENTICATED, CANCEL, SETUP_NEEDED, UNKNOWN, INVALID_SIGNATURE);

   --  ------------------------------
   --  Authentication result
   --  ------------------------------
   --
   type Authentication is private;

   --  Get the email address
   function Get_Email (Auth : in Authentication) return String;

   --  Get the user first name.
   function Get_First_Name (Auth : in Authentication) return String;

   --  Get the user last name.
   function Get_Last_Name (Auth : in Authentication) return String;

   --  Get the user full name.
   function Get_Full_Name (Auth : in Authentication) return String;

   --  Get the user identity.
   function Get_Identity (Auth : in Authentication) return String;

   --  Get the user claimed identity.
   function Get_Claimed_Id (Auth : in Authentication) return String;

   --  Get the user language.
   function Get_Language (Auth : in Authentication) return String;

   --  Get the user country.
   function Get_Country (Auth : in Authentication) return String;

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

   --  ------------------------------
   --  Default principal
   --  ------------------------------
   type Principal is new Security.Principal with private;
   type Principal_Access is access all Principal'Class;

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

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

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

   --  Create a principal with the given authentication results.
   function Create_Principal (Auth : in Authentication) return Principal_Access;

   --  ------------------------------
   --  Authentication Manager
   --  ------------------------------
   --  The Manager provides the core operations for the authentication process.
   type Manager is tagged limited private;

   --  Initialize the authentication realm.
   procedure Initialize (Realm     : in out Manager;
                         Params    : in Parameters'Class;
                         Provider  : in String := PROVIDER_OPENID);

   --  Discover the authentication provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.  The discover step may do nothing for
   --  authentication providers based on OAuth.
   --  (See OpenID Section 7.3 Discovery)
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the authentication provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

   --  Get the authentication URL to which the user must be redirected for authentication
   --  by the authentication server.
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String;

   --  Verify the authentication result
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication);

private

   use Ada.Strings.Unbounded;

   type Association is record
      Provider     : Unbounded_String;
      Session_Type : Unbounded_String;
      Assoc_Type   : Unbounded_String;
      Assoc_Handle : Unbounded_String;
      Mac_Key      : Unbounded_String;
      Expired      : Ada.Calendar.Time;
   end record;

   type Authentication is record
      Status     : Auth_Result;
      Identity   : Unbounded_String;
      Claimed_Id : Unbounded_String;
      Email      : Unbounded_String;
      Full_Name  : Unbounded_String;
      First_Name : Unbounded_String;
      Last_Name  : Unbounded_String;
      Language   : Unbounded_String;
      Country    : Unbounded_String;
      Gender     : Unbounded_String;
      Timezone   : Unbounded_String;
      Nickname   : Unbounded_String;
   end record;

   type End_Point is record
      URL        : Unbounded_String;
      Alias      : Unbounded_String;
      Expired    : Ada.Calendar.Time;
   end record;

   type Manager_Access is access all Manager'Class;

   type Manager is new Ada.Finalization.Limited_Controlled with record
      Provider  : Unbounded_String;
      Delegate  : Manager_Access;
   end record;

   type Principal is new Security.Principal with record
      Auth : Authentication;
   end record;

   procedure Set_Result (Result  : in out Authentication;
                         Status  : in Auth_Result;
                         Message : in String);

end Security.Auth;

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

--  == Auth ==
--  The Security.Auth package implements an authentication framework that is
--  suitable for OpenID 2.0, OAuth 2.0 and later for OpenID Connect.  It allows an application
--  to authenticate users using an external authorization server such as Google, Facebook,
--  Google +, Twitter and others.
--
--  See OpenID Authentication 2.0 - Final
--  http://openid.net/specs/openid-authentication-2_0.html
--
--  See OpenID Connect Standard 1.0
--  http://openid.net/specs/openid-connect-standard-1_0.html
--
--  See Facebook API: The Login Flow for Web (without JavaScript SDK)
--  https://developers.facebook.com/docs/facebook-login/login-flow-for-web-no-jssdk/
--
--  Despite their subtle differences, all these authentication frameworks share almost
--  a common flow.  The API provided by Security.Auth defines an abstraction suitable
--  for all these frameworks.
--
--  There are basically two steps that an application must implement:
--
--    * Discovery: to resolve and use the OpenID provider and redirect the user to the
--      provider authentication form.
--    * Verify: to decode the authentication and check its result.
--
--  [http://ada-security.googlecode.com/svn/wiki/OpenID.png]
--
--  The authentication process is the following:
--
--    * The application should redirect the user to the authentication URL.
--    * The OpenID provider authenticate the user and redirects the user to the callback CB.
--    * The association is decoded from the callback parameter.
--    * The Verify procedure is called with the association to check the result and
--      obtain the authentication results.
--
--  === Initialization ===
--  The initialization process must be done before each two steps (discovery and verify).
--  The Authentication manager must be declared and configured.
--
--    Mgr   : Security.Auth.Manager;
--
--  For the configuration, the Initialize procedure is called to configure
--  the Auth realm and set the authentication return callback URL.  The return callback
--  must be a valid URL that is based on the realm.  Example:
--
--    Mgr.Initialize (Name      => "http://app.site.com/auth",
--                    Return_To => "http://app.site.com/auth/verify",
--                    Realm     => "openid");
--
--  After this initialization, the authentication manager can be used in the authentication
--  process.
--
--  @include security-auth-openid.ads
--  @include security-auth-oauth.ads
--
--  === Discovery: creating the authentication URL ===
--  The first step is to create an authentication URL to which the user must be redirected.
--  In this step, we have to create an OpenID manager, discover the OpenID provider,
--  do the association and get an End_Point.  The OpenID provider is specified as an
--  URL, below is an example for Google OpenID:
--
--    Provider : constant String := "https://www.google.com/accounts/o8/id";
--    OP       : Security.Auth.End_Point;
--    Assoc    : constant Security.Auth.Association_Access := new Security.Auth.Association;
--
--  The following steps are performed:
--
--    * The Discover procedure is called to retrieve from the OpenID provider the XRDS
--      stream and identify the provider.  An End_Point is returned in <tt>OP</tt>.
--    * The Associate procedure is called to make the association with the End_Point.
--      The Association record holds session, and authentication.
--
--    Mgr.Discover (Provider, OP);  --  Yadis discovery (get the XRDS file).
--    Mgr.Associate (OP, Assoc.all);--  Associate and get an end-point with a key.
--
--  After this first step, you must manage to save the association in the HTTP session.
--  Then you must redirect to the authentication URL that is obtained by using:
--
--    Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc.all);
--
--  === Verify: acknowledge the authentication in the callback URL ===
--  The second step is done when the user has finished the authentication successfully or not.
--  For this step, the application must get back the association that was saved in the session.
--  It must also prepare a parameters object that allows the OpenID framework to get the
--  URI parameters from the return callback.
--
--    Assoc      : Association_Access := ...;  --  Get the association saved in the session.
--    Credential : Security.Auth.Authentication;
--    Params     : Auth_Params;
--
--  The auth manager must be initialized and the Verify procedure is called with
--  the association, parameters and the authentication result.  The Get_Status function
--  must be used to check that the authentication succeeded.
--
--    Mgr.Verify (Assoc.all, Params, Credential);
--    if Security.Auth.Get_Status (Credential) = Security.Auth.AUTHENTICATED then ...  -- Success.
--
--  === Principal creation ===
--  After the user is successfully authenticated, a user principal can be created and saved in
--  the session.  The user principal can then be used to assign permissions to that user and
--  enforce the application permissions using the security policy manger.
--
--    P : Security.Auth.Principal_Access := Security.Auth.Create_Principal (Credential);
--
package Security.Auth is

   --  Use an authentication server implementing OpenID 2.0.
   PROVIDER_OPENID   : constant String := "openid";

   --  Use the Facebook OAuth 2.0 - draft 12 authentication server.
   PROVIDER_FACEBOOK : constant String := "facebook";

   Invalid_End_Point : exception;

   Service_Error     : exception;

   type Parameters is limited interface;

   function Get_Parameter (Params : in Parameters;
                           Name   : in String) return String is abstract;

   --  ------------------------------
   --  Auth provider
   --  ------------------------------
   --  The End_Point represents the authentication provider that will authenticate
   --  the user.
   type End_Point is private;

   function To_String (OP : End_Point) return String;

   --  ------------------------------
   --  Association
   --  ------------------------------
   --  The association contains the shared secret between the relying party
   --  and the authentication provider.  The association can be cached and reused to authenticate
   --  different users using the same authentication provider.  The association also has an
   --  expiration date.
   type Association is private;

   --  Get the provider.
   function Get_Provider (Assoc : in Association) return String;

   --  Dump the association as a string (for debugging purposes)
   function To_String (Assoc : Association) return String;

   type Auth_Result is (AUTHENTICATED, CANCEL, SETUP_NEEDED, UNKNOWN, INVALID_SIGNATURE);

   --  ------------------------------
   --  Authentication result
   --  ------------------------------
   --
   type Authentication is private;

   --  Get the email address
   function Get_Email (Auth : in Authentication) return String;

   --  Get the user first name.
   function Get_First_Name (Auth : in Authentication) return String;

   --  Get the user last name.
   function Get_Last_Name (Auth : in Authentication) return String;

   --  Get the user full name.
   function Get_Full_Name (Auth : in Authentication) return String;

   --  Get the user identity.
   function Get_Identity (Auth : in Authentication) return String;

   --  Get the user claimed identity.
   function Get_Claimed_Id (Auth : in Authentication) return String;

   --  Get the user language.
   function Get_Language (Auth : in Authentication) return String;

   --  Get the user country.
   function Get_Country (Auth : in Authentication) return String;

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

   --  ------------------------------
   --  Default principal
   --  ------------------------------
   type Principal is new Security.Principal with private;
   type Principal_Access is access all Principal'Class;

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

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

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

   --  Create a principal with the given authentication results.
   function Create_Principal (Auth : in Authentication) return Principal_Access;

   --  ------------------------------
   --  Authentication Manager
   --  ------------------------------
   --  The Manager provides the core operations for the authentication process.
   type Manager is tagged limited private;

   --  Initialize the authentication realm.
   procedure Initialize (Realm  : in out Manager;
                         Params : in Parameters'Class;
                         Name   : in String := PROVIDER_OPENID);

   --  Discover the authentication provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.  The discover step may do nothing for
   --  authentication providers based on OAuth.
   --  (See OpenID Section 7.3 Discovery)
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the authentication provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

   --  Get the authentication URL to which the user must be redirected for authentication
   --  by the authentication server.
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String;

   --  Verify the authentication result
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication);

private

   use Ada.Strings.Unbounded;

   type Association is record
      Provider     : Unbounded_String;
      Session_Type : Unbounded_String;
      Assoc_Type   : Unbounded_String;
      Assoc_Handle : Unbounded_String;
      Mac_Key      : Unbounded_String;
      Expired      : Ada.Calendar.Time;
   end record;

   type Authentication is record
      Status     : Auth_Result;
      Identity   : Unbounded_String;
      Claimed_Id : Unbounded_String;
      Email      : Unbounded_String;
      Full_Name  : Unbounded_String;
      First_Name : Unbounded_String;
      Last_Name  : Unbounded_String;
      Language   : Unbounded_String;
      Country    : Unbounded_String;
      Gender     : Unbounded_String;
      Timezone   : Unbounded_String;
      Nickname   : Unbounded_String;
   end record;

   type End_Point is record
      URL        : Unbounded_String;
      Alias      : Unbounded_String;
      Expired    : Ada.Calendar.Time;
   end record;

   type Manager_Access is access all Manager'Class;

   type Manager is new Ada.Finalization.Limited_Controlled with record
      Provider  : Unbounded_String;
      Delegate  : Manager_Access;
   end record;

   type Principal is new Security.Principal with record
      Auth : Authentication;
   end record;

   procedure Set_Result (Result  : in out Authentication;
                         Status  : in Auth_Result;
                         Message : in String);

end Security.Auth;

Rename the Initialize parameters

Rename the Initialize parameters


-----------------------------------------------------------------------
--  ASF tests - ASF Tests Framework
--  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 GNAT.Regpat;

with Ada.Strings.Unbounded;

with Util.Files;
with Util.Log.Loggers;

with ASF.Streams;
with ASF.Servlets.Faces;
with ASF.Servlets.Files;
with ASF.Servlets.Ajax;
with ASF.Servlets.Measures;
with ASF.Responses;
with ASF.Responses.Tools;

with ASF.Filters.Dump;

package body ASF.Tests is

   use Ada.Strings.Unbounded;
   use Util.Tests;

   Log      : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Tests");

   CONTEXT_PATH : constant String := "/asfunit";

   Server   : access ASF.Server.Container;

   App      : ASF.Applications.Main.Application_Access := null;
   Faces    : aliased ASF.Servlets.Faces.Faces_Servlet;
   Files    : aliased ASF.Servlets.Files.File_Servlet;
   Ajax     : aliased ASF.Servlets.Ajax.Ajax_Servlet;
   Dump     : aliased ASF.Filters.Dump.Dump_Filter;
   Measures : aliased ASF.Servlets.Measures.Measure_Servlet;

   --  Save the response headers and content in a file
   procedure Save_Response (Name     : in String;
                            Response : in out ASF.Responses.Mockup.Response);

   --  ------------------------------
   --  Initialize the awa test framework mockup.
   --  ------------------------------
   procedure Initialize (Props       : in Util.Properties.Manager;
                         Application : in ASF.Applications.Main.Application_Access := null;
                         Factory     : in out ASF.Applications.Main.Application_Factory'Class) is
      use type ASF.Applications.Main.Application_Access;

      C        : ASF.Applications.Config;
   begin
      if Application /= null then
         App := Application;
      else
         App := new ASF.Applications.Main.Application;
      end if;

      Server := new ASF.Server.Container;
      Server.Register_Application (CONTEXT_PATH, App.all'Access);

      C.Copy (Props);
      App.Initialize (C, Factory);
      App.Register ("layoutMsg", "layout");
      App.Set_Global ("contextPath", CONTEXT_PATH);

      --  Register the servlets and filters
      App.Add_Servlet (Name => "faces", Server => Faces'Access);
      App.Add_Servlet (Name => "files", Server => Files'Access);
      App.Add_Servlet (Name => "ajax", Server => Ajax'Access);
      App.Add_Servlet (Name => "measures", Server => Measures'Access);
      App.Add_Filter (Name => "dump", Filter => Dump'Access);
      App.Add_Filter (Name => "measures", Filter => Measures'Access);

      --  Define servlet mappings
      App.Add_Mapping (Name => "faces", Pattern => "*.html");
      App.Add_Mapping (Name => "files", Pattern => "*.css");
      App.Add_Mapping (Name => "files", Pattern => "*.js");
      App.Add_Mapping (Name => "files", Pattern => "*.properties");
      App.Add_Mapping (Name => "files", Pattern => "*.xhtml");
      App.Add_Mapping (Name => "ajax", Pattern => "/ajax/*");
      App.Add_Mapping (Name => "measures", Pattern => "stats.xml");

      App.Add_Filter_Mapping (Name => "measures", Pattern => "*");
      App.Add_Filter_Mapping (Name => "measures", Pattern => "/ajax/*");
      App.Add_Filter_Mapping (Name => "measures", Pattern => "*.html");
      App.Add_Filter_Mapping (Name => "measures", Pattern => "*.xhtml");
      App.Add_Filter_Mapping (Name => "dump", Pattern => "*.html");
      App.Add_Filter_Mapping (Name => "dump", Pattern => "*.css");
      App.Add_Filter_Mapping (Name => "dump", Pattern => "/ajax/*");
   end Initialize;

   --  ------------------------------
   --  Get the server
   --  ------------------------------
   function Get_Server return access ASF.Server.Container is
   begin
      return Server;
   end Get_Server;

   --  ------------------------------
   --  Get the test application.
   --  ------------------------------
   function Get_Application return ASF.Applications.Main.Application_Access is
   begin
      return App;
   end Get_Application;

   --  ------------------------------
   --  Save the response headers and content in a file
   --  ------------------------------
   procedure Save_Response (Name     : in String;
                            Response : in out ASF.Responses.Mockup.Response) is
      use ASF.Responses;

      Info        : constant String := Tools.To_String (Reply         => Response,
                                                        Html          => False,
                                                        Print_Headers => True);
      Result_Path : constant String := Util.Tests.Get_Test_Path ("regtests/result");
      Content     : Unbounded_String;
      Stream      : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
   begin
      Response.Read_Content (Content);
      Stream.Write (Content);

      Insert (Content, 1, Info);
      Util.Files.Write_File (Result_Path & "/" & Name, Content);

   end Save_Response;

   --  ------------------------------
   --  Simulate a raw request.  The URI and method must have been set on the Request object.
   --  ------------------------------
   procedure Do_Req (Request  : in out ASF.Requests.Mockup.Request;
                     Response : in out ASF.Responses.Mockup.Response) is
   begin
      --  For the purpose of writing tests, clear the buffer before invoking the service.
      Response.Clear;
      Server.Service (Request  => Request,
                      Response => Response);
   end Do_Req;

   --  ------------------------------
   --  Simulate a GET request on the given URI with the request parameters.
   --  Get the result in the response object.
   --  ------------------------------
   procedure Do_Get (Request  : in out ASF.Requests.Mockup.Request;
                     Response : in out ASF.Responses.Mockup.Response;
                     URI      : in String;
                     Save     : in String := "") is
   begin
      Request.Set_Method (Method => "GET");
      Request.Set_Request_URI (URI => CONTEXT_PATH & URI);
      Request.Set_Protocol (Protocol => "HTTP/1.1");
      Do_Req (Request, Response);

      if Save'Length > 0 then
         Save_Response (Save, Response);
      end if;
   end Do_Get;

   --  ------------------------------
   --  Simulate a POST request on the given URI with the request parameters.
   --  Get the result in the response object.
   --  ------------------------------
   procedure Do_Post (Request  : in out ASF.Requests.Mockup.Request;
                      Response : in out ASF.Responses.Mockup.Response;
                      URI      : in String;
                      Save     : in String := "") is
   begin
      Request.Set_Method (Method => "POST");
      Request.Set_Request_URI (URI => CONTEXT_PATH & URI);
      Request.Set_Protocol (Protocol => "HTTP/1.1");
      Do_Req (Request, Response);

      if Save'Length > 0 then
         Save_Response (Save, Response);
      end if;
   end Do_Post;

   --  ------------------------------
   --  Check that the response body contains the string
   --  ------------------------------
   procedure Assert_Contains (T       : in Util.Tests.Test'Class;
                              Value   : in String;
                              Reply   : in out ASF.Responses.Mockup.Response;
                              Message : in String := "Test failed";
                              Source  : String := GNAT.Source_Info.File;
                              Line    : Natural := GNAT.Source_Info.Line) is
      Stream  : ASF.Streams.Print_Stream := Reply.Get_Output_Stream;
      Content : Unbounded_String;
   begin
      Reply.Read_Content (Content);
      Stream.Write (Content);

      Assert_Equals (T, ASF.Responses.SC_OK, Reply.Get_Status, "Invalid response", Source, Line);

      T.Assert (Condition => Index (Content, Value) > 0,
                Message   => Message & ": value '" & Value & "' not found",
                Source    => Source,
                Line      => Line);
   end Assert_Contains;

   --  ------------------------------
   --  Check that the response body matches the regular expression
   --  ------------------------------
   procedure Assert_Matches (T       : in Util.Tests.Test'Class;
                             Pattern : in String;
                             Reply   : in out ASF.Responses.Mockup.Response;
                             Message : in String := "Test failed";
                             Source  : String := GNAT.Source_Info.File;
                             Line    : Natural := GNAT.Source_Info.Line) is
      use GNAT.Regpat;

      Stream  : ASF.Streams.Print_Stream := Reply.Get_Output_Stream;
      Content : Unbounded_String;
      Regexp  : constant Pattern_Matcher := Compile (Expression => Pattern,
                                                     Flags      => Multiple_Lines);
   begin
      Reply.Read_Content (Content);
      Stream.Write (Content);

      Assert_Equals (T, ASF.Responses.SC_OK, Reply.Get_Status, "Invalid response", Source, Line);

      T.Assert (Condition => Match (Regexp, To_String (Content)),
                Message   => Message & ": does not match '" & Pattern & "'",
                Source    => Source,
                Line      => Line);
   end Assert_Matches;

   --  ------------------------------
   --  Check that the response body is a redirect to the given URI.
   --  ------------------------------
   procedure Assert_Redirect (T       : in Util.Tests.Test'Class;
                              Value   : in String;
                              Reply   : in out ASF.Responses.Mockup.Response;
                              Message : in String := "Test failed";
                              Source  : String := GNAT.Source_Info.File;
                              Line    : Natural := GNAT.Source_Info.Line) is
   begin
      Assert_Equals (T, ASF.Responses.SC_MOVED_TEMPORARILY, Reply.Get_Status,
                     "Invalid response", Source, Line);

      Util.Tests.Assert_Equals (T, Value, Reply.Get_Header ("Location"),
                                Message & ": missing Location",
                                Source, Line);
   end Assert_Redirect;

end ASF.Tests;

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

with GNAT.Regpat;

with Ada.Strings.Unbounded;

with Util.Files;

with ASF.Streams;
with ASF.Servlets.Faces;
with ASF.Servlets.Files;
with ASF.Servlets.Ajax;
with ASF.Servlets.Measures;
with ASF.Responses;
with ASF.Responses.Tools;

with ASF.Filters.Dump;

package body ASF.Tests is

   use Ada.Strings.Unbounded;
   use Util.Tests;

   CONTEXT_PATH : constant String := "/asfunit";

   Server   : access ASF.Server.Container;

   App      : ASF.Applications.Main.Application_Access := null;
   Faces    : aliased ASF.Servlets.Faces.Faces_Servlet;
   Files    : aliased ASF.Servlets.Files.File_Servlet;
   Ajax     : aliased ASF.Servlets.Ajax.Ajax_Servlet;
   Dump     : aliased ASF.Filters.Dump.Dump_Filter;
   Measures : aliased ASF.Servlets.Measures.Measure_Servlet;

   --  Save the response headers and content in a file
   procedure Save_Response (Name     : in String;
                            Response : in out ASF.Responses.Mockup.Response);

   --  ------------------------------
   --  Initialize the awa test framework mockup.
   --  ------------------------------
   procedure Initialize (Props       : in Util.Properties.Manager;
                         Application : in ASF.Applications.Main.Application_Access := null;
                         Factory     : in out ASF.Applications.Main.Application_Factory'Class) is
      use type ASF.Applications.Main.Application_Access;

      C        : ASF.Applications.Config;
   begin
      if Application /= null then
         App := Application;
      else
         App := new ASF.Applications.Main.Application;
      end if;

      Server := new ASF.Server.Container;
      Server.Register_Application (CONTEXT_PATH, App.all'Access);

      C.Copy (Props);
      App.Initialize (C, Factory);
      App.Register ("layoutMsg", "layout");
      App.Set_Global ("contextPath", CONTEXT_PATH);

      --  Register the servlets and filters
      App.Add_Servlet (Name => "faces", Server => Faces'Access);
      App.Add_Servlet (Name => "files", Server => Files'Access);
      App.Add_Servlet (Name => "ajax", Server => Ajax'Access);
      App.Add_Servlet (Name => "measures", Server => Measures'Access);
      App.Add_Filter (Name => "dump", Filter => Dump'Access);
      App.Add_Filter (Name => "measures", Filter => Measures'Access);

      --  Define servlet mappings
      App.Add_Mapping (Name => "faces", Pattern => "*.html");
      App.Add_Mapping (Name => "files", Pattern => "*.css");
      App.Add_Mapping (Name => "files", Pattern => "*.js");
      App.Add_Mapping (Name => "files", Pattern => "*.properties");
      App.Add_Mapping (Name => "files", Pattern => "*.xhtml");
      App.Add_Mapping (Name => "ajax", Pattern => "/ajax/*");
      App.Add_Mapping (Name => "measures", Pattern => "stats.xml");

      App.Add_Filter_Mapping (Name => "measures", Pattern => "*");
      App.Add_Filter_Mapping (Name => "measures", Pattern => "/ajax/*");
      App.Add_Filter_Mapping (Name => "measures", Pattern => "*.html");
      App.Add_Filter_Mapping (Name => "measures", Pattern => "*.xhtml");
      App.Add_Filter_Mapping (Name => "dump", Pattern => "*.html");
      App.Add_Filter_Mapping (Name => "dump", Pattern => "*.css");
      App.Add_Filter_Mapping (Name => "dump", Pattern => "/ajax/*");
   end Initialize;

   --  ------------------------------
   --  Get the server
   --  ------------------------------
   function Get_Server return access ASF.Server.Container is
   begin
      return Server;
   end Get_Server;

   --  ------------------------------
   --  Get the test application.
   --  ------------------------------
   function Get_Application return ASF.Applications.Main.Application_Access is
   begin
      return App;
   end Get_Application;

   --  ------------------------------
   --  Save the response headers and content in a file
   --  ------------------------------
   procedure Save_Response (Name     : in String;
                            Response : in out ASF.Responses.Mockup.Response) is
      use ASF.Responses;

      Info        : constant String := Tools.To_String (Reply         => Response,
                                                        Html          => False,
                                                        Print_Headers => True);
      Result_Path : constant String := Util.Tests.Get_Test_Path ("regtests/result");
      Content     : Unbounded_String;
      Stream      : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
   begin
      Response.Read_Content (Content);
      Stream.Write (Content);

      Insert (Content, 1, Info);
      Util.Files.Write_File (Result_Path & "/" & Name, Content);

   end Save_Response;

   --  ------------------------------
   --  Simulate a raw request.  The URI and method must have been set on the Request object.
   --  ------------------------------
   procedure Do_Req (Request  : in out ASF.Requests.Mockup.Request;
                     Response : in out ASF.Responses.Mockup.Response) is
   begin
      --  For the purpose of writing tests, clear the buffer before invoking the service.
      Response.Clear;
      Server.Service (Request  => Request,
                      Response => Response);
   end Do_Req;

   --  ------------------------------
   --  Simulate a GET request on the given URI with the request parameters.
   --  Get the result in the response object.
   --  ------------------------------
   procedure Do_Get (Request  : in out ASF.Requests.Mockup.Request;
                     Response : in out ASF.Responses.Mockup.Response;
                     URI      : in String;
                     Save     : in String := "") is
   begin
      Request.Set_Method (Method => "GET");
      Request.Set_Request_URI (URI => CONTEXT_PATH & URI);
      Request.Set_Protocol (Protocol => "HTTP/1.1");
      Do_Req (Request, Response);

      if Save'Length > 0 then
         Save_Response (Save, Response);
      end if;
   end Do_Get;

   --  ------------------------------
   --  Simulate a POST request on the given URI with the request parameters.
   --  Get the result in the response object.
   --  ------------------------------
   procedure Do_Post (Request  : in out ASF.Requests.Mockup.Request;
                      Response : in out ASF.Responses.Mockup.Response;
                      URI      : in String;
                      Save     : in String := "") is
   begin
      Request.Set_Method (Method => "POST");
      Request.Set_Request_URI (URI => CONTEXT_PATH & URI);
      Request.Set_Protocol (Protocol => "HTTP/1.1");
      Do_Req (Request, Response);

      if Save'Length > 0 then
         Save_Response (Save, Response);
      end if;
   end Do_Post;

   --  ------------------------------
   --  Check that the response body contains the string
   --  ------------------------------
   procedure Assert_Contains (T       : in Util.Tests.Test'Class;
                              Value   : in String;
                              Reply   : in out ASF.Responses.Mockup.Response;
                              Message : in String := "Test failed";
                              Source  : String := GNAT.Source_Info.File;
                              Line    : Natural := GNAT.Source_Info.Line) is
      Stream  : ASF.Streams.Print_Stream := Reply.Get_Output_Stream;
      Content : Unbounded_String;
   begin
      Reply.Read_Content (Content);
      Stream.Write (Content);

      Assert_Equals (T, ASF.Responses.SC_OK, Reply.Get_Status, "Invalid response", Source, Line);

      T.Assert (Condition => Index (Content, Value) > 0,
                Message   => Message & ": value '" & Value & "' not found",
                Source    => Source,
                Line      => Line);
   end Assert_Contains;

   --  ------------------------------
   --  Check that the response body matches the regular expression
   --  ------------------------------
   procedure Assert_Matches (T       : in Util.Tests.Test'Class;
                             Pattern : in String;
                             Reply   : in out ASF.Responses.Mockup.Response;
                             Message : in String := "Test failed";
                             Source  : String := GNAT.Source_Info.File;
                             Line    : Natural := GNAT.Source_Info.Line) is
      use GNAT.Regpat;

      Stream  : ASF.Streams.Print_Stream := Reply.Get_Output_Stream;
      Content : Unbounded_String;
      Regexp  : constant Pattern_Matcher := Compile (Expression => Pattern,
                                                     Flags      => Multiple_Lines);
   begin
      Reply.Read_Content (Content);
      Stream.Write (Content);

      Assert_Equals (T, ASF.Responses.SC_OK, Reply.Get_Status, "Invalid response", Source, Line);

      T.Assert (Condition => Match (Regexp, To_String (Content)),
                Message   => Message & ": does not match '" & Pattern & "'",
                Source    => Source,
                Line      => Line);
   end Assert_Matches;

   --  ------------------------------
   --  Check that the response body is a redirect to the given URI.
   --  ------------------------------
   procedure Assert_Redirect (T       : in Util.Tests.Test'Class;
                              Value   : in String;
                              Reply   : in out ASF.Responses.Mockup.Response;
                              Message : in String := "Test failed";
                              Source  : String := GNAT.Source_Info.File;
                              Line    : Natural := GNAT.Source_Info.Line) is
   begin
      Assert_Equals (T, ASF.Responses.SC_MOVED_TEMPORARILY, Reply.Get_Status,
                     "Invalid response", Source, Line);

      Util.Tests.Assert_Equals (T, Value, Reply.Get_Header ("Location"),
                                Message & ": missing Location",
                                Source, Line);
   end Assert_Redirect;

end ASF.Tests;

Fix compilation warning

Fix compilation warning


-----------------------------------------------------------------------
--  mat-events-timelines - Timelines
--  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 MAT.Frames;
package body MAT.Events.Timelines is

   use MAT.Events.Targets;

   ITERATE_COUNT : constant MAT.Events.Event_Id_Type := 10_000;

   procedure Extract (Target : in out MAT.Events.Targets.Target_Events'Class;
                      Into   : in out Timeline_Info_Vector) is
      use type MAT.Types.Target_Time;
      use type MAT.Types.Target_Size;
      procedure Collect (Event : in MAT.Events.Target_Event_Type);

      First_Event : MAT.Events.Target_Event_Type;
      Last_Event  : MAT.Events.Target_Event_Type;
      Prev_Event  : MAT.Events.Target_Event_Type;
      Info        : Timeline_Info;
      First_Id    : MAT.Events.Event_Id_Type;

      procedure Collect (Event : in MAT.Events.Target_Event_Type) is
         Dt : constant MAT.Types.Target_Time := Event.Time - Prev_Event.Time;
      begin
         if Dt > 500_000 then
            Into.Append (Info);
            Info.Malloc_Count := 0;
            Info.Realloc_Count := 0;
            Info.Free_Count := 0;
            Info.First_Event := Event;
            Info.Free_Size := 0;
            Info.Alloc_Size := 0;
            Prev_Event := Event;
         end if;
         Info.Last_Event := Event;
         if Event.Event = 2 then
            Info.Malloc_Count := Info.Malloc_Count + 1;
            Info.Alloc_Size := Info.Alloc_Size + Event.Size;
         elsif Event.Event = 3 then
            Info.Realloc_Count := Info.Realloc_Count + 1;
            Info.Alloc_Size := Info.Alloc_Size + Event.Size;
            Info.Free_Size := Info.Free_Size + Event.Old_Size;
         elsif Event.Event = 4 then
            Info.Free_Count := Info.Free_Count + 1;
            Info.Free_Size := Info.Free_Size + Event.Size;
         end if;
      end Collect;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      Prev_Event      := First_Event;
      Info.First_Event := First_Event;
      First_Id := First_Event.Id;
      while First_Id < Last_Event.Id loop
         Target.Iterate (Start   => First_Id,
                         Finish  => First_Id + ITERATE_COUNT,
                         Process => Collect'Access);
         First_Id := First_Id + ITERATE_COUNT;
      end loop;
   end Extract;

   --  ------------------------------
   --  Find in the events stream the events which are associated with a given event.
   --  When the <tt>Event</tt> is a memory allocation, find the associated reallocation
   --  and free events.  When the event is a free, find the associated allocations.
   --  Collect at most <tt>Max</tt> events.
   --  ------------------------------
   procedure Find_Related (Target : in out MAT.Events.Targets.Target_Events'Class;
                           Event  : in MAT.Events.Target_Event_Type;
                           Max    : in Positive;
                           List   : in out MAT.Events.Tools.Target_Event_Vector) is

      procedure Collect_Free (Event : in MAT.Events.Target_Event_Type);
      procedure Collect_Alloc (Event : in MAT.Events.Target_Event_Type);

      First_Id    : MAT.Events.Event_Id_Type;
      Last_Id     : MAT.Events.Event_Id_Type;
      First_Event : MAT.Events.Target_Event_Type;
      Last_Event  : MAT.Events.Target_Event_Type;
      Addr        : MAT.Types.Target_Addr := Event.Addr;

      Done : exception;

      procedure Collect_Free (Event : in MAT.Events.Target_Event_Type) is
      begin
         if Event.Index = MAT.Events.MSG_FREE and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.MSG_REALLOC and then Event.Old_Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Addr;
         end if;
      end Collect_Free;

      procedure Collect_Alloc (Event : in MAT.Events.Target_Event_Type) is
      begin
         if Event.Index = MAT.Events.MSG_MALLOC and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.MSG_REALLOC and then Event.Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Old_Addr;
         end if;
      end Collect_Alloc;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      First_Id := Event.Id;
      if Event.Index = MAT.Events.MSG_FREE then
         --  Search backward for MSG_MALLOC and MSG_REALLOC.
         First_Id := First_Id - 1;
         while First_Id > First_Event.Id loop
            if First_Id > ITERATE_COUNT then
               Last_Id := First_Id - ITERATE_COUNT;
            else
               Last_Id := First_Event.Id;
            end if;
            Target.Iterate (Start   => First_Id,
                            Finish  => Last_Id,
                            Process => Collect_Alloc'Access);
            First_Id := Last_Id;
         end loop;
      else
         --  Search forward for MSG_REALLOC and MSG_FREE
         First_Id := First_Id + 1;
         while First_Id < Last_Event.Id loop
            Target.Iterate (Start   => First_Id,
                            Finish  => First_Id + ITERATE_COUNT,
                            Process => Collect_Free'Access);
            First_Id := First_Id + ITERATE_COUNT;
         end loop;
      end if;

   exception
      when Done =>
         null;
   end Find_Related;

   --  ------------------------------
   --  Find the sizes of malloc and realloc events which is selected by the given filter.
   --  Update the <tt>Sizes</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding size.
   --  ------------------------------
   procedure Find_Sizes (Target : in out MAT.Events.Targets.Target_Events'Class;
                         Filter : in MAT.Expressions.Expression_Type;
                         Sizes  : in out MAT.Events.Tools.Size_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type);

      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type) is
         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Tools.Event_Info_Type);

         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Tools.Event_Info_Type) is
            pragma Unreferenced (Size);
         begin
            Info.Count      := Info.Count + 1;
            Info.Last_Event := Event;
            if Event.Index = MAT.Events.MSG_MALLOC then
               Info.Alloc_Size := Info.Alloc_Size + Event.Size;
            elsif Event.Index = MAT.Events.MSG_REALLOC then
               Info.Alloc_Size := Info.Alloc_Size + Event.Size;
               Info.Free_Size := Info.Alloc_Size + Event.Old_Size;
            else
               Info.Free_Size := Info.Alloc_Size + Event.Size;
            end if;
         end Update_Size;

      begin
         --  Look for malloc or realloc events which are selected by the filter.
         if (Event.Index /= MAT.Events.MSG_MALLOC
             and Event.Index /= MAT.Events.MSG_FREE
             and Event.Index /= MAT.Events.MSG_REALLOC)
           or else not Filter.Is_Selected (Event)
         then
            return;
         end if;
         declare
            Pos : constant MAT.Events.Tools.Size_Event_Info_Cursor := Sizes.Find (Event.Size);
         begin
            if MAT.Events.Tools.Size_Event_Info_Maps.Has_Element (Pos) then
               --  Increment the count and update the last event.
               Sizes.Update_Element (Pos, Update_Size'Access);
            else
               declare
                  Info : MAT.Events.Tools.Event_Info_Type;
               begin
                  --  Insert a new size with the event.
                  Info.First_Event := Event;
                  Info.Last_Event := Event;
                  Info.Count := 1;
                  if Event.Index = MAT.Events.MSG_MALLOC then
                     Info.Alloc_Size := Event.Size;
                  elsif Event.Index = MAT.Events.MSG_REALLOC then
                     Info.Alloc_Size := Event.Size;
                     Info.Free_Size := Event.Old_Size;
                  else
                     Info.Free_Size := Event.Size;
                  end if;
                  Sizes.Insert (Event.Size, Info);
               end;
            end if;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Sizes;

   --  ------------------------------
   --  Find the function address from the call event frames for the events which is selected
   --  by the given filter.  The function addresses are collected up to the given frame depth.
   --  Update the <tt>Frames</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding frame address.
   --  ------------------------------
   procedure Find_Frames (Target : in out MAT.Events.Targets.Target_Events'Class;
                          Filter : in MAT.Expressions.Expression_Type;
                          Depth  : in Natural;
                          Frames : in out MAT.Events.Tools.Frame_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type);

      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type) is

         procedure Update_Size (Key  : in MAT.Events.Tools.Frame_Key_Type;
                                Info : in out MAT.Events.Tools.Event_Info_Type);

         procedure Update_Size (Key  : in MAT.Events.Tools.Frame_Key_Type;
                                Info : in out MAT.Events.Tools.Event_Info_Type) is
            pragma Unreferenced (Key);
         begin
            Info.Count      := Info.Count + 1;
            Info.Last_Event := Event;
         end Update_Size;

      begin
         --  Look for events which are selected by the filter.
         if not Filter.Is_Selected (Event) then
            return;
         end if;
         declare
            Backtrace : constant MAT.Frames.Frame_Table := MAT.Frames.Backtrace (Event.Frame);
            Key       : MAT.Events.Tools.Frame_Key_Type;
         begin
            for I in Backtrace'Range loop
               exit when I > Depth;
               Key.Addr  := Backtrace (I);
               Key.Level := I;
               declare
                  Pos : constant MAT.Events.Tools.Frame_Event_Info_Cursor
                    := Frames.Find (Key);
               begin
                  if MAT.Events.Tools.Frame_Event_Info_Maps.Has_Element (Pos) then
                     --  Increment the count and update the last event.
                     Frames.Update_Element (Pos, Update_Size'Access);
                  else
                     declare
                        Info : MAT.Events.Tools.Event_Info_Type;
                     begin
                        --  Insert a new size with the event.
                        Info.First_Event := Event;
                        Info.Last_Event := Event;
                        Info.Frame_Addr := Key.Addr;
                        Info.Count := 1;
                        Frames.Insert (Key, Info);
                     end;
                  end if;
               end;
            end loop;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Frames;

end MAT.Events.Timelines;

-----------------------------------------------------------------------
--  mat-events-timelines - Timelines
--  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 MAT.Frames;
package body MAT.Events.Timelines is

   use MAT.Events.Targets;

   ITERATE_COUNT : constant MAT.Events.Event_Id_Type := 10_000;

   procedure Extract (Target : in out MAT.Events.Targets.Target_Events'Class;
                      Into   : in out Timeline_Info_Vector) is
      use type MAT.Types.Target_Time;
      use type MAT.Types.Target_Size;
      procedure Collect (Event : in MAT.Events.Target_Event_Type);

      First_Event : MAT.Events.Target_Event_Type;
      Last_Event  : MAT.Events.Target_Event_Type;
      Prev_Event  : MAT.Events.Target_Event_Type;
      Info        : Timeline_Info;
      First_Id    : MAT.Events.Event_Id_Type;

      procedure Collect (Event : in MAT.Events.Target_Event_Type) is
         Dt : constant MAT.Types.Target_Time := Event.Time - Prev_Event.Time;
      begin
         if Dt > 500_000 then
            Into.Append (Info);
            Info.Malloc_Count := 0;
            Info.Realloc_Count := 0;
            Info.Free_Count := 0;
            Info.First_Event := Event;
            Info.Free_Size := 0;
            Info.Alloc_Size := 0;
            Prev_Event := Event;
         end if;
         Info.Last_Event := Event;
         if Event.Event = 2 then
            Info.Malloc_Count := Info.Malloc_Count + 1;
            Info.Alloc_Size := Info.Alloc_Size + Event.Size;
         elsif Event.Event = 3 then
            Info.Realloc_Count := Info.Realloc_Count + 1;
            Info.Alloc_Size := Info.Alloc_Size + Event.Size;
            Info.Free_Size := Info.Free_Size + Event.Old_Size;
         elsif Event.Event = 4 then
            Info.Free_Count := Info.Free_Count + 1;
            Info.Free_Size := Info.Free_Size + Event.Size;
         end if;
      end Collect;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      Prev_Event      := First_Event;
      Info.First_Event := First_Event;
      First_Id := First_Event.Id;
      while First_Id < Last_Event.Id loop
         Target.Iterate (Start   => First_Id,
                         Finish  => First_Id + ITERATE_COUNT,
                         Process => Collect'Access);
         First_Id := First_Id + ITERATE_COUNT;
      end loop;
   end Extract;

   --  ------------------------------
   --  Find in the events stream the events which are associated with a given event.
   --  When the <tt>Event</tt> is a memory allocation, find the associated reallocation
   --  and free events.  When the event is a free, find the associated allocations.
   --  Collect at most <tt>Max</tt> events.
   --  ------------------------------
   procedure Find_Related (Target : in out MAT.Events.Targets.Target_Events'Class;
                           Event  : in MAT.Events.Target_Event_Type;
                           Max    : in Positive;
                           List   : in out MAT.Events.Tools.Target_Event_Vector) is

      procedure Collect_Free (Event : in MAT.Events.Target_Event_Type);
      procedure Collect_Alloc (Event : in MAT.Events.Target_Event_Type);

      First_Id    : MAT.Events.Event_Id_Type;
      Last_Id     : MAT.Events.Event_Id_Type;
      First_Event : MAT.Events.Target_Event_Type;
      Last_Event  : MAT.Events.Target_Event_Type;
      Addr        : MAT.Types.Target_Addr := Event.Addr;

      Done : exception;

      procedure Collect_Free (Event : in MAT.Events.Target_Event_Type) is
      begin
         if Event.Index = MAT.Events.MSG_FREE and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.MSG_REALLOC and then Event.Old_Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Addr;
         end if;
      end Collect_Free;

      procedure Collect_Alloc (Event : in MAT.Events.Target_Event_Type) is
      begin
         if Event.Index = MAT.Events.MSG_MALLOC and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.MSG_REALLOC and then Event.Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Old_Addr;
         end if;
      end Collect_Alloc;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      First_Id := Event.Id;
      if Event.Index = MAT.Events.MSG_FREE then
         --  Search backward for MSG_MALLOC and MSG_REALLOC.
         First_Id := First_Id - 1;
         while First_Id > First_Event.Id loop
            if First_Id > ITERATE_COUNT then
               Last_Id := First_Id - ITERATE_COUNT;
            else
               Last_Id := First_Event.Id;
            end if;
            Target.Iterate (Start   => First_Id,
                            Finish  => Last_Id,
                            Process => Collect_Alloc'Access);
            First_Id := Last_Id;
         end loop;
      else
         --  Search forward for MSG_REALLOC and MSG_FREE
         First_Id := First_Id + 1;
         while First_Id < Last_Event.Id loop
            Target.Iterate (Start   => First_Id,
                            Finish  => First_Id + ITERATE_COUNT,
                            Process => Collect_Free'Access);
            First_Id := First_Id + ITERATE_COUNT;
         end loop;
      end if;

   exception
      when Done =>
         null;
   end Find_Related;

   --  ------------------------------
   --  Find the sizes of malloc and realloc events which is selected by the given filter.
   --  Update the <tt>Sizes</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding size.
   --  ------------------------------
   procedure Find_Sizes (Target : in out MAT.Events.Targets.Target_Events'Class;
                         Filter : in MAT.Expressions.Expression_Type;
                         Sizes  : in out MAT.Events.Tools.Size_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type);

      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type) is
         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Tools.Event_Info_Type);

         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Tools.Event_Info_Type) is
            pragma Unreferenced (Size);
         begin
            Info.Count      := Info.Count + 1;
            Info.Last_Event := Event;
            if Event.Index = MAT.Events.MSG_MALLOC then
               Info.Alloc_Size := Info.Alloc_Size + Event.Size;
            elsif Event.Index = MAT.Events.MSG_REALLOC then
               Info.Alloc_Size := Info.Alloc_Size + Event.Size;
               Info.Free_Size := Info.Alloc_Size + Event.Old_Size;
            else
               Info.Free_Size := Info.Alloc_Size + Event.Size;
            end if;
         end Update_Size;

      begin
         --  Look for malloc or realloc events which are selected by the filter.
         if (Event.Index /= MAT.Events.MSG_MALLOC
             and Event.Index /= MAT.Events.MSG_FREE
             and Event.Index /= MAT.Events.MSG_REALLOC)
           or else not Filter.Is_Selected (Event)
         then
            return;
         end if;
         declare
            Pos : constant MAT.Events.Tools.Size_Event_Info_Cursor := Sizes.Find (Event.Size);
         begin
            if MAT.Events.Tools.Size_Event_Info_Maps.Has_Element (Pos) then
               --  Increment the count and update the last event.
               Sizes.Update_Element (Pos, Update_Size'Access);
            else
               declare
                  Info : MAT.Events.Tools.Event_Info_Type;
               begin
                  --  Insert a new size with the event.
                  Info.First_Event := Event;
                  Info.Last_Event := Event;
                  Info.Count := 1;
                  if Event.Index = MAT.Events.MSG_MALLOC then
                     Info.Alloc_Size := Event.Size;
                  elsif Event.Index = MAT.Events.MSG_REALLOC then
                     Info.Alloc_Size := Event.Size;
                     Info.Free_Size := Event.Old_Size;
                  else
                     Info.Free_Size := Event.Size;
                  end if;
                  Sizes.Insert (Event.Size, Info);
               end;
            end if;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Sizes;

   --  ------------------------------
   --  Find the function address from the call event frames for the events which is selected
   --  by the given filter.  The function addresses are collected up to the given frame depth.
   --  Update the <tt>Frames</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding frame address.
   --  ------------------------------
   procedure Find_Frames (Target : in out MAT.Events.Targets.Target_Events'Class;
                          Filter : in MAT.Expressions.Expression_Type;
                          Depth  : in Natural;
                          Frames : in out MAT.Events.Tools.Frame_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type);

      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type) is

         procedure Update_Size (Key  : in MAT.Events.Tools.Frame_Key_Type;
                                Info : in out MAT.Events.Tools.Event_Info_Type);

         procedure Update_Size (Key  : in MAT.Events.Tools.Frame_Key_Type;
                                Info : in out MAT.Events.Tools.Event_Info_Type) is
            pragma Unreferenced (Key);
         begin
            Info.Count      := Info.Count + 1;
            Info.Last_Event := Event;
            if Event.Event = 2 then
               Info.Malloc_Count := Info.Malloc_Count + 1;
               Info.Alloc_Size := Info.Alloc_Size + Event.Size;
            elsif Event.Event = 3 then
               Info.Realloc_Count := Info.Realloc_Count + 1;
               Info.Alloc_Size := Info.Alloc_Size + Event.Size;
               Info.Free_Size := Info.Free_Size + Event.Old_Size;
            elsif Event.Event = 4 then
               Info.Free_Count := Info.Free_Count + 1;
               Info.Free_Size := Info.Free_Size + Event.Size;
            end if;
         end Update_Size;

      begin
         --  Look for events which are selected by the filter.
         if not Filter.Is_Selected (Event) then
            return;
         end if;
         declare
            Backtrace : constant MAT.Frames.Frame_Table := MAT.Frames.Backtrace (Event.Frame);
            Key       : MAT.Events.Tools.Frame_Key_Type;
         begin
            for I in Backtrace'Range loop
               exit when I > Depth;
               Key.Addr  := Backtrace (Backtrace'Last - I + 1);
               Key.Level := I;
               declare
                  Pos : constant MAT.Events.Tools.Frame_Event_Info_Cursor
                    := Frames.Find (Key);
               begin
                  if MAT.Events.Tools.Frame_Event_Info_Maps.Has_Element (Pos) then
                     --  Increment the count and update the last event.
                     Frames.Update_Element (Pos, Update_Size'Access);
                  else
                     declare
                        Info : MAT.Events.Tools.Event_Info_Type;
                     begin
                        --  Insert a new size with the event.
                        Info.First_Event := Event;
                        Info.Last_Event := Event;
                        Info.Frame_Addr := Key.Addr;
                        Info.Count := 1;
                        Frames.Insert (Key, Info);
                     end;
                  end if;
               end;
            end loop;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Frames;

end MAT.Events.Timelines;

Update Find_Frames to collect the malloc count, realloc count, free count


-----------------------------------------------------------------------
--  gen-artifacts-xmi -- UML-XMI artifact for Code Generator
--  Copyright (C) 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 DOM.Core;
with Gen.Model.Packages;
with Gen.Model.XMI;
with Util.Strings.Sets;

--  The Gen.Artifacts.XMI package is an artifact for the generation of Ada code
--  from an UML XMI description.
package Gen.Artifacts.XMI is

   --  ------------------------------
   --  UML XMI artifact
   --  ------------------------------
   type Artifact is new Gen.Artifacts.Artifact with private;

   --  After the configuration file is read, processes the node whose root
   --  is passed in Node and initializes the Model with the information.
   overriding
   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);

   --  Prepare the model after all the configuration files have been read and before
   --  actually invoking the generation.
   overriding
   procedure Prepare (Handler : in out Artifact;
                      Model   : in out Gen.Model.Packages.Model_Definition'Class;
                      Context : in out Generator'Class);

   --  Read the UML/XMI model file.
   procedure Read_Model (Handler       : in out Artifact;
                         File          : in String;
                         Context       : in out Generator'Class;
                         Is_Predefined : in Boolean := False);

private

   --  Read the UML profiles that are referenced by the current models.
   --  The UML profiles are installed in the UML config directory for dynamo's installation.
   procedure Read_Profiles (Handler : in out Artifact;
                            Context : in out Generator'Class);

   type Artifact is new Gen.Artifacts.Artifact with record
      Nodes      : aliased Gen.Model.XMI.UML_Model;

      --  A set of profiles that are necessary for the model definitions.
      Profiles   : aliased Util.Strings.Sets.Set;

      Has_Config : Boolean := False;

      --  Stereotype which triggers the generation of database table.
      Table_Stereotype      : Gen.Model.XMI.Stereotype_Element_Access;
      PK_Stereotype         : Gen.Model.XMI.Stereotype_Element_Access;
      FK_Stereotype         : Gen.Model.XMI.Stereotype_Element_Access;
      Data_Model_Stereotype : Gen.Model.XMI.Stereotype_Element_Access;
      Nullable_Stereotype   : Gen.Model.XMI.Stereotype_Element_Access;
      Not_Null_Stereotype   : Gen.Model.XMI.Stereotype_Element_Access;
      Use_FK_Stereotype     : Gen.Model.XMI.Stereotype_Element_Access;
      Version_Stereotype    : Gen.Model.XMI.Stereotype_Element_Access;

      --  Tag definitions which control the generation.
      Has_List_Tag          : Gen.Model.XMI.Tag_Definition_Element_Access;
      Table_Name_Tag        : Gen.Model.XMI.Tag_Definition_Element_Access;
      Sql_Type_Tag          : Gen.Model.XMI.Tag_Definition_Element_Access;
      Generator_Tag         : Gen.Model.XMI.Tag_Definition_Element_Access;
      Literal_Tag           : Gen.Model.XMI.Tag_Definition_Element_Access;
      Sql_Length_Tag        : Gen.Model.XMI.Tag_Definition_Element_Access;

      --  Stereotype which triggers the generation of AWA bean types.
      Bean_Stereotype  : Gen.Model.XMI.Stereotype_Element_Access;
   end record;

end Gen.Artifacts.XMI;

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

with DOM.Core;
with Gen.Model.Packages;
with Gen.Model.XMI;
with Util.Strings.Sets;

--  The Gen.Artifacts.XMI package is an artifact for the generation of Ada code
--  from an UML XMI description.
package Gen.Artifacts.XMI is

   --  ------------------------------
   --  UML XMI artifact
   --  ------------------------------
   type Artifact is new Gen.Artifacts.Artifact with private;

   --  After the configuration file is read, processes the node whose root
   --  is passed in Node and initializes the Model with the information.
   overriding
   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);

   --  Prepare the model after all the configuration files have been read and before
   --  actually invoking the generation.
   overriding
   procedure Prepare (Handler : in out Artifact;
                      Model   : in out Gen.Model.Packages.Model_Definition'Class;
                      Context : in out Generator'Class);

   --  Read the UML/XMI model file.
   procedure Read_Model (Handler       : in out Artifact;
                         File          : in String;
                         Context       : in out Generator'Class;
                         Is_Predefined : in Boolean := False);

private

   --  Read the UML profiles that are referenced by the current models.
   --  The UML profiles are installed in the UML config directory for dynamo's installation.
   procedure Read_Profiles (Handler : in out Artifact;
                            Context : in out Generator'Class);

   type Artifact is new Gen.Artifacts.Artifact with record
      Nodes      : aliased Gen.Model.XMI.UML_Model;

      --  A set of profiles that are necessary for the model definitions.
      Profiles   : aliased Util.Strings.Sets.Set;

      Has_Config : Boolean := False;

      --  Stereotype which triggers the generation of database table.
      Table_Stereotype      : Gen.Model.XMI.Stereotype_Element_Access;
      PK_Stereotype         : Gen.Model.XMI.Stereotype_Element_Access;
      FK_Stereotype         : Gen.Model.XMI.Stereotype_Element_Access;
      Data_Model_Stereotype : Gen.Model.XMI.Stereotype_Element_Access;
      Nullable_Stereotype   : Gen.Model.XMI.Stereotype_Element_Access;
      Not_Null_Stereotype   : Gen.Model.XMI.Stereotype_Element_Access;
      Use_FK_Stereotype     : Gen.Model.XMI.Stereotype_Element_Access;
      Version_Stereotype    : Gen.Model.XMI.Stereotype_Element_Access;

      --  Tag definitions which control the generation.
      Has_List_Tag          : Gen.Model.XMI.Tag_Definition_Element_Access;
      Table_Name_Tag        : Gen.Model.XMI.Tag_Definition_Element_Access;
      Sql_Type_Tag          : Gen.Model.XMI.Tag_Definition_Element_Access;
      Generator_Tag         : Gen.Model.XMI.Tag_Definition_Element_Access;
      Literal_Tag           : Gen.Model.XMI.Tag_Definition_Element_Access;
      Sql_Length_Tag        : Gen.Model.XMI.Tag_Definition_Element_Access;

      --  Stereotype which triggers the generation of AWA bean types.
      Bean_Stereotype         : Gen.Model.XMI.Stereotype_Element_Access;
      Limited_Bean_Stereotype : Gen.Model.XMI.Stereotype_Element_Access;
   end record;

end Gen.Artifacts.XMI;

Add a Limited_Bean_Stereotype member in the XMI artifact


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

with Ada.Characters.Latin_1;
with Ada.Numerics.Generic_Elementary_Functions;

with GL.Buffers;

with Orka.Rendering.Drawing;
with Orka.Transforms.Doubles.Matrices;
with Orka.Transforms.Doubles.Vectors;
with Orka.Transforms.Doubles.Vector_Conversions;
with Orka.Transforms.Singles.Vectors;

package body Orka.Features.Atmosphere.Rendering is

   package EF is new Ada.Numerics.Generic_Elementary_Functions (GL.Types.Double);

   Altitude_Hack_Threshold : constant := 8000.0;

   function Create_Atmosphere
     (Data       : aliased Model_Data;
      Location   : Resources.Locations.Location_Ptr;
      Parameters : Model_Parameters := (others => <>)) return Atmosphere
   is
      Atmosphere_Model : constant Model := Create_Model (Data'Access, Location);

      Sky_GLSL : constant String := Resources.Convert
        (Orka.Resources.Byte_Array'(Location.Read_Data ("atmosphere/sky.frag").Get));

      use Ada.Characters.Latin_1;
      use Rendering.Programs;
      use Rendering.Programs.Modules;

      Sky_Shader : constant String :=
        "#version 420 core" & LF &
        (if Data.Luminance /= None then "#define USE_LUMINANCE" & LF else "") &
        "const float kLengthUnitInMeters = " & Data.Length_Unit_In_Meters'Image & ";" & LF &
        Sky_GLSL & LF;

      Shader_Module : constant Rendering.Programs.Modules.Module := Atmosphere_Model.Get_Shader;
   begin
      return Result : Atmosphere :=
        (Program => Create_Program (Modules.Module_Array'
           (Modules.Create_Module (Location, VS => "atmosphere/sky.vert"),
            Modules.Create_Module_From_Sources (FS => Sky_Shader),
            Shader_Module)),
         Module  => Shader_Module,
         Parameters     => Parameters,
         Bottom_Radius  => Data.Bottom_Radius,
         Distance_Scale => 1.0 / Data.Length_Unit_In_Meters,
         others => <>)
      do
         Result.Uniform_Ground_Hack   := Result.Program.Uniform ("ground_hack");
         Result.Uniform_Camera_Offset := Result.Program.Uniform ("camera_offset");

         Result.Uniform_Camera_Pos := Result.Program.Uniform ("camera_pos");
         Result.Uniform_Planet_Pos := Result.Program.Uniform ("planet_pos");

         Result.Uniform_View := Result.Program.Uniform ("view");
         Result.Uniform_Proj := Result.Program.Uniform ("proj");

         Result.Uniform_Sun_Dir  := Result.Program.Uniform ("sun_direction");

         Result.Uniform_Star_Dir  := Result.Program.Uniform ("star_direction");
         Result.Uniform_Star_Size := Result.Program.Uniform ("star_size");
      end return;
   end Create_Atmosphere;

   function Shader_Module (Object : Atmosphere) return Orka.Rendering.Programs.Modules.Module is
     (Object.Module);

   function Flattened_Vector
     (Parameters : Model_Parameters;
      Direction  : Orka.Transforms.Doubles.Vectors.Vector4)
   return Orka.Transforms.Doubles.Vectors.Vector4 is
      Altitude   : constant := 0.0;
      Flattening : GL.Types.Double renames Parameters.Flattening;

      E2 : constant GL.Types.Double := 2.0 * Flattening - Flattening**2;

      N : constant GL.Types.Double := Parameters.Semi_Major_Axis /
        EF.Sqrt (1.0 - E2 * Direction (Orka.Z)**2);
   begin
      return
        (Direction (Orka.X) * (N + Altitude),
         Direction (Orka.Y) * (N + Altitude),
         Direction (Orka.Z) * (N * (1.0 - E2) + Altitude),
         1.0);
   end Flattened_Vector;

   package Matrices renames Orka.Transforms.Doubles.Matrices;

   procedure Render
     (Object : in out Atmosphere;
      Camera : Cameras.Camera_Ptr;
      Planet : Behaviors.Behavior_Ptr;
      Star   : Behaviors.Behavior_Ptr)
   is
      function "*" (Left : Matrices.Matrix4; Right : Matrices.Vector4) return Matrices.Vector4
        renames Matrices."*";

      function "*" (Left, Right : Matrices.Matrix4) return Matrices.Matrix4 renames Matrices."*";

      function Far_Plane (Value : GL.Types.Compare_Function) return GL.Types.Compare_Function is
        (case Value is
           when Less | LEqual     => LEqual,
           when Greater | GEqual  => GEqual,
           when others            => raise Constraint_Error);

      Original_Function : constant GL.Types.Compare_Function := GL.Buffers.Depth_Function;

      use Orka.Transforms.Doubles.Vectors;
      use Orka.Transforms.Doubles.Vector_Conversions;

      use all type Orka.Transforms.Doubles.Vectors.Vector4;

      Planet_To_Camera : constant Vector4 := Camera.View_Position - Planet.Position;
      Planet_To_Star   : constant Vector4 := Star.Position - Planet.Position;
      Camera_To_Star   : constant Vector4 := Star.Position - Camera.View_Position;

      procedure Apply_Hacks is
         GL_To_Geo : constant Matrices.Matrix4 := Matrices.R
           (Matrices.Vectors.Normalize ((1.0, 1.0, 1.0, 0.0)),
            (2.0 / 3.0) * Ada.Numerics.Pi);
         Earth_Tilt : constant Matrices.Matrix4 := Matrices.R
           (Matrices.Vectors.Normalize ((1.0, 0.0, 0.0, 0.0)),
            Object.Parameters.Axial_Tilt);

         Inverse_Inertial    : constant Matrices.Matrix4 := Earth_Tilt * GL_To_Geo;
         Camera_Normal_Inert : constant Vector4 := Normalize (Inverse_Inertial * Planet_To_Camera);

         Actual_Surface   : constant Vector4 := Flattened_Vector
           (Object.Parameters, Camera_Normal_Inert);
         Expected_Surface : constant Vector4 := Camera_Normal_Inert * Object.Bottom_Radius;

         Offset   : constant Vector4 := Expected_Surface - Actual_Surface;
         Altitude : constant Double  := Length (Planet_To_Camera) - Length (Actual_Surface);
      begin
         Object.Uniform_Ground_Hack.Set_Boolean (Altitude < Altitude_Hack_Threshold);
         Object.Uniform_Camera_Offset.Set_Vector (Convert (Offset * Object.Distance_Scale));
      end Apply_Hacks;
   begin
      if Object.Parameters.Flattening > 0.0 then
         Apply_Hacks;
      else
         Object.Uniform_Ground_Hack.Set_Boolean (False);
         Object.Uniform_Camera_Offset.Set_Vector (Orka.Transforms.Singles.Vectors.Zero_Point);
      end if;

      Object.Uniform_Camera_Pos.Set_Vector (Orka.Transforms.Singles.Vectors.Zero_Point);
      Object.Uniform_Planet_Pos.Set_Vector (Convert (-Planet_To_Camera * Object.Distance_Scale));

      Object.Uniform_Sun_Dir.Set_Vector (Convert (Normalize (Planet_To_Star)));
      Object.Uniform_Star_Dir.Set_Vector (Convert (Normalize (Camera_To_Star)));

      --  Use distance to star and its radius instead of the
      --  Sun_Angular_Radius of Model_Data
      declare
         Angular_Radius : constant GL.Types.Double :=
           EF.Arctan (Object.Parameters.Star_Radius, Length (Camera_To_Star));
      begin
         Object.Uniform_Star_Size.Set_Single (GL.Types.Single (EF.Cos (Angular_Radius)));
      end;

      Object.Uniform_View.Set_Matrix (Camera.View_Matrix);
      Object.Uniform_Proj.Set_Matrix (Camera.Projection_Matrix);

      Object.Program.Use_Program;

      GL.Buffers.Set_Depth_Function (Far_Plane (Original_Function));
      Orka.Rendering.Drawing.Draw (GL.Types.Triangles, 0, 3);
      GL.Buffers.Set_Depth_Function (Original_Function);
   end Render;

end Orka.Features.Atmosphere.Rendering;

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

with Ada.Characters.Latin_1;
with Ada.Numerics.Generic_Elementary_Functions;

with GL.Buffers;

with Orka.Rendering.Drawing;
with Orka.Transforms.Doubles.Matrices;
with Orka.Transforms.Doubles.Vectors;
with Orka.Transforms.Doubles.Vector_Conversions;
with Orka.Transforms.Singles.Vectors;

package body Orka.Features.Atmosphere.Rendering is

   package EF is new Ada.Numerics.Generic_Elementary_Functions (GL.Types.Double);

   Altitude_Hack_Threshold : constant := 8000.0;

   function Create_Atmosphere
     (Data       : aliased Model_Data;
      Location   : Resources.Locations.Location_Ptr;
      Parameters : Model_Parameters := (others => <>)) return Atmosphere
   is
      Atmosphere_Model : constant Model := Create_Model (Data'Access, Location);

      Sky_GLSL : constant String := Resources.Convert
        (Orka.Resources.Byte_Array'(Location.Read_Data ("atmosphere/sky.frag").Get));

      use Ada.Characters.Latin_1;
      use Rendering.Programs;
      use Rendering.Programs.Modules;

      Sky_Shader : constant String :=
        "#version 420 core" & LF &
        (if Data.Luminance /= None then "#define USE_LUMINANCE" & LF else "") &
        "const float kLengthUnitInMeters = " & Data.Length_Unit_In_Meters'Image & ";" & LF &
        Sky_GLSL & LF;

      Shader_Module : constant Rendering.Programs.Modules.Module := Atmosphere_Model.Get_Shader;
   begin
      return Result : Atmosphere :=
        (Program => Create_Program (Modules.Module_Array'
           (Modules.Create_Module (Location, VS => "atmosphere/sky.vert"),
            Modules.Create_Module_From_Sources (FS => Sky_Shader),
            Shader_Module)),
         Module  => Shader_Module,
         Parameters     => Parameters,
         Bottom_Radius  => Data.Bottom_Radius,
         Distance_Scale => 1.0 / Data.Length_Unit_In_Meters,
         others => <>)
      do
         Result.Uniform_Ground_Hack   := Result.Program.Uniform ("ground_hack");
         Result.Uniform_Camera_Offset := Result.Program.Uniform ("camera_offset");

         Result.Uniform_Camera_Pos := Result.Program.Uniform ("camera_pos");
         Result.Uniform_Planet_Pos := Result.Program.Uniform ("planet_pos");

         Result.Uniform_View := Result.Program.Uniform ("view");
         Result.Uniform_Proj := Result.Program.Uniform ("proj");

         Result.Uniform_Sun_Dir  := Result.Program.Uniform ("sun_direction");

         Result.Uniform_Star_Dir  := Result.Program.Uniform ("star_direction");
         Result.Uniform_Star_Size := Result.Program.Uniform ("star_size");
      end return;
   end Create_Atmosphere;

   function Shader_Module (Object : Atmosphere) return Orka.Rendering.Programs.Modules.Module is
     (Object.Module);

   function Flattened_Vector
     (Parameters : Model_Parameters;
      Direction  : Orka.Transforms.Doubles.Vectors.Vector4)
   return Orka.Transforms.Doubles.Vectors.Vector4 is
      Altitude   : constant := 0.0;
      Flattening : GL.Types.Double renames Parameters.Flattening;

      E2 : constant GL.Types.Double := 2.0 * Flattening - Flattening**2;

      N : constant GL.Types.Double := Parameters.Semi_Major_Axis /
        EF.Sqrt (1.0 - E2 * Direction (Orka.Z)**2);
   begin
      return
        (Direction (Orka.X) * (N + Altitude),
         Direction (Orka.Y) * (N + Altitude),
         Direction (Orka.Z) * (N * (1.0 - E2) + Altitude),
         1.0);
   end Flattened_Vector;

   package Matrices renames Orka.Transforms.Doubles.Matrices;

   procedure Render
     (Object : in out Atmosphere;
      Camera : Cameras.Camera_Ptr;
      Planet : Behaviors.Behavior_Ptr;
      Star   : Behaviors.Behavior_Ptr)
   is
      function "*" (Left : Matrices.Matrix4; Right : Matrices.Vector4) return Matrices.Vector4
        renames Matrices."*";

      function "*" (Left, Right : Matrices.Matrix4) return Matrices.Matrix4 renames Matrices."*";

      function Far_Plane (Value : GL.Types.Compare_Function) return GL.Types.Compare_Function is
        (case Value is
           when Less | LEqual     => LEqual,
           when Greater | GEqual  => GEqual,
           when others            => raise Constraint_Error);

      Original_Function : constant GL.Types.Compare_Function := GL.Buffers.Depth_Function;

      use Orka.Transforms.Doubles.Vectors;
      use Orka.Transforms.Doubles.Vector_Conversions;

      use all type Orka.Transforms.Doubles.Vectors.Vector4;

      Planet_To_Camera : constant Vector4 := Camera.View_Position - Planet.Position;
      Planet_To_Star   : constant Vector4 := Star.Position - Planet.Position;
      Camera_To_Star   : constant Vector4 := Star.Position - Camera.View_Position;

      procedure Apply_Hacks is
         GL_To_Geo : constant Matrices.Matrix4 := Matrices.R
           (Matrices.Vectors.Normalize ((1.0, 1.0, 1.0, 0.0)),
            (2.0 / 3.0) * Ada.Numerics.Pi);
         Earth_Tilt : constant Matrices.Matrix4 := Matrices.R
           (Matrices.Vectors.Normalize ((1.0, 0.0, 0.0, 0.0)),
            Object.Parameters.Axial_Tilt);

         Inverse_Inertial    : constant Matrices.Matrix4 := Earth_Tilt * GL_To_Geo;
         Camera_Normal_Inert : constant Vector4 := Normalize (Inverse_Inertial * Planet_To_Camera);

         Actual_Surface   : constant Vector4 := Flattened_Vector
           (Object.Parameters, Camera_Normal_Inert);
         Expected_Surface : constant Vector4 := Camera_Normal_Inert * Object.Bottom_Radius;

         Offset   : constant Vector4 := Expected_Surface - Actual_Surface;
         Altitude : constant Double  := Length (Planet_To_Camera) - Length (Actual_Surface);
      begin
         Object.Uniform_Ground_Hack.Set_Boolean (Altitude < Altitude_Hack_Threshold);
         Object.Uniform_Camera_Offset.Set_Vector (Convert (Offset * Object.Distance_Scale));
      end Apply_Hacks;
   begin
      if Object.Parameters.Flattening > 0.0 then
         Apply_Hacks;
      else
         Object.Uniform_Ground_Hack.Set_Boolean (False);
         Object.Uniform_Camera_Offset.Set_Vector (Orka.Transforms.Singles.Vectors.Zero);
      end if;

      Object.Uniform_Camera_Pos.Set_Vector (Orka.Transforms.Singles.Vectors.Zero);
      Object.Uniform_Planet_Pos.Set_Vector (Convert (-Planet_To_Camera * Object.Distance_Scale));

      Object.Uniform_Sun_Dir.Set_Vector (Convert (Normalize (Planet_To_Star)));
      Object.Uniform_Star_Dir.Set_Vector (Convert (Normalize (Camera_To_Star)));

      --  Use distance to star and its radius instead of the
      --  Sun_Angular_Radius of Model_Data
      declare
         Angular_Radius : constant GL.Types.Double :=
           EF.Arctan (Object.Parameters.Star_Radius, Length (Camera_To_Star));
      begin
         Object.Uniform_Star_Size.Set_Single (GL.Types.Single (EF.Cos (Angular_Radius)));
      end;

      Object.Uniform_View.Set_Matrix (Camera.View_Matrix);
      Object.Uniform_Proj.Set_Matrix (Camera.Projection_Matrix);

      Object.Program.Use_Program;

      GL.Buffers.Set_Depth_Function (Far_Plane (Original_Function));
      Orka.Rendering.Drawing.Draw (GL.Types.Triangles, 0, 3);
      GL.Buffers.Set_Depth_Function (Original_Function);
   end Render;

end Orka.Features.Atmosphere.Rendering;

atmosphere: Fix compilation after changes to orka_transforms

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