-----------------------------------------------------------------------
--  users - Gives access to the OpenID principal through an Ada bean
--  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 ASF.Contexts.Faces;
with ASF.Contexts.Flash;
with ASF.Sessions;
with ASF.Principals;
with ASF.Cookies;
with ASF.Events.Faces.Actions;
with ASF.Applications.Messages.Factory;

with GNAT.MD5;

with Security.Openid;
with ASF.Security.Filters;

with Util.Strings.Transforms;
package body Users is

   use Ada.Strings.Unbounded;
   use Security.Openid;
   use type ASF.Principals.Principal_Access;
   use type ASF.Contexts.Faces.Faces_Context_Access;

   --  ------------------------------
   --  Given an Email address, return the Gravatar link to the user image.
   --  (See http://en.gravatar.com/site/implement/hash/ and
   --  http://en.gravatar.com/site/implement/images/)
   --  ------------------------------
   function Get_Gravatar_Link (Email : in String) return String is
      E : constant String := Util.Strings.Transforms.To_Lower_Case (Email);
      C : constant GNAT.MD5.Message_Digest := GNAT.MD5.Digest (E);
   begin
      return "http://www.gravatar.com/avatar/" & C;
   end Get_Gravatar_Link;

   --  ------------------------------
   --  Get the user information identified by the given name.
   --  ------------------------------
   function Get_Value (From : in User_Info;
                       Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (From);

      F : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      S : ASF.Sessions.Session;
      P : ASF.Principals.Principal_Access := null;
      U : Security.Openid.Principal_Access := null;
   begin
      if F /= null then
         S := F.Get_Session;
         if S.Is_Valid then
            P := S.Get_Principal;
            if P /= null then
               U := Security.Openid.Principal'Class (P.all)'Access;
            end if;
         end if;
      end if;
      if Name = "authenticated" then
         return Util.Beans.Objects.To_Object (U /= null);
      end if;
      if U = null then
         return Util.Beans.Objects.Null_Object;
      end if;
      if Name = "email" then
         return Util.Beans.Objects.To_Object (U.Get_Email);
      end if;
      if Name = "language" then
         return Util.Beans.Objects.To_Object (Get_Language (U.Get_Authentication));
      end if;
      if Name = "first_name" then
         return Util.Beans.Objects.To_Object (Get_First_Name (U.Get_Authentication));
      end if;
      if Name = "last_name" then
         return Util.Beans.Objects.To_Object (Get_Last_Name (U.Get_Authentication));
      end if;
      if Name = "full_name" then
         return Util.Beans.Objects.To_Object (Get_Full_Name (U.Get_Authentication));
      end if;
      if Name = "id" then
         return Util.Beans.Objects.To_Object (Get_Claimed_Id (U.Get_Authentication));
      end if;
      if Name = "country" then
         return Util.Beans.Objects.To_Object (Get_Country (U.Get_Authentication));
      end if;
      if Name = "sessionId" then
         return Util.Beans.Objects.To_Object (S.Get_Id);
      end if;
      if Name = "gravatar" then
         return Util.Beans.Objects.To_Object (Get_Gravatar_Link (U.Get_Email));
      end if;

      return Util.Beans.Objects.To_Object (U.Get_Name);
   end Get_Value;

   --  ------------------------------
   --  Helper to send a remove cookie in the current response
   --  ------------------------------
   procedure Remove_Cookie (Name : in String) is
      Ctx : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      C   : ASF.Cookies.Cookie := ASF.Cookies.Create (Name, "");
   begin
      ASF.Cookies.Set_Path (C, Ctx.Get_Request.Get_Context_Path);
      ASF.Cookies.Set_Max_Age (C, 0);
      Ctx.Get_Response.Add_Cookie (Cookie => C);
   end Remove_Cookie;

   --  ------------------------------
   --  Logout by dropping the user session.
   --  ------------------------------
   procedure Logout (From    : in out User_Info;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (From);

      F : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      S : ASF.Sessions.Session := F.Get_Session;
      P : ASF.Principals.Principal_Access := null;
      U : Security.Openid.Principal_Access := null;
   begin
      if S.Is_Valid then
         P := S.Get_Principal;
         if P /= null then
            U := Security.Openid.Principal'Class (P.all)'Access;
         end if;
         S.Invalidate;
      end if;
      if U /= null then
         F.Get_Flash.Set_Keep_Messages (True);
         ASF.Applications.Messages.Factory.Add_Message (F.all, "samples.openid_logout_message",
                                                        Get_Full_Name (U.Get_Authentication));
      end if;
      Remove_Cookie (ASF.Security.Filters.SID_COOKIE);
      Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("logout_success");
   end Logout;

   package Logout_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => User_Info,
                                                      Method => Logout,
                                                      Name   => "logout");

   Binding_Array : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Logout_Binding.Proxy'Unchecked_Access);

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in User_Info)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Binding_Array'Access;
   end Get_Method_Bindings;

end Users;

-----------------------------------------------------------------------
--  users - Gives access to the OpenID principal through an Ada bean
--  Copyright (C) 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 ASF.Contexts.Faces;
with ASF.Contexts.Flash;
with ASF.Sessions;
with ASF.Principals;
with ASF.Cookies;
with ASF.Events.Faces.Actions;
with ASF.Applications.Messages.Factory;

with GNAT.MD5;

with Security.OpenID;
with ASF.Security.Filters;

with Util.Strings.Transforms;
package body Users is

   use Ada.Strings.Unbounded;
   use Security.OpenID;
   use type ASF.Principals.Principal_Access;
   use type ASF.Contexts.Faces.Faces_Context_Access;

   procedure Remove_Cookie (Name : in String);

   --  ------------------------------
   --  Given an Email address, return the Gravatar link to the user image.
   --  (See http://en.gravatar.com/site/implement/hash/ and
   --  http://en.gravatar.com/site/implement/images/)
   --  ------------------------------
   function Get_Gravatar_Link (Email : in String) return String is
      E : constant String := Util.Strings.Transforms.To_Lower_Case (Email);
      C : constant GNAT.MD5.Message_Digest := GNAT.MD5.Digest (E);
   begin
      return "http://www.gravatar.com/avatar/" & C;
   end Get_Gravatar_Link;

   --  ------------------------------
   --  Get the user information identified by the given name.
   --  ------------------------------
   function Get_Value (From : in User_Info;
                       Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (From);

      F : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      S : ASF.Sessions.Session;
      P : ASF.Principals.Principal_Access := null;
      U : Security.OpenID.Principal_Access := null;
   begin
      if F /= null then
         S := F.Get_Session;
         if S.Is_Valid then
            P := S.Get_Principal;
            if P /= null then
               U := Security.OpenID.Principal'Class (P.all)'Access;
            end if;
         end if;
      end if;
      if Name = "authenticated" then
         return Util.Beans.Objects.To_Object (U /= null);
      end if;
      if U = null then
         return Util.Beans.Objects.Null_Object;
      end if;
      if Name = "email" then
         return Util.Beans.Objects.To_Object (U.Get_Email);
      end if;
      if Name = "language" then
         return Util.Beans.Objects.To_Object (Get_Language (U.Get_Authentication));
      end if;
      if Name = "first_name" then
         return Util.Beans.Objects.To_Object (Get_First_Name (U.Get_Authentication));
      end if;
      if Name = "last_name" then
         return Util.Beans.Objects.To_Object (Get_Last_Name (U.Get_Authentication));
      end if;
      if Name = "full_name" then
         return Util.Beans.Objects.To_Object (Get_Full_Name (U.Get_Authentication));
      end if;
      if Name = "id" then
         return Util.Beans.Objects.To_Object (Get_Claimed_Id (U.Get_Authentication));
      end if;
      if Name = "country" then
         return Util.Beans.Objects.To_Object (Get_Country (U.Get_Authentication));
      end if;
      if Name = "sessionId" then
         return Util.Beans.Objects.To_Object (S.Get_Id);
      end if;
      if Name = "gravatar" then
         return Util.Beans.Objects.To_Object (Get_Gravatar_Link (U.Get_Email));
      end if;

      return Util.Beans.Objects.To_Object (U.Get_Name);
   end Get_Value;

   --  ------------------------------
   --  Helper to send a remove cookie in the current response
   --  ------------------------------
   procedure Remove_Cookie (Name : in String) is
      Ctx : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      C   : ASF.Cookies.Cookie := ASF.Cookies.Create (Name, "");
   begin
      ASF.Cookies.Set_Path (C, Ctx.Get_Request.Get_Context_Path);
      ASF.Cookies.Set_Max_Age (C, 0);
      Ctx.Get_Response.Add_Cookie (Cookie => C);
   end Remove_Cookie;

   --  ------------------------------
   --  Logout by dropping the user session.
   --  ------------------------------
   procedure Logout (From    : in out User_Info;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (From);

      F : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      S : ASF.Sessions.Session := F.Get_Session;
      P : ASF.Principals.Principal_Access := null;
      U : Security.OpenID.Principal_Access := null;
   begin
      if S.Is_Valid then
         P := S.Get_Principal;
         if P /= null then
            U := Security.OpenID.Principal'Class (P.all)'Access;
         end if;
         S.Invalidate;
      end if;
      if U /= null then
         F.Get_Flash.Set_Keep_Messages (True);
         ASF.Applications.Messages.Factory.Add_Message (F.all, "samples.openid_logout_message",
                                                        Get_Full_Name (U.Get_Authentication));
      end if;
      Remove_Cookie (ASF.Security.Filters.SID_COOKIE);
      Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("logout_success");
   end Logout;

   package Logout_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => User_Info,
                                                      Method => Logout,
                                                      Name   => "logout");

   Binding_Array : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Logout_Binding.Proxy'Unchecked_Access);

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in User_Info)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Binding_Array'Access;
   end Get_Method_Bindings;

end Users;

Fix some compilation warnings

Fix some compilation warnings


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2016 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.Numerics.Generic_Elementary_Functions;

package body Orka.Transforms.SIMD_Matrices is

   package EF is new Ada.Numerics.Generic_Elementary_Functions (Element_Type);

   function Diagonal (Elements : Vector_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      for Index in Elements'Range loop
         Result (Index) (Index) := Elements (Index);
      end loop;
      return Result;
   end Diagonal;

   function Main_Diagonal (Matrix : Matrix_Type) return Vector_Type is
     (Matrix (X) (X), Matrix (Y) (Y), Matrix (Z) (Z), Matrix (W) (W));

   function Trace (Matrix : Matrix_Type) return Element_Type is
     (Vectors.Sum (Main_Diagonal (Matrix)));

   function "*" (Left : Vector_Type; Right : Matrix_Type) return Vector_Type is
      Result : Vector_Type;
   begin
      for Column in Right'Range loop
         Result (Column) := Vectors.Dot (Left, Right (Column));
      end loop;

      return Result;
   end "*";

   function Outer (Left, Right : Vector_Type) return Matrix_Type is
      use Vectors;

      Result : Matrix_Type;
   begin
      for Index in Right'Range loop
         Result (Index) := Right (Index) * Left;
      end loop;

      return Result;
   end Outer;

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

   function T (Offset : Vectors.Point) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (W) := Vector_Type (Offset);
      return Result;
   end T;

   function T (Offset : Vector_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (W) := Offset;
      Result (W) (W) := 1.0;
      return Result;
   end T;

   function Rx (Angle : Element_Type) return Matrix_Type is
      CA : constant Element_Type := EF.Cos (Angle);
      SA : constant Element_Type := EF.Sin (Angle);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (Y) := (0.0,  CA, SA, 0.0);
      Result (Z) := (0.0, -SA, CA, 0.0);
      return Result;
   end Rx;

   function Ry (Angle : Element_Type) return Matrix_Type is
      CA : constant Element_Type := EF.Cos (Angle);
      SA : constant Element_Type := EF.Sin (Angle);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) := (CA, 0.0, -SA, 0.0);
      Result (Z) := (SA, 0.0,  CA, 0.0);
      return Result;
   end Ry;

   function Rz (Angle : Element_Type) return Matrix_Type is
      CA : constant Element_Type := EF.Cos (Angle);
      SA : constant Element_Type := EF.Sin (Angle);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) := (CA,  SA, 0.0, 0.0);
      Result (Y) := (-SA, CA, 0.0, 0.0);
      return Result;
   end Rz;

   function R (Axis : Vector_Type; Angle : Element_Type) return Matrix_Type is
      CA : constant Element_Type := EF.Cos (Angle);
      SA : constant Element_Type := EF.Sin (Angle);

      MCA : constant Element_Type := 1.0 - CA;

      MCARXY : constant Element_Type := MCA * Axis (X) * Axis (Y);
      MCARXZ : constant Element_Type := MCA * Axis (X) * Axis (Z);
      MCARYZ : constant Element_Type := MCA * Axis (Y) * Axis (Z);

      RXSA : constant Element_Type := Axis (X) * SA;
      RYSA : constant Element_Type := Axis (Y) * SA;
      RZSA : constant Element_Type := Axis (Z) * SA;

      R11 : constant Element_Type := CA + MCA * Axis (X)**2;
      R12 : constant Element_Type := MCARXY + RZSA;
      R13 : constant Element_Type := MCARXZ - RYSA;

      R21 : constant Element_Type := MCARXY - RZSA;
      R22 : constant Element_Type := CA + MCA * Axis (Y)**2;
      R23 : constant Element_Type := MCARYZ + RXSA;

      R31 : constant Element_Type := MCARXZ + RYSA;
      R32 : constant Element_Type := MCARYZ - RXSA;
      R33 : constant Element_Type := CA + MCA * Axis (Z)**2;

      Result : Matrix_Type;
   begin
      Result (X) := (R11, R12, R13, 0.0);
      Result (Y) := (R21, R22, R23, 0.0);
      Result (Z) := (R31, R32, R33, 0.0);
      Result (W) := (0.0, 0.0, 0.0, 1.0);
      return Result;
   end R;

   function R (Quaternion : Vector_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;

      Q_X : constant Element_Type := Quaternion (X);
      Q_Y : constant Element_Type := Quaternion (Y);
      Q_Z : constant Element_Type := Quaternion (Z);
      Q_W : constant Element_Type := Quaternion (W);

      S : constant := 2.0;
      --  S = 2 / Norm (Quaternion)
   begin
      Result (X) (X) := 1.0 - S * (Q_Y * Q_Y + Q_Z * Q_Z);
      Result (X) (Y) := S * (Q_X * Q_Y - Q_Z * Q_W);
      Result (X) (Z) := S * (Q_X * Q_Z + Q_Y * Q_W);

      Result (Y) (X) := S * (Q_X * Q_Y + Q_Z * Q_W);
      Result (Y) (Y) := 1.0 - S * (Q_X * Q_X + Q_Z * Q_Z);
      Result (Y) (Z) := S * (Q_Y * Q_Z - Q_X * Q_W);

      Result (Z) (X) := S * (Q_X * Q_Z - Q_Y * Q_W);
      Result (Z) (Y) := S * (Q_Y * Q_Z + Q_X * Q_W);
      Result (Z) (Z) := 1.0 - S * (Q_X * Q_X + Q_Y * Q_Y);

      return Result;
   end R;

   function S (Factors : Vector_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := Factors (X);
      Result (Y) (Y) := Factors (Y);
      Result (Z) (Z) := Factors (Z);
      return Result;
   end S;

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

   function FOV (Width, Distance : Element_Type) return Element_Type is
     (2.0 * EF.Arctan (Width  / (2.0 * Distance)));

   function Finite_Perspective (FOV, Aspect, Z_Near, Z_Far : Element_Type) return Matrix_Type is
      F : constant Element_Type := 1.0 / EF.Tan (0.5 * FOV);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := F / Aspect;
      Result (Y) (Y) := F;

      --  Depth normalized to [0, 1] instead of [-1 , 1]
      Result (Z) (Z) := Z_Far / (Z_Near - Z_Far);
      Result (W) (Z) := (Z_Near * Z_Far) / (Z_Near - Z_Far);

      Result (Z) (W) := Element_Type (-1.0);
      Result (W) (W) := Element_Type (0.0);
      return Result;
   end Finite_Perspective;

   function Infinite_Perspective (FOV, Aspect, Z_Near : Element_Type) return Matrix_Type is
      F : constant Element_Type := 1.0 / EF.Tan (0.5 * FOV);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := F / Aspect;
      Result (Y) (Y) := F;

      --  Depth normalized to [0, 1] instead of [-1 , 1]
      Result (Z) (Z) := Element_Type (-1.0);
      Result (W) (Z) := -Z_Near;

      Result (Z) (W) := Element_Type (-1.0);
      Result (W) (W) := Element_Type (0.0);

      return Result;
   end Infinite_Perspective;

   function Infinite_Perspective_Reversed_Z
     (FOV, Aspect, Z_Near : Element_Type) return Matrix_Type
   is
      F : constant Element_Type := 1.0 / EF.Tan (0.5 * FOV);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := F / Aspect;
      Result (Y) (Y) := F;

      --  Depth normalized to [1, 0] instead of [-1 , 1]
      Result (Z) (Z) := Element_Type (0.0);
      Result (W) (Z) := Z_Near;

      Result (Z) (W) := Element_Type (-1.0);
      Result (W) (W) := Element_Type (0.0);

      return Result;
   end Infinite_Perspective_Reversed_Z;

   function Orthographic (X_Mag, Y_Mag, Z_Near, Z_Far : Element_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := 2.0 / X_Mag;
      Result (Y) (Y) := 2.0 / Y_Mag;

      --  Depth normalized to [0, 1] instead of [-1, 1]
      Result (Z) (Z) := -1.0 / (Z_Far - Z_Near);
      Result (W) (Z) := -Z_Near / (Z_Far - Z_Near);

      return Result;
   end Orthographic;

end Orka.Transforms.SIMD_Matrices;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2016 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.Numerics.Generic_Elementary_Functions;

package body Orka.Transforms.SIMD_Matrices is

   package EF is new Ada.Numerics.Generic_Elementary_Functions (Element_Type);

   function Diagonal (Elements : Vector_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      for Index in Elements'Range loop
         Result (Index) (Index) := Elements (Index);
      end loop;
      return Result;
   end Diagonal;

   function Main_Diagonal (Matrix : Matrix_Type) return Vector_Type is
     (Matrix (X) (X), Matrix (Y) (Y), Matrix (Z) (Z), Matrix (W) (W));

   function Trace (Matrix : Matrix_Type) return Element_Type is
     (Vectors.Sum (Main_Diagonal (Matrix)));

   function "*" (Left : Vector_Type; Right : Matrix_Type) return Vector_Type is
      Result : Vector_Type;
   begin
      for Column in Right'Range loop
         Result (Column) := Vectors.Dot (Left, Right (Column));
      end loop;

      return Result;
   end "*";

   function Outer (Left, Right : Vector_Type) return Matrix_Type is
      use Vectors;

      Result : Matrix_Type;
   begin
      for Index in Right'Range loop
         Result (Index) := Right (Index) * Left;
      end loop;

      return Result;
   end Outer;

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

   function T (Offset : Vectors.Point) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (W) := Vector_Type (Offset);
      return Result;
   end T;

   function T (Offset : Vector_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (W) := Offset;
      Result (W) (W) := 1.0;
      return Result;
   end T;

   function Rx (Angle : Element_Type) return Matrix_Type is
      CA : constant Element_Type := EF.Cos (Angle);
      SA : constant Element_Type := EF.Sin (Angle);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (Y) := (0.0,  CA, SA, 0.0);
      Result (Z) := (0.0, -SA, CA, 0.0);
      return Result;
   end Rx;

   function Ry (Angle : Element_Type) return Matrix_Type is
      CA : constant Element_Type := EF.Cos (Angle);
      SA : constant Element_Type := EF.Sin (Angle);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) := (CA, 0.0, -SA, 0.0);
      Result (Z) := (SA, 0.0,  CA, 0.0);
      return Result;
   end Ry;

   function Rz (Angle : Element_Type) return Matrix_Type is
      CA : constant Element_Type := EF.Cos (Angle);
      SA : constant Element_Type := EF.Sin (Angle);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) := (CA,  SA, 0.0, 0.0);
      Result (Y) := (-SA, CA, 0.0, 0.0);
      return Result;
   end Rz;

   function R (Axis : Vector_Type; Angle : Element_Type) return Matrix_Type is
      CA : constant Element_Type := EF.Cos (Angle);
      SA : constant Element_Type := EF.Sin (Angle);

      MCA : constant Element_Type := 1.0 - CA;

      MCARXY : constant Element_Type := MCA * Axis (X) * Axis (Y);
      MCARXZ : constant Element_Type := MCA * Axis (X) * Axis (Z);
      MCARYZ : constant Element_Type := MCA * Axis (Y) * Axis (Z);

      RXSA : constant Element_Type := Axis (X) * SA;
      RYSA : constant Element_Type := Axis (Y) * SA;
      RZSA : constant Element_Type := Axis (Z) * SA;

      R11 : constant Element_Type := CA + MCA * Axis (X)**2;
      R12 : constant Element_Type := MCARXY + RZSA;
      R13 : constant Element_Type := MCARXZ - RYSA;

      R21 : constant Element_Type := MCARXY - RZSA;
      R22 : constant Element_Type := CA + MCA * Axis (Y)**2;
      R23 : constant Element_Type := MCARYZ + RXSA;

      R31 : constant Element_Type := MCARXZ + RYSA;
      R32 : constant Element_Type := MCARYZ - RXSA;
      R33 : constant Element_Type := CA + MCA * Axis (Z)**2;

      Result : Matrix_Type;
   begin
      Result (X) := (R11, R12, R13, 0.0);
      Result (Y) := (R21, R22, R23, 0.0);
      Result (Z) := (R31, R32, R33, 0.0);
      Result (W) := (0.0, 0.0, 0.0, 1.0);
      return Result;
   end R;

   function R (Quaternion : Vector_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;

      Q_X : constant Element_Type := Quaternion (X);
      Q_Y : constant Element_Type := Quaternion (Y);
      Q_Z : constant Element_Type := Quaternion (Z);
      Q_W : constant Element_Type := Quaternion (W);

      S : constant := 2.0;
      --  S = 2 / Norm (Quaternion)
   begin
      Result (X) (X) := 1.0 - S * (Q_Y * Q_Y + Q_Z * Q_Z);
      Result (X) (Y) := S * (Q_X * Q_Y + Q_Z * Q_W);
      Result (X) (Z) := S * (Q_X * Q_Z - Q_Y * Q_W);

      Result (Y) (X) := S * (Q_X * Q_Y - Q_Z * Q_W);
      Result (Y) (Y) := 1.0 - S * (Q_X * Q_X + Q_Z * Q_Z);
      Result (Y) (Z) := S * (Q_Y * Q_Z + Q_X * Q_W);

      Result (Z) (X) := S * (Q_X * Q_Z + Q_Y * Q_W);
      Result (Z) (Y) := S * (Q_Y * Q_Z - Q_X * Q_W);
      Result (Z) (Z) := 1.0 - S * (Q_X * Q_X + Q_Y * Q_Y);

      return Result;
   end R;

   function S (Factors : Vector_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := Factors (X);
      Result (Y) (Y) := Factors (Y);
      Result (Z) (Z) := Factors (Z);
      return Result;
   end S;

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

   function FOV (Width, Distance : Element_Type) return Element_Type is
     (2.0 * EF.Arctan (Width  / (2.0 * Distance)));

   function Finite_Perspective (FOV, Aspect, Z_Near, Z_Far : Element_Type) return Matrix_Type is
      F : constant Element_Type := 1.0 / EF.Tan (0.5 * FOV);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := F / Aspect;
      Result (Y) (Y) := F;

      --  Depth normalized to [0, 1] instead of [-1 , 1]
      Result (Z) (Z) := Z_Far / (Z_Near - Z_Far);
      Result (W) (Z) := (Z_Near * Z_Far) / (Z_Near - Z_Far);

      Result (Z) (W) := Element_Type (-1.0);
      Result (W) (W) := Element_Type (0.0);
      return Result;
   end Finite_Perspective;

   function Infinite_Perspective (FOV, Aspect, Z_Near : Element_Type) return Matrix_Type is
      F : constant Element_Type := 1.0 / EF.Tan (0.5 * FOV);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := F / Aspect;
      Result (Y) (Y) := F;

      --  Depth normalized to [0, 1] instead of [-1 , 1]
      Result (Z) (Z) := Element_Type (-1.0);
      Result (W) (Z) := -Z_Near;

      Result (Z) (W) := Element_Type (-1.0);
      Result (W) (W) := Element_Type (0.0);

      return Result;
   end Infinite_Perspective;

   function Infinite_Perspective_Reversed_Z
     (FOV, Aspect, Z_Near : Element_Type) return Matrix_Type
   is
      F : constant Element_Type := 1.0 / EF.Tan (0.5 * FOV);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := F / Aspect;
      Result (Y) (Y) := F;

      --  Depth normalized to [1, 0] instead of [-1 , 1]
      Result (Z) (Z) := Element_Type (0.0);
      Result (W) (Z) := Z_Near;

      Result (Z) (W) := Element_Type (-1.0);
      Result (W) (W) := Element_Type (0.0);

      return Result;
   end Infinite_Perspective_Reversed_Z;

   function Orthographic (X_Mag, Y_Mag, Z_Near, Z_Far : Element_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := 2.0 / X_Mag;
      Result (Y) (Y) := 2.0 / Y_Mag;

      --  Depth normalized to [0, 1] instead of [-1, 1]
      Result (Z) (Z) := -1.0 / (Z_Far - Z_Near);
      Result (W) (Z) := -Z_Near / (Z_Far - Z_Near);

      return Result;
   end Orthographic;

end Orka.Transforms.SIMD_Matrices;

Fix positions of elements in function R

transforms: Fix positions of elements in function R

The type Matrix_Type uses column-major order. Fix the positions so that
it is equal to Equation 4.42 from chapter 4.3 Quaternions from [1].

[1] "Real-Time Rendering" (third edition, 2008)

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


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

with Util.Test_Caller;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Tests;
with AWA.Tests.Helpers.Users;

package body AWA.Blogs.Tests is

   use Ada.Strings.Unbounded;
   use AWA.Tests;

   package Caller is new Util.Test_Caller (Test, "Blogs.Beans");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Blogs.Beans.List_Post (Anonymous)",
                       Test_Anonymous_Access'Access);
      Caller.Add_Test (Suite, "Test AWA.Blogs.Beans.Create_Blog",
                       Test_Create_Blog'Access);
      Caller.Add_Test (Suite, "Test AWA.Blogs.Beans.Update_Post",
                       Test_Update_Post'Access);
      Caller.Add_Test (Suite, "Test AWA.Blogs.Beans.List_Post (Admin)",
                       Test_Admin_List_Posts'Access);
      Caller.Add_Test (Suite, "Test AWA.Blogs.Beans.List_Comments (Admin)",
                       Test_Admin_List_Comments'Access);
      Caller.Add_Test (Suite, "Test AWA.Blogs.Beans.Stats (Admin)",
                       Test_Admin_Blog_Stats'Access);
      Caller.Add_Test (Suite, "Test AWA.Blogs.Beans.Update_Post (Publish_Date)",
                       Test_Update_Publish_Date'Access);
   end Add_Tests;

   --  ------------------------------
   --  Get some access on the blog as anonymous users.
   --  ------------------------------
   procedure Verify_Anonymous (T    : in out Test;
                               Post : in String) is
      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
   begin
      ASF.Tests.Do_Get (Request, Reply, "/blogs/view.html", "blog-view.html");
      ASF.Tests.Assert_Contains (T, "Blog posts", Reply, "Blog view page is invalid");

      ASF.Tests.Do_Get (Request, Reply, "/blogs/tagged.html?tag=test", "blog-tagged.html");
      ASF.Tests.Assert_Contains (T, "Tag - test", Reply, "Blog tag page is invalid");

      ASF.Tests.Do_Get (Request, Reply, "/blogs/post.html?post=missing", "blog-missing.html");
      ASF.Tests.Assert_Matches (T, "The post you are looking for does not exist",
                                Reply, "Blog post missing page is invalid",
                                ASF.Responses.SC_NOT_FOUND);

      if Post = "" then
         return;
      end if;

      ASF.Tests.Do_Get (Request, Reply, "/blogs/post.html?post=" & Post, "blog-post.html");
      ASF.Tests.Assert_Matches (T, ".*The blog post.*content.*", Reply,
                                "Blog post page is invalid"
                                );

   end Verify_Anonymous;

   --  ------------------------------
   --  Test access to the blog as anonymous user.
   --  ------------------------------
   procedure Test_Anonymous_Access (T : in out Test) is
   begin
      T.Verify_Anonymous ("");
   end Test_Anonymous_Access;

   --  ------------------------------
   --  Test creation of blog by simulating web requests.
   --  ------------------------------
   procedure Test_Create_Blog (T : in out Test) is
      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Uuid      : constant String := Util.Tests.Get_Uuid;
   begin
      AWA.Tests.Helpers.Users.Login ("test-wiki@test.com", Request);
      Request.Set_Parameter ("title", "The Blog Title");
      Request.Set_Parameter ("create-blog", "1");
      Request.Set_Parameter ("create", "1");
      ASF.Tests.Do_Post (Request, Reply, "/blogs/admin/create-blog.html", "create-blog.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY,
                "Invalid response after blog creation");
      declare
         Ident : constant String
            := Helpers.Extract_Redirect (Reply, "/asfunit/blogs/admin/create.html?id=");
      begin
         Util.Tests.Assert_Matches (T, "^[0-9]+$", Ident,
                                    "Invalid blog identifier in the response");
         T.Blog_Ident := To_Unbounded_String (Ident);

         Request.Set_Parameter ("post-blog-id", Ident);
         Request.Set_Parameter ("post", "1");
         Request.Set_Parameter ("post-title", "Post title");
         Request.Set_Parameter ("text", "The blog post content.");
         Request.Set_Parameter ("uri", Uuid);
         Request.Set_Parameter ("save", "1");
         Request.Set_Parameter ("post-status", "1");
         Request.Set_Parameter ("allow-comment", "0");
         Request.Set_Parameter ("post-format", "dotclear");
         ASF.Tests.Do_Post (Request, Reply, "/blogs/admin/create.html", "create-post.html");

         T.Post_Ident := Helpers.Extract_Redirect (Reply, "/asfunit/blogs/admin/"
                                                   & Ident & "/preview/");

         Util.Tests.Assert_Matches (T, "^[0-9]+$", To_String (T.Post_Ident),
                                    "Invalid post identifier in the response");
      end;

      --  Check public access to the post.
      T.Post_Uri := To_Unbounded_String (Uuid);
      T.Verify_Anonymous (Uuid);
   end Test_Create_Blog;

   --  ------------------------------
   --  Test updating a post by simulating web requests.
   --  ------------------------------
   procedure Test_Update_Post (T : in out Test) is
      Request    : ASF.Requests.Mockup.Request;
      Reply      : ASF.Responses.Mockup.Response;
      Uuid       : constant String := Util.Tests.Get_Uuid;
      Ident      : constant String := To_String (T.Blog_Ident);
      Post_Ident : Unbounded_String;
   begin
      AWA.Tests.Helpers.Users.Login ("test-wiki@test.com", Request);

      Request.Set_Parameter ("post-blog-id", Ident);
      Request.Set_Parameter ("post-id", To_String (T.Post_Ident));
      Request.Set_Parameter ("post", "1");
      Request.Set_Parameter ("post-title", "New post title");
      Request.Set_Parameter ("text", "The blog post new content.");
      Request.Set_Parameter ("uri", Uuid);
      Request.Set_Parameter ("save", "1");
      Request.Set_Parameter ("post-status", "POST_PUBLISHED");
      Request.Set_Parameter ("post-format", "dotclear");
      Request.Set_Parameter ("allow-comment", "0");
      ASF.Tests.Do_Post (Request, Reply, "/blogs/admin/edit.html", "edit-post.html");

      Post_Ident := Helpers.Extract_Redirect (Reply, "/asfunit/blogs/admin/"
                                              & Ident & "/preview/");

      Util.Tests.Assert_Equals (T, To_String (T.Post_Ident), To_String (Post_Ident),
                                "Invalid post identifier returned after post update");
      T.Verify_Anonymous (Uuid);
   end Test_Update_Post;

   --  ------------------------------
   --  Test updating the publication date by simulating web requests.
   --  ------------------------------
   procedure Test_Update_Publish_Date (T : in out Test) is
      Request    : ASF.Requests.Mockup.Request;
      Reply      : ASF.Responses.Mockup.Response;
      Uuid       : constant String := Util.Tests.Get_Uuid;
      Ident      : constant String := To_String (T.Blog_Ident);
      Post_Ident : Unbounded_String;
   begin
      AWA.Tests.Helpers.Users.Login ("test-wiki@test.com", Request);
      Request.Set_Parameter ("post_id", To_String (T.Post_Ident));
      Request.Set_Parameter ("blog_id", Ident);
      ASF.Tests.Do_Get (Request, Reply, "/blogs/admin/edit.html", "edit-post-form.html");

      Request.Set_Parameter ("post-blog-id", Ident);
      Request.Set_Parameter ("post-id", To_String (T.Post_Ident));
      Request.Set_Parameter ("post", "1");
      Request.Set_Parameter ("post-title", "New post title");
      Request.Set_Parameter ("text", "The blog post new content.");
      Request.Set_Parameter ("uri", Uuid);
      Request.Set_Parameter ("save", "POST_PUBLISHED");
      Request.Set_Parameter ("format", "dotclear");
      Request.Set_Parameter ("post-status", "1");
      Request.Set_Parameter ("allow-comment", "0");
      Request.Set_Parameter ("publish-date", "");
      ASF.Tests.Do_Post (Request, Reply, "/blogs/admin/edit.html", "edit-post.html");

      Post_Ident := Helpers.Extract_Redirect (Reply, "/asfunit/blogs/admin/"
                                              & Ident & "/preview/");

      Util.Tests.Assert_Equals (T, To_String (T.Post_Ident), To_String (Post_Ident),
                                "Invalid post identifier returned after post update");
      T.Verify_Anonymous (Uuid);
   end Test_Update_Publish_Date;

   --  ------------------------------
   --  Test listing the blog posts.
   --  ------------------------------
   procedure Test_Admin_List_Posts (T : in out Test) is
      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
      Ident   : constant String := To_String (T.Blog_Ident);
   begin
      AWA.Tests.Helpers.Users.Login ("test-wiki@test.com", Request);
      ASF.Tests.Do_Get (Request, Reply, "/blogs/admin/list.html?id=" & Ident, "blog-list.html");
      ASF.Tests.Assert_Contains (T, "blog-post-list-header", Reply, "Blog admin page is invalid");
   end Test_Admin_List_Posts;

   --  ------------------------------
   --  Test listing the blog comments.
   --  ------------------------------
   procedure Test_Admin_List_Comments (T : in out Test) is
      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
      Ident   : constant String := To_String (T.Blog_Ident);
   begin
      AWA.Tests.Helpers.Users.Login ("test-wiki@test.com", Request);
      ASF.Tests.Do_Get (Request, Reply, "/blogs/admin/list-comments.html?id=" & Ident,
                        "blog-list-comments.html");
      ASF.Tests.Assert_Contains (T, "blog-comment-list-header", Reply,
                                 "Blog admin comments page is invalid");
   end Test_Admin_List_Comments;

   --  ------------------------------
   --  Test getting the JSON blog stats (for graphs).
   --  ------------------------------
   procedure Test_Admin_Blog_Stats (T : in out Test) is
      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
      Ident   : constant String := To_String (T.Blog_Ident);
   begin
      AWA.Tests.Helpers.Users.Login ("test-wiki@test.com", Request);
      ASF.Tests.Do_Get (Request, Reply, "/blogs/admin/" & Ident & "/stats",
                        "blog-stats.html");
      ASF.Tests.Assert_Contains (T, "data", Reply,
                                 "Blog admin stats page is invalid");
   end Test_Admin_Blog_Stats;

end AWA.Blogs.Tests;

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

with Util.Test_Caller;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Tests;
with AWA.Tests.Helpers.Users;

package body AWA.Blogs.Tests is

   use Ada.Strings.Unbounded;
   use AWA.Tests;

   package Caller is new Util.Test_Caller (Test, "Blogs.Beans");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Blogs.Beans.List_Post (Anonymous)",
                       Test_Anonymous_Access'Access);
      Caller.Add_Test (Suite, "Test AWA.Blogs.Beans.Create_Blog",
                       Test_Create_Blog'Access);
      Caller.Add_Test (Suite, "Test AWA.Blogs.Beans.Update_Post",
                       Test_Update_Post'Access);
      Caller.Add_Test (Suite, "Test AWA.Blogs.Beans.List_Post (Admin)",
                       Test_Admin_List_Posts'Access);
      Caller.Add_Test (Suite, "Test AWA.Blogs.Beans.List_Comments (Admin)",
                       Test_Admin_List_Comments'Access);
      Caller.Add_Test (Suite, "Test AWA.Blogs.Beans.Stats (Admin)",
                       Test_Admin_Blog_Stats'Access);
      Caller.Add_Test (Suite, "Test AWA.Blogs.Beans.Update_Post (Publish_Date)",
                       Test_Update_Publish_Date'Access);
   end Add_Tests;

   --  ------------------------------
   --  Get some access on the blog as anonymous users.
   --  ------------------------------
   procedure Verify_Anonymous (T    : in out Test;
                               Post : in String) is
      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
   begin
      ASF.Tests.Do_Get (Request, Reply, "/blogs/view.html", "blog-view.html");
      ASF.Tests.Assert_Contains (T, "Blog posts", Reply, "Blog view page is invalid");

      ASF.Tests.Do_Get (Request, Reply, "/blogs/tagged.html?tag=test", "blog-tagged.html");
      ASF.Tests.Assert_Contains (T, "Tag - test", Reply, "Blog tag page is invalid");

      ASF.Tests.Do_Get (Request, Reply, "/blogs/post.html?post=missing", "blog-missing.html");
      ASF.Tests.Assert_Matches (T, "The post you are looking for does not exist",
                                Reply, "Blog post missing page is invalid",
                                ASF.Responses.SC_NOT_FOUND);

      if Post = "" then
         return;
      end if;

      ASF.Tests.Do_Get (Request, Reply, "/blogs/post.html?post=" & Post, "blog-post.html");
      ASF.Tests.Assert_Matches (T, ".*The blog post.*content.*", Reply,
                                "Blog post page is invalid"
                                );

   end Verify_Anonymous;

   --  ------------------------------
   --  Test access to the blog as anonymous user.
   --  ------------------------------
   procedure Test_Anonymous_Access (T : in out Test) is
   begin
      T.Verify_Anonymous ("");
   end Test_Anonymous_Access;

   --  ------------------------------
   --  Test creation of blog by simulating web requests.
   --  ------------------------------
   procedure Test_Create_Blog (T : in out Test) is
      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Uuid      : constant String := Util.Tests.Get_Uuid;
   begin
      AWA.Tests.Helpers.Users.Login ("test-wiki@test.com", Request);
      Request.Set_Parameter ("title", "The Blog Title");
      Request.Set_Parameter ("create-blog", "1");
      Request.Set_Parameter ("create", "1");
      ASF.Tests.Do_Post (Request, Reply, "/blogs/admin/create-blog.html", "create-blog.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY,
                "Invalid response after blog creation");
      declare
         Ident : constant String
            := Helpers.Extract_Redirect (Reply, "/asfunit/blogs/admin/create.html?id=");
      begin
         Util.Tests.Assert_Matches (T, "^[0-9]+$", Ident,
                                    "Invalid blog identifier in the response");
         T.Blog_Ident := To_Unbounded_String (Ident);

         Request.Set_Parameter ("post-blog-id", Ident);
         Request.Set_Parameter ("post", "1");
         Request.Set_Parameter ("post-title", "Post title");
         Request.Set_Parameter ("text", "The blog post content.");
         Request.Set_Parameter ("uri", Uuid);
         Request.Set_Parameter ("save", "1");
         Request.Set_Parameter ("post-status", "1");
         Request.Set_Parameter ("allow-comment", "0");
         Request.Set_Parameter ("post-format", "dotclear");
         ASF.Tests.Do_Post (Request, Reply, "/blogs/admin/create.html", "create-post.html");

         T.Post_Ident := Helpers.Extract_Redirect (Reply, "/asfunit/blogs/admin/"
                                                   & Ident & "/preview/");

         Util.Tests.Assert_Matches (T, "^[0-9]+$", To_String (T.Post_Ident),
                                    "Invalid post identifier in the response");
      end;

      --  Check public access to the post.
      T.Post_Uri := To_Unbounded_String (Uuid);
      T.Verify_Anonymous (Uuid);
   end Test_Create_Blog;

   --  ------------------------------
   --  Test updating a post by simulating web requests.
   --  ------------------------------
   procedure Test_Update_Post (T : in out Test) is
      Request    : ASF.Requests.Mockup.Request;
      Reply      : ASF.Responses.Mockup.Response;
      Uuid       : constant String := Util.Tests.Get_Uuid;
      Ident      : constant String := To_String (T.Blog_Ident);
      Post_Ident : Unbounded_String;
   begin
      AWA.Tests.Helpers.Users.Login ("test-wiki@test.com", Request);

      Request.Set_Parameter ("post-blog-id", Ident);
      Request.Set_Parameter ("post-id", To_String (T.Post_Ident));
      Request.Set_Parameter ("post", "1");
      Request.Set_Parameter ("post-title", "New post title");
      Request.Set_Parameter ("text", "The blog post new content.");
      Request.Set_Parameter ("uri", Uuid);
      Request.Set_Parameter ("save", "1");
      Request.Set_Parameter ("post-status", "POST_PUBLISHED");
      Request.Set_Parameter ("post-format", "dotclear");
      Request.Set_Parameter ("allow-comment", "0");
      ASF.Tests.Do_Post (Request, Reply, "/blogs/admin/edit.html", "edit-post.html");

      Post_Ident := Helpers.Extract_Redirect (Reply, "/asfunit/blogs/admin/"
                                              & Ident & "/preview/");

      Util.Tests.Assert_Equals (T, To_String (T.Post_Ident), To_String (Post_Ident),
                                "Invalid post identifier returned after post update");
      T.Verify_Anonymous (Uuid);
   end Test_Update_Post;

   --  ------------------------------
   --  Test updating the publication date by simulating web requests.
   --  ------------------------------
   procedure Test_Update_Publish_Date (T : in out Test) is
      Request    : ASF.Requests.Mockup.Request;
      Reply      : ASF.Responses.Mockup.Response;
      Uuid       : constant String := Util.Tests.Get_Uuid;
      Ident      : constant String := To_String (T.Blog_Ident);
      Post_Ident : Unbounded_String;
   begin
      AWA.Tests.Helpers.Users.Login ("test-wiki@test.com", Request);
      Request.Set_Parameter ("post_id", To_String (T.Post_Ident));
      Request.Set_Parameter ("blog_id", Ident);
      ASF.Tests.Do_Get (Request, Reply, "/blogs/admin/edit.html", "edit-post-form.html");

      Request.Set_Parameter ("post-blog-id", Ident);
      Request.Set_Parameter ("post-id", To_String (T.Post_Ident));
      Request.Set_Parameter ("post", "1");
      Request.Set_Parameter ("post-title", "New post title");
      Request.Set_Parameter ("text", "The blog post new content.");
      Request.Set_Parameter ("uri", Uuid);
      Request.Set_Parameter ("save", "POST_PUBLISHED");
      Request.Set_Parameter ("post-format", "dotclear");
      Request.Set_Parameter ("post-status", "1");
      Request.Set_Parameter ("allow-comment", "0");
      Request.Set_Parameter ("publish-date", "");
      ASF.Tests.Do_Post (Request, Reply, "/blogs/admin/edit.html", "edit-post.html");

      Post_Ident := Helpers.Extract_Redirect (Reply, "/asfunit/blogs/admin/"
                                              & Ident & "/preview/");

      Util.Tests.Assert_Equals (T, To_String (T.Post_Ident), To_String (Post_Ident),
                                "Invalid post identifier returned after post update");
      T.Verify_Anonymous (Uuid);
   end Test_Update_Publish_Date;

   --  ------------------------------
   --  Test listing the blog posts.
   --  ------------------------------
   procedure Test_Admin_List_Posts (T : in out Test) is
      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
      Ident   : constant String := To_String (T.Blog_Ident);
   begin
      AWA.Tests.Helpers.Users.Login ("test-wiki@test.com", Request);
      ASF.Tests.Do_Get (Request, Reply, "/blogs/admin/list.html?id=" & Ident, "blog-list.html");
      ASF.Tests.Assert_Contains (T, "blog-post-list-header", Reply, "Blog admin page is invalid");
   end Test_Admin_List_Posts;

   --  ------------------------------
   --  Test listing the blog comments.
   --  ------------------------------
   procedure Test_Admin_List_Comments (T : in out Test) is
      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
      Ident   : constant String := To_String (T.Blog_Ident);
   begin
      AWA.Tests.Helpers.Users.Login ("test-wiki@test.com", Request);
      ASF.Tests.Do_Get (Request, Reply, "/blogs/admin/list-comments.html?id=" & Ident,
                        "blog-list-comments.html");
      ASF.Tests.Assert_Contains (T, "blog-comment-list-header", Reply,
                                 "Blog admin comments page is invalid");
   end Test_Admin_List_Comments;

   --  ------------------------------
   --  Test getting the JSON blog stats (for graphs).
   --  ------------------------------
   procedure Test_Admin_Blog_Stats (T : in out Test) is
      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
      Ident   : constant String := To_String (T.Blog_Ident);
   begin
      AWA.Tests.Helpers.Users.Login ("test-wiki@test.com", Request);
      ASF.Tests.Do_Get (Request, Reply, "/blogs/admin/" & Ident & "/stats",
                        "blog-stats.html");
      ASF.Tests.Assert_Contains (T, "data", Reply,
                                 "Blog admin stats page is invalid");
   end Test_Admin_Blog_Stats;

end AWA.Blogs.Tests;

Fix name of format parameter for the unit test


-----------------------------------------------------------------------
--  awa-comments-beans -- Beans for the comments module
--  Copyright (C) 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with ADO.Sessions.Entities;
with ADO.Queries;
with ADO.Utils;
with AWA.Helpers.Requests;
package body AWA.Comments.Beans is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Comment_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Comments.Models.Comment_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Comment_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "message" then
         From.Set_Message (Util.Beans.Objects.To_String (Value));

      elsif Name = "entity_type" then
         From.Entity_Type := Util.Beans.Objects.To_Unbounded_String (Value);

      elsif Name = "entity_id" then
         declare
            use type ADO.Identifier;

            Id : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            if Id /= ADO.NO_IDENTIFIER then
               From.Set_Entity_Id (ADO.Utils.To_Identifier (Value));
            end if;
         end;

      elsif Name = "permission" then
         From.Permission := Util.Beans.Objects.To_Unbounded_String (Value);

      elsif Name = "status" then
         From.Set_Status (AWA.Comments.Models.Status_Type_Objects.To_Value (Value));

      elsif Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            Id  : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            From.Module.Load_Comment (From, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the comment.
   --  ------------------------------
   overriding
   procedure Create (Bean    : in out Comment_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Module.Create_Comment (Permission  => To_String (Bean.Permission),
                                  Entity_Type => To_String (Bean.Entity_Type),
                                  Comment     => Bean);
   end Create;

   --  Save the comment.
   overriding
   procedure Save (Bean    : in out Comment_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Save;

   --  ------------------------------
   --  Publish or not the comment.
   --  ------------------------------
   overriding
   procedure Publish (Bean    : in out Comment_Bean;
                      Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);

      Id     : constant ADO.Identifier := Helpers.Requests.Get_Parameter ("id");
      Value  : constant Util.Beans.Objects.Object := Helpers.Requests.Get_Parameter ("status");
   begin
      Bean.Module.Publish_Comment (Permission  => To_String (Bean.Permission),
                                   Id          => Id,
                                   Status      => Models.Status_Type_Objects.To_Value (Value),
                                   Comment     => Bean);
   end Publish;

   --  ------------------------------
   --  Delete the comment.
   --  ------------------------------
   overriding
   procedure Delete (Bean    : in out Comment_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Module.Delete_Comment (Ada.Strings.Unbounded.To_String (Bean.Permission), Bean);
   end Delete;

   --  ------------------------------
   --  Create a new comment bean instance.
   --  ------------------------------
   function Create_Comment_Bean (Module : in AWA.Comments.Modules.Comment_Module_Access)
                                 return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Comment_Bean_Access := new Comment_Bean;
   begin
      Result.Module := Module;
      return Result.all'Access;
   end Create_Comment_Bean;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Comment_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "entity_type" then
         From.Entity_Type := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "permission" then
         From.Permission := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "entity_id" then
         From.Load_Comments (ADO.Utils.To_Identifier (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Set the entity type (database table) with which the comments are associated.
   --  ------------------------------
   procedure Set_Entity_Type (Into  : in out Comment_List_Bean;
                              Table : in ADO.Schemas.Class_Mapping_Access) is
   begin
      Into.Entity_Type := Ada.Strings.Unbounded.To_Unbounded_String (Table.Table.all);
   end Set_Entity_Type;

   --  ------------------------------
   --  Set the permission to check before removing or adding a comment on the entity.
   --  ------------------------------
   procedure Set_Permission (Into       : in out Comment_List_Bean;
                             Permission : in String) is
   begin
      Into.Permission := Ada.Strings.Unbounded.To_Unbounded_String (Permission);
   end Set_Permission;

   --  ------------------------------
   --  Load the comments associated with the given database identifier.
   --  ------------------------------
   procedure Load_Comments (Into          : in out Comment_List_Bean;
                            For_Entity_Id : in ADO.Identifier) is
      Session : ADO.Sessions.Session := Into.Module.Get_Session;
   begin
      Into.Load_Comments (Session, For_Entity_Id);
   end Load_Comments;

   --  ------------------------------
   --  Load the comments associated with the given database identifier.
   --  ------------------------------
   procedure Load_Comments (Into          : in out Comment_List_Bean;
                            Session       : in out ADO.Sessions.Session;
                            For_Entity_Id : in ADO.Identifier) is
      use ADO.Sessions.Entities;

      Entity_Type : constant String := Ada.Strings.Unbounded.To_String (Into.Entity_Type);
      Kind        : constant ADO.Entity_Type := Find_Entity_Type (Session, Entity_Type);
      Query       : ADO.Queries.Context;
   begin
      Into.Entity_Id := For_Entity_Id;
      Query.Set_Query (AWA.Comments.Models.Query_Comment_List);
      Query.Bind_Param ("entity_type", Kind);
      Query.Bind_Param ("entity_id", For_Entity_Id);
      Query.Bind_Param ("status", Integer (Models.Status_Type'Pos (Models.COMMENT_PUBLISHED)));
      AWA.Comments.Models.List (Into, Session, Query);
   end Load_Comments;

   --  ------------------------------
   --  Create the comment list bean instance.
   --  ------------------------------
   function Create_Comment_List_Bean (Module : in AWA.Comments.Modules.Comment_Module_Access)
                                      return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Comment_List_Bean_Access := new Comment_List_Bean;
   begin
      Result.Module := Module;
      return Result.all'Access;
   end Create_Comment_List_Bean;

end AWA.Comments.Beans;

-----------------------------------------------------------------------
--  awa-comments-beans -- Beans for the comments module
--  Copyright (C) 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with ADO.Sessions.Entities;
with ADO.Queries;
with ADO.Utils;
with AWA.Helpers.Requests;
package body AWA.Comments.Beans is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Comment_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Comments.Models.Comment_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Comment_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "message" then
         From.Set_Message (Util.Beans.Objects.To_String (Value));

      elsif Name = "entity_type" then
         From.Entity_Type := Util.Beans.Objects.To_Unbounded_String (Value);

      elsif Name = "entity_id" then
         declare
            use type ADO.Identifier;

            Id : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            if Id /= ADO.NO_IDENTIFIER then
               From.Set_Entity_Id (ADO.Utils.To_Identifier (Value));
            end if;
         end;

      elsif Name = "permission" then
         From.Permission := Util.Beans.Objects.To_Unbounded_String (Value);

      elsif Name = "status" then
         From.Set_Status (AWA.Comments.Models.Status_Type_Objects.To_Value (Value));

      elsif Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            Id  : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            From.Module.Load_Comment (From, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the comment.
   --  ------------------------------
   overriding
   procedure Create (Bean    : in out Comment_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Module.Create_Comment (Permission  => To_String (Bean.Permission),
                                  Entity_Type => To_String (Bean.Entity_Type),
                                  Comment     => Bean);
   end Create;

   --  ------------------------------
   --  Save the comment.
   --  ------------------------------
   overriding
   procedure Save (Bean    : in out Comment_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Module.Update_Comment (Permission  => To_String (Bean.Permission),
                                  Comment     => Bean);
   end Save;

   --  ------------------------------
   --  Publish or not the comment.
   --  ------------------------------
   overriding
   procedure Publish (Bean    : in out Comment_Bean;
                      Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);

      Id     : constant ADO.Identifier := Helpers.Requests.Get_Parameter ("id");
      Value  : constant Util.Beans.Objects.Object := Helpers.Requests.Get_Parameter ("status");
   begin
      Bean.Module.Publish_Comment (Permission  => To_String (Bean.Permission),
                                   Id          => Id,
                                   Status      => Models.Status_Type_Objects.To_Value (Value),
                                   Comment     => Bean);
   end Publish;

   --  ------------------------------
   --  Delete the comment.
   --  ------------------------------
   overriding
   procedure Delete (Bean    : in out Comment_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Module.Delete_Comment (Ada.Strings.Unbounded.To_String (Bean.Permission), Bean);
   end Delete;

   --  ------------------------------
   --  Create a new comment bean instance.
   --  ------------------------------
   function Create_Comment_Bean (Module : in AWA.Comments.Modules.Comment_Module_Access)
                                 return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Comment_Bean_Access := new Comment_Bean;
   begin
      Result.Module := Module;
      return Result.all'Access;
   end Create_Comment_Bean;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Comment_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "entity_type" then
         From.Entity_Type := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "permission" then
         From.Permission := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "entity_id" then
         From.Load_Comments (ADO.Utils.To_Identifier (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Set the entity type (database table) with which the comments are associated.
   --  ------------------------------
   procedure Set_Entity_Type (Into  : in out Comment_List_Bean;
                              Table : in ADO.Schemas.Class_Mapping_Access) is
   begin
      Into.Entity_Type := Ada.Strings.Unbounded.To_Unbounded_String (Table.Table.all);
   end Set_Entity_Type;

   --  ------------------------------
   --  Set the permission to check before removing or adding a comment on the entity.
   --  ------------------------------
   procedure Set_Permission (Into       : in out Comment_List_Bean;
                             Permission : in String) is
   begin
      Into.Permission := Ada.Strings.Unbounded.To_Unbounded_String (Permission);
   end Set_Permission;

   --  ------------------------------
   --  Load the comments associated with the given database identifier.
   --  ------------------------------
   procedure Load_Comments (Into          : in out Comment_List_Bean;
                            For_Entity_Id : in ADO.Identifier) is
      Session : ADO.Sessions.Session := Into.Module.Get_Session;
   begin
      Into.Load_Comments (Session, For_Entity_Id);
   end Load_Comments;

   --  ------------------------------
   --  Load the comments associated with the given database identifier.
   --  ------------------------------
   procedure Load_Comments (Into          : in out Comment_List_Bean;
                            Session       : in out ADO.Sessions.Session;
                            For_Entity_Id : in ADO.Identifier) is
      use ADO.Sessions.Entities;

      Entity_Type : constant String := Ada.Strings.Unbounded.To_String (Into.Entity_Type);
      Kind        : constant ADO.Entity_Type := Find_Entity_Type (Session, Entity_Type);
      Query       : ADO.Queries.Context;
   begin
      Into.Entity_Id := For_Entity_Id;
      Query.Set_Query (AWA.Comments.Models.Query_Comment_List);
      Query.Bind_Param ("entity_type", Kind);
      Query.Bind_Param ("entity_id", For_Entity_Id);
      Query.Bind_Param ("status", Integer (Models.Status_Type'Pos (Models.COMMENT_PUBLISHED)));
      AWA.Comments.Models.List (Into, Session, Query);
   end Load_Comments;

   --  ------------------------------
   --  Create the comment list bean instance.
   --  ------------------------------
   function Create_Comment_List_Bean (Module : in AWA.Comments.Modules.Comment_Module_Access)
                                      return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Comment_List_Bean_Access := new Comment_List_Bean;
   begin
      Result.Module := Module;
      return Result.all'Access;
   end Create_Comment_List_Bean;

end AWA.Comments.Beans;

Implement the Save action bean by using the Update_Comment operation


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

with Util.Tests;
with Util.Log.Loggers;

with AWA.Applications;
with AWA.Tests;
with AWA.Users.Modules;
with ADO.Sessions;
with ADO.SQL;
package body AWA.Tests.Helpers.Users is

   use AWA.Users.Services;

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Tests.Helpers.Users");

   --  ------------------------------
   --  Initialize the service context.
   --  ------------------------------
   procedure Initialize (Principal : in out Test_User) is
   begin
      --  Setup the service context.
      Principal.Context.Set_Context (AWA.Tests.Get_Application, null);

      if Principal.Manager = null then
         Principal.Manager := AWA.Users.Modules.Get_User_Manager;
         if Principal.Manager = null then
            Log.Error ("There is no User_Manager in the application.");
         end if;
      end if;
   end Initialize;

   --  ------------------------------
   --  Create a test user associated with the given email address.
   --  Get an open session for that user.  If the user already exists, no error is reported.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User;
                          Email     : in String) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
      Key   : AWA.Users.Models.Access_Key_Ref;
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the user
      Query.Set_Join ("inner join email e on e.user_id = o.id");
      Query.Set_Filter ("e.email = ?");
      Query.Bind_Param (1, Email);
      Principal.User.Find (DB, Query, Found);
      if not Found then
         Principal.User.Set_First_Name ("Joe");
         Principal.User.Set_Last_Name ("Pot");
         Principal.User.Set_Password ("admin");
         Principal.Email.Set_Email (Email);
         Principal.Manager.Create_User (Principal.User, Principal.Email);

         Find_Access_Key (Principal, Email, Key);

         --  Run the verification and get the user and its session
         Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                        Principal.Principal);
      else
         Principal.Manager.Authenticate (Email     => Email,
                                         Password  => "admin",
                                         IpAddr    => "192.168.1.1",
                                         Principal => Principal.Principal);
      end if;
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Create a test user for a new test and get an open session.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User) is
      Key     : AWA.Users.Models.Access_Key_Ref;
      Email   : constant String := "Joe-" & Util.Tests.Get_Uuid & "@gmail.com";
   begin
      Initialize (Principal);
      Principal.User.Set_First_Name ("Joe");
      Principal.User.Set_Last_Name ("Pot");
      Principal.User.Set_Password ("admin");
      Principal.Email.Set_Email (Email);
      Principal.Manager.Create_User (Principal.User, Principal.Email);

      Find_Access_Key (Principal, Email, Key);

      --  Run the verification and get the user and its session
      Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                     Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Find the access key associated with a user (if any).
   --  ------------------------------
   procedure Find_Access_Key (Principal : in out Test_User;
                              Email     : in String;
                              Key       : in out AWA.Users.Models.Access_Key_Ref) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the access key
      Query.Set_Join ("inner join email e on e.user_id = o.user_id");
      Query.Set_Filter ("e.email = ?");
      Query.Bind_Param (1, Email);
      Key.Find (DB, Query, Found);
      if not Found then
         Log.Error ("Cannot find access key for email {0}", Email);
      end if;
   end Find_Access_Key;

   --  ------------------------------
   --  Login a user and create a session
   --  ------------------------------
   procedure Login (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Authenticate (Email     => Principal.Email.Get_Email,
                                      Password  => "admin",
                                      IpAddr    => "192.168.1.1",
                                      Principal => Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Login;

   --  ------------------------------
   --  Logout the user and closes the current session.
   --  ------------------------------
   procedure Logout (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Close_Session (Principal.Session.Get_Id, True);
   end Logout;

   --  Simulate a user login in the given service context.
   procedure Login (Context : in out AWA.Services.Contexts.Service_Context;
                    Sec_Context : in out Security.Contexts.Security_Context;
                    Email   : in String) is
      User      : Test_User;
      Principal : AWA.Users.Principals.Principal_Access;
      App       : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
   begin
      AWA.Tests.Set_Application_Context;
      Create_User (User, Email);
      Principal := AWA.Users.Principals.Create (User.User, User.Session);
      Context.Set_Context (App, Principal);
      Sec_Context.Set_Context (Manager   => App.Get_Security_Manager,
                               Principal => Principal.all'Access);
   end Login;

   overriding
   procedure Finalize (Principal : in out Test_User) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => AWA.Users.Principals.Principal'Class,
                                         Name   => AWA.Users.Principals.Principal_Access);
   begin
      Free (Principal.Principal);
   end Finalize;

end AWA.Tests.Helpers.Users;

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

with Util.Tests;
with Util.Log.Loggers;

with AWA.Applications;
with AWA.Tests;
with AWA.Users.Modules;
with ADO.Sessions;
with ADO.SQL;
package body AWA.Tests.Helpers.Users is

   use AWA.Users.Services;

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Tests.Helpers.Users");

   --  ------------------------------
   --  Initialize the service context.
   --  ------------------------------
   procedure Initialize (Principal : in out Test_User) is
   begin
      --  Setup the service context.
      Principal.Context.Set_Context (AWA.Tests.Get_Application, null);

      if Principal.Manager = null then
         Principal.Manager := AWA.Users.Modules.Get_User_Manager;
         if Principal.Manager = null then
            Log.Error ("There is no User_Manager in the application.");
         end if;
      end if;
   end Initialize;

   --  ------------------------------
   --  Create a test user associated with the given email address.
   --  Get an open session for that user.  If the user already exists, no error is reported.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User;
                          Email     : in String) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
      Key   : AWA.Users.Models.Access_Key_Ref;
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the user
      Query.Set_Join ("inner join awa_email e on e.user_id = o.id");
      Query.Set_Filter ("e.email = ?");
      Query.Bind_Param (1, Email);
      Principal.User.Find (DB, Query, Found);
      if not Found then
         Principal.User.Set_First_Name ("Joe");
         Principal.User.Set_Last_Name ("Pot");
         Principal.User.Set_Password ("admin");
         Principal.Email.Set_Email (Email);
         Principal.Manager.Create_User (Principal.User, Principal.Email);

         Find_Access_Key (Principal, Email, Key);

         --  Run the verification and get the user and its session
         Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                        Principal.Principal);
      else
         Principal.Manager.Authenticate (Email     => Email,
                                         Password  => "admin",
                                         IpAddr    => "192.168.1.1",
                                         Principal => Principal.Principal);
      end if;
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Create a test user for a new test and get an open session.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User) is
      Key     : AWA.Users.Models.Access_Key_Ref;
      Email   : constant String := "Joe-" & Util.Tests.Get_Uuid & "@gmail.com";
   begin
      Initialize (Principal);
      Principal.User.Set_First_Name ("Joe");
      Principal.User.Set_Last_Name ("Pot");
      Principal.User.Set_Password ("admin");
      Principal.Email.Set_Email (Email);
      Principal.Manager.Create_User (Principal.User, Principal.Email);

      Find_Access_Key (Principal, Email, Key);

      --  Run the verification and get the user and its session
      Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                     Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Find the access key associated with a user (if any).
   --  ------------------------------
   procedure Find_Access_Key (Principal : in out Test_User;
                              Email     : in String;
                              Key       : in out AWA.Users.Models.Access_Key_Ref) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the access key
      Query.Set_Join ("inner join awa_email e on e.user_id = o.user_id");
      Query.Set_Filter ("e.email = ?");
      Query.Bind_Param (1, Email);
      Key.Find (DB, Query, Found);
      if not Found then
         Log.Error ("Cannot find access key for email {0}", Email);
      end if;
   end Find_Access_Key;

   --  ------------------------------
   --  Login a user and create a session
   --  ------------------------------
   procedure Login (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Authenticate (Email     => Principal.Email.Get_Email,
                                      Password  => "admin",
                                      IpAddr    => "192.168.1.1",
                                      Principal => Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Login;

   --  ------------------------------
   --  Logout the user and closes the current session.
   --  ------------------------------
   procedure Logout (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Close_Session (Principal.Session.Get_Id, True);
   end Logout;

   --  Simulate a user login in the given service context.
   procedure Login (Context : in out AWA.Services.Contexts.Service_Context;
                    Sec_Context : in out Security.Contexts.Security_Context;
                    Email   : in String) is
      User      : Test_User;
      Principal : AWA.Users.Principals.Principal_Access;
      App       : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
   begin
      AWA.Tests.Set_Application_Context;
      Create_User (User, Email);
      Principal := AWA.Users.Principals.Create (User.User, User.Session);
      Context.Set_Context (App, Principal);
      Sec_Context.Set_Context (Manager   => App.Get_Security_Manager,
                               Principal => Principal.all'Access);
   end Login;

   overriding
   procedure Finalize (Principal : in out Test_User) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => AWA.Users.Principals.Principal'Class,
                                         Name   => AWA.Users.Principals.Principal_Access);
   begin
      Free (Principal.Principal);
   end Finalize;

end AWA.Tests.Helpers.Users;

Update according to the UML model

Update according to the UML model


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

package body MAT.Consoles is

   --  ------------------------------
   --  Print the title for the given field and setup the associated field size.
   --  ------------------------------
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String;
                          Length  : in Positive) is
   begin
      Console.Sizes (Field) := Length;
      if Console.Field_Count >= 1 then
         Console.Cols (Field) := Console.Cols (Console.Fields (Console.Field_Count))
           + Console.Sizes (Console.Fields (Console.Field_Count));
      else
         Console.Cols (Field) := 1;
      end if;
      Console.Field_Count := Console.Field_Count + 1;
      Console.Fields (Console.Field_Count) := Field;
      Console_Type'Class (Console).Print_Title (Field, Title);
   end Print_Title;

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

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

   --  ------------------------------
   --  Format the thread information and print it for the given field.
   --  ------------------------------
   procedure Print_Thread (Console : in out Console_Type;
                           Field   : in Field_Type;
                           Thread  : in MAT.Types.Target_Thread_Ref) is
      Value : constant String := MAT.Types.Target_Thread_Ref'Image (Thread);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Thread;

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

   --  ------------------------------
   --  Format the integer and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Console_Type'Class (Console).Print_Field (Field, Ada.Strings.Unbounded.To_String (Value));
   end Print_Field;

end MAT.Consoles;

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

package body MAT.Consoles is

   --  ------------------------------
   --  Print the title for the given field and setup the associated field size.
   --  ------------------------------
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String;
                          Length  : in Positive) is
   begin
      Console.Sizes (Field) := Length;
      if Console.Field_Count >= 1 then
         Console.Cols (Field) := Console.Cols (Console.Fields (Console.Field_Count))
           + Console.Sizes (Console.Fields (Console.Field_Count));
      else
         Console.Cols (Field) := 1;
      end if;
      Console.Field_Count := Console.Field_Count + 1;
      Console.Fields (Console.Field_Count) := Field;
      Console_Type'Class (Console).Print_Title (Field, Title);
   end Print_Title;

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

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

   --  ------------------------------
   --  Format the thread information and print it for the given field.
   --  ------------------------------
   procedure Print_Thread (Console : in out Console_Type;
                           Field   : in Field_Type;
                           Thread  : in MAT.Types.Target_Thread_Ref) is
      Value : constant String := MAT.Types.Target_Thread_Ref'Image (Thread);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Thread;

   --  ------------------------------
   --  Format the time tick as a duration and print it for the given field.
   --  ------------------------------
   procedure Print_Duration (Console  : in out Console_Type;
                             Field    : in Field_Type;
                             Duration : in MAT.Types.Target_Tick_Ref) is
      Value : constant String := MAT.Types.Tick_Image (Duration);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Duration;

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

   --  ------------------------------
   --  Format the integer and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Console_Type'Class (Console).Print_Field (Field, Ada.Strings.Unbounded.To_String (Value));
   end Print_Field;

end MAT.Consoles;

Implement the Print_Duration operation

Implement the Print_Duration operation