-----------------------------------------------------------------------
--  gen-model-xmi -- UML-XMI model
--  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 Ada.Containers.Hashed_Maps;
with Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Hash;
with Ada.Containers.Vectors;

with Util.Beans.Objects;

with Gen.Model.Tables;
package Gen.Model.XMI is

   use Ada.Strings.Unbounded;

   type Element_Type is (XMI_UNKNOWN,
                         XMI_PACKAGE,
                         XMI_CLASS,
                         XMI_ASSOCIATION,
                         XMI_ASSOCIATION_END,
                         XMI_ATTRIBUTE,
                         XMI_OPERATION,
                         XMI_ENUMERATION,
                         XMI_ENUMERATION_LITERAL,
                         XMI_TAGGED_VALUE,
                         XMI_TAG_DEFINITION,
                         XMI_DATA_TYPE,
                         XMI_STEREOTYPE,
                         XMI_COMMENT);

   type Visibility_Type is (VISIBILITY_PUBLIC,
                            VISIBILITY_PACKAGE,
                            VISIBILITY_PROTECTED,
                            VISIBILITY_PRIVATE);

   type Changeability_Type is (CHANGEABILITY_INSERT,
                               CHANGEABILITY_CHANGEABLE,
                               CHANGEABILITY_FROZEN);
   type Model_Element;
   type Tagged_Value_Element;
   type Model_Element_Access is access all Model_Element'Class;
   type Tagged_Value_Element_Access is access all Tagged_Value_Element'Class;

   --  Define a list of model elements.
   package Model_Vectors is
      new Ada.Containers.Vectors (Index_Type   => Positive,
                                  Element_Type => Model_Element_Access);

   subtype Model_Vector is Model_Vectors.Vector;

   subtype Model_Cursor is Model_Vectors.Cursor;

   --  Define a map to search an element from its XMI ID.
   package Model_Map is
     new Ada.Containers.Hashed_Maps (Key_Type        => Unbounded_String,
                                     Element_Type    => Model_Element_Access,
                                     Hash            => Ada.Strings.Unbounded.Hash,
                                     Equivalent_Keys => "=");

   subtype Model_Map_Cursor is Model_Map.Cursor;
   type Model_Map_Access is access all Model_Map.Map;

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

   --  Returns the table definition.
   function Element (Position : in Model_Map_Cursor) return Model_Element_Access
                     renames Model_Map.Element;

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

   --  Iterate on the model element of the type <tt>On</tt> and execute the <tt>Process</tt>
   --  procedure.
   procedure Iterate (Model   : in Model_Map.Map;
                      On      : in Element_Type;
                      Process : not null access procedure (Id   : in Unbounded_String;
                                                           Node : in Model_Element_Access));

   --  Generic procedure to iterate over the XMI elements of a vector
   --  and having the entity name <b>name</b>.
   generic
      type T (<>) is limited private;
   procedure Iterate_Elements (Closure : in out T;
                               List    : in Model_Vector;
                               Process : not null access
                                 procedure (Closure : in out T;
                                            Node    : in Model_Element_Access));

   --  Map of UML models indexed on the model name.
   package UML_Model_Map is new
     Ada.Containers.Hashed_Maps (Key_Type        => Unbounded_String,
                                 Element_Type    => Model_Map.Map,
                                 Hash            => Ada.Strings.Unbounded.Hash,
                                 Equivalent_Keys => "=",
                                 "="             => Model_Map."=");
   subtype UML_Model is UML_Model_Map.Map;

   type Search_Type is (BY_NAME, BY_ID);

   --  Find the model element with the given XMI id.
   --  Returns null if the model element is not found.
   function Find (Model : in Model_Map.Map;
                  Key   : in String;
                  Mode  : in Search_Type := BY_ID) return Model_Element_Access;

   --  Find the model element within all loaded UML models.
   --  Returns null if the model element is not found.
   function Find (Model   : in UML_Model;
                  Current : in Model_Map.Map;
                  Id      : in Ada.Strings.Unbounded.Unbounded_String)
                  return Model_Element_Access;

   --  Dump the XMI model elements.
   procedure Dump (Map : in Model_Map.Map);

   --  Reconcile all the UML model elements by resolving all the references to UML elements.
   procedure Reconcile (Model : in out UML_Model);

   --  ------------------------------
   --  Model Element
   --  ------------------------------
   type Model_Element (Model : Model_Map_Access) is abstract new Definition with record
      --  Element XMI id.
      XMI_Id        : Ada.Strings.Unbounded.Unbounded_String;

      --  List of tagged values for the element.
      Tagged_Values : Model_Vector;

      --  Elements contained.
      Elements      : Model_Vector;

      --  Stereotypes associated with the element.
      Stereotypes   : Model_Vector;

      --  The parent model element;
      Parent        : Model_Element_Access;
   end record;

   --  Get the element type.
   function Get_Type (Node : in Model_Element) return Element_Type is abstract;

   --  Reconcile the element by resolving the references to other elements in the model.
   procedure Reconcile (Node  : in out Model_Element;
                        Model : in UML_Model);

   --  Find the element with the given name.  If the name is a qualified name, navigate
   --  down the package/class to find the appropriate element.
   --  Returns null if the element was not found.
   function Find (Node : in Model_Element;
                  Name : in String) return Model_Element_Access;

   --  Set the model name.
   procedure Set_Name (Node  : in out Model_Element;
                       Value : in Util.Beans.Objects.Object);

   --  Set the model XMI unique id.
   procedure Set_XMI_Id (Node  : in out Model_Element;
                         Value : in Util.Beans.Objects.Object);

   --  Find the tag value element with the given name.
   --  Returns null if there is no such tag.
   function Find_Tag_Value (Node : in Model_Element;
                            Name : in String) return Tagged_Value_Element_Access;

   --  Get the documentation and comment associated with the model element.
   --  Returns the empty string if there is no comment.
   function Get_Comment (Node : in Model_Element) return String;

   --  Get the full qualified name for the element.
   function Get_Qualified_Name (Node : in Model_Element) return String;

   --  Find from the model file identified by <tt>Name</tt>, the model element with the
   --  identifier or name represented by <tt>Key</tt>.
   --  Returns null if the model element is not found.
   generic
      type Element_Type is new Model_Element with private;
      type Element_Type_Access is access all Element_Type'Class;
   function Find_Element (Model   : in UML_Model;
                          Name    : in String;
                          Key     : in String;
                          Mode    : in Search_Type := BY_ID)
                          return Element_Type_Access;

   --  ------------------------------
   --  Data type
   --  ------------------------------
   type Ref_Type_Element is new Model_Element with record
      Href : Unbounded_String;
      Ref  : Model_Element_Access;
   end record;
   type Ref_Type_Element_Access is access all Ref_Type_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Ref_Type_Element) return Element_Type;

   --  Reconcile the element by resolving the references to other elements in the model.
   overriding
   procedure Reconcile (Node  : in out Ref_Type_Element;
                        Model : in UML_Model);

   --  ------------------------------
   --  Data type
   --  ------------------------------
   type Data_Type_Element is new Model_Element with null record;
   type Data_Type_Element_Access is access all Data_Type_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Data_Type_Element) return Element_Type;

   --  ------------------------------
   --  Enum
   --  ------------------------------
   type Enum_Element is new Model_Element with null record;
   type Enum_Element_Access is access all Enum_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Enum_Element) return Element_Type;

   procedure Add_Literal (Node : in out Enum_Element;
                          Id   : in Util.Beans.Objects.Object;
                          Name : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Literal
   --  ------------------------------
   --  The literal describes a possible value for an enum.
   type Literal_Element is new Model_Element with null record;
   type Literal_Element_Access is access all Literal_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Literal_Element) return Element_Type;

   --  ------------------------------
   --  Stereotype
   --  ------------------------------

   type Stereotype_Element is new Model_Element with null record;
   type Stereotype_Element_Access is access all Stereotype_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Stereotype_Element) return Element_Type;

   --  Returns True if the model element has the stereotype with the given name.
   function Has_Stereotype (Node       : in Model_Element'Class;
                            Stereotype : in Stereotype_Element_Access) return Boolean;

   --  ------------------------------
   --  Comment
   --  ------------------------------
   type Comment_Element is new Model_Element with record
      Text       : Ada.Strings.Unbounded.Unbounded_String;
      Ref_Id     : Ada.Strings.Unbounded.Unbounded_String;
   end record;
   type Comment_Element_Access is access all Comment_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Comment_Element) return Element_Type;

   --  ------------------------------
   --  An operation
   --  ------------------------------
   type Operation_Element is new Model_Element with record
      Visibility : Visibility_Type := VISIBILITY_PUBLIC;
   end record;
   type Operation_Element_Access is access all Operation_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Operation_Element) return Element_Type;

   --  ------------------------------
   --  An attribute
   --  ------------------------------
   type Attribute_Element is new Model_Element with record
      Ref_Id             : Ada.Strings.Unbounded.Unbounded_String;
      Visibility         : Visibility_Type := VISIBILITY_PUBLIC;
      Changeability      : Changeability_Type := CHANGEABILITY_CHANGEABLE;
      Initial_Value      : Util.Beans.Objects.Object;
      Multiplicity_Lower : Integer := 0;
      Multiplicity_Upper : Integer := 1;
   end record;
   type Attribute_Element_Access is access all Attribute_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Attribute_Element) return Element_Type;

   --  ------------------------------
   --  An association end
   --  ------------------------------
   type Association_End_Element is new Model_Element with record
      Visibility : Visibility_Type := VISIBILITY_PUBLIC;
   end record;
   type Association_End_Element_Access is access all Association_End_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Association_End_Element) return Element_Type;

   --  ------------------------------
   --  An association
   --  ------------------------------
   type Association_Element is new Model_Element with record
      Visibility : Visibility_Type := VISIBILITY_PUBLIC;
   end record;
   type Association_Element_Access is access all Association_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Association_Element) return Element_Type;

   --  ------------------------------
   --  Tag Definition
   --  ------------------------------
   TAG_DOCUMENTATION : constant String := "documentation";
   TAG_AUTHOR        : constant String := "author";

   type Tag_Definition_Element is new Model_Element with record
      Multiplicity_Lower : Natural := 0;
      Multiplicity_Upper : Natural := 0;
   end record;
   type Tag_Definition_Element_Access is access all Tag_Definition_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Tag_Definition_Element) return Element_Type;

   --  ------------------------------
   --  Tagged value
   --  ------------------------------
   type Tagged_Value_Element is new Model_Element with record
      Value      : Ada.Strings.Unbounded.Unbounded_String;
      Value_Type : Ada.Strings.Unbounded.Unbounded_String;
      Ref_Id     : Ada.Strings.Unbounded.Unbounded_String;
      Tag_Def    : Tag_Definition_Element_Access;
   end record;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Tagged_Value_Element) return Element_Type;

   --  Reconcile the element by resolving the references to other elements in the model.
   overriding
   procedure Reconcile (Node  : in out Tagged_Value_Element;
                        Model : in UML_Model);

   --  ------------------------------
   --  A class
   --  ------------------------------
   type Class_Element is new Model_Element with record
      Operations   : Model_Vector;
      Attributes   : Model_Vector;
      Associations : Model_Vector;
      Visibility   : Visibility_Type := VISIBILITY_PUBLIC;
   end record;
   type Class_Element_Access is access all Class_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Class_Element) return Element_Type;

   --  ------------------------------
   --  A package
   --  ------------------------------
   type Package_Element;
   type Package_Element_Access is access all Package_Element'Class;

   type Package_Element is new Model_Element with record
      Classes      : Model_Vector;
   end record;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Package_Element) return Element_Type;

end Gen.Model.XMI;

-----------------------------------------------------------------------
--  gen-model-xmi -- UML-XMI model
--  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 Ada.Containers.Hashed_Maps;
with Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Hash;
with Ada.Containers.Vectors;

with Util.Beans.Objects;

with Gen.Model.Tables;
package Gen.Model.XMI is

   use Ada.Strings.Unbounded;

   type Element_Type is (XMI_UNKNOWN,
                         XMI_PACKAGE,
                         XMI_CLASS,
                         XMI_ASSOCIATION,
                         XMI_ASSOCIATION_END,
                         XMI_ATTRIBUTE,
                         XMI_OPERATION,
                         XMI_ENUMERATION,
                         XMI_ENUMERATION_LITERAL,
                         XMI_TAGGED_VALUE,
                         XMI_TAG_DEFINITION,
                         XMI_DATA_TYPE,
                         XMI_STEREOTYPE,
                         XMI_COMMENT);

   --  Defines the visibility of an element (a package, class, attribute, operation).
   type Visibility_Type is (VISIBILITY_PUBLIC,
                            VISIBILITY_PACKAGE,
                            VISIBILITY_PROTECTED,
                            VISIBILITY_PRIVATE);

   --  Defines whether an attribute or association changes.
   type Changeability_Type is (CHANGEABILITY_INSERT,
                               CHANGEABILITY_CHANGEABLE,
                               CHANGEABILITY_FROZEN);

   type Model_Element;
   type Tagged_Value_Element;
   type Model_Element_Access is access all Model_Element'Class;
   type Tagged_Value_Element_Access is access all Tagged_Value_Element'Class;

   --  Define a list of model elements.
   package Model_Vectors is
      new Ada.Containers.Vectors (Index_Type   => Positive,
                                  Element_Type => Model_Element_Access);

   subtype Model_Vector is Model_Vectors.Vector;

   subtype Model_Cursor is Model_Vectors.Cursor;

   --  Define a map to search an element from its XMI ID.
   package Model_Map is
     new Ada.Containers.Hashed_Maps (Key_Type        => Unbounded_String,
                                     Element_Type    => Model_Element_Access,
                                     Hash            => Ada.Strings.Unbounded.Hash,
                                     Equivalent_Keys => "=");

   subtype Model_Map_Cursor is Model_Map.Cursor;
   type Model_Map_Access is access all Model_Map.Map;

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

   --  Returns the table definition.
   function Element (Position : in Model_Map_Cursor) return Model_Element_Access
                     renames Model_Map.Element;

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

   --  Iterate on the model element of the type <tt>On</tt> and execute the <tt>Process</tt>
   --  procedure.
   procedure Iterate (Model   : in Model_Map.Map;
                      On      : in Element_Type;
                      Process : not null access procedure (Id   : in Unbounded_String;
                                                           Node : in Model_Element_Access));

   --  Generic procedure to iterate over the XMI elements of a vector
   --  and having the entity name <b>name</b>.
   generic
      type T (<>) is limited private;
   procedure Iterate_Elements (Closure : in out T;
                               List    : in Model_Vector;
                               Process : not null access
                                 procedure (Closure : in out T;
                                            Node    : in Model_Element_Access));

   --  Map of UML models indexed on the model name.
   package UML_Model_Map is new
     Ada.Containers.Hashed_Maps (Key_Type        => Unbounded_String,
                                 Element_Type    => Model_Map.Map,
                                 Hash            => Ada.Strings.Unbounded.Hash,
                                 Equivalent_Keys => "=",
                                 "="             => Model_Map."=");
   subtype UML_Model is UML_Model_Map.Map;

   type Search_Type is (BY_NAME, BY_ID);

   --  Find the model element with the given XMI id.
   --  Returns null if the model element is not found.
   function Find (Model : in Model_Map.Map;
                  Key   : in String;
                  Mode  : in Search_Type := BY_ID) return Model_Element_Access;

   --  Find the model element within all loaded UML models.
   --  Returns null if the model element is not found.
   function Find (Model   : in UML_Model;
                  Current : in Model_Map.Map;
                  Id      : in Ada.Strings.Unbounded.Unbounded_String)
                  return Model_Element_Access;

   --  Dump the XMI model elements.
   procedure Dump (Map : in Model_Map.Map);

   --  Reconcile all the UML model elements by resolving all the references to UML elements.
   procedure Reconcile (Model : in out UML_Model);

   --  ------------------------------
   --  Model Element
   --  ------------------------------
   type Model_Element (Model : Model_Map_Access) is abstract new Definition with record
      --  Element XMI id.
      XMI_Id        : Ada.Strings.Unbounded.Unbounded_String;

      --  List of tagged values for the element.
      Tagged_Values : Model_Vector;

      --  Elements contained.
      Elements      : Model_Vector;

      --  Stereotypes associated with the element.
      Stereotypes   : Model_Vector;

      --  The parent model element;
      Parent        : Model_Element_Access;
   end record;

   --  Get the element type.
   function Get_Type (Node : in Model_Element) return Element_Type is abstract;

   --  Reconcile the element by resolving the references to other elements in the model.
   procedure Reconcile (Node  : in out Model_Element;
                        Model : in UML_Model);

   --  Find the element with the given name.  If the name is a qualified name, navigate
   --  down the package/class to find the appropriate element.
   --  Returns null if the element was not found.
   function Find (Node : in Model_Element;
                  Name : in String) return Model_Element_Access;

   --  Set the model name.
   procedure Set_Name (Node  : in out Model_Element;
                       Value : in Util.Beans.Objects.Object);

   --  Set the model XMI unique id.
   procedure Set_XMI_Id (Node  : in out Model_Element;
                         Value : in Util.Beans.Objects.Object);

   --  Find the tag value element with the given name.
   --  Returns null if there is no such tag.
   function Find_Tag_Value (Node : in Model_Element;
                            Name : in String) return Tagged_Value_Element_Access;

   --  Get the documentation and comment associated with the model element.
   --  Returns the empty string if there is no comment.
   function Get_Comment (Node : in Model_Element) return String;

   --  Get the full qualified name for the element.
   function Get_Qualified_Name (Node : in Model_Element) return String;

   --  Find from the model file identified by <tt>Name</tt>, the model element with the
   --  identifier or name represented by <tt>Key</tt>.
   --  Returns null if the model element is not found.
   generic
      type Element_Type is new Model_Element with private;
      type Element_Type_Access is access all Element_Type'Class;
   function Find_Element (Model   : in UML_Model;
                          Name    : in String;
                          Key     : in String;
                          Mode    : in Search_Type := BY_ID)
                          return Element_Type_Access;

   --  ------------------------------
   --  Data type
   --  ------------------------------
   type Ref_Type_Element is new Model_Element with record
      Href : Unbounded_String;
      Ref  : Model_Element_Access;
   end record;
   type Ref_Type_Element_Access is access all Ref_Type_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Ref_Type_Element) return Element_Type;

   --  Reconcile the element by resolving the references to other elements in the model.
   overriding
   procedure Reconcile (Node  : in out Ref_Type_Element;
                        Model : in UML_Model);

   --  ------------------------------
   --  Data type
   --  ------------------------------
   type Data_Type_Element is new Model_Element with null record;
   type Data_Type_Element_Access is access all Data_Type_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Data_Type_Element) return Element_Type;

   --  ------------------------------
   --  Enum
   --  ------------------------------
   type Enum_Element is new Model_Element with null record;
   type Enum_Element_Access is access all Enum_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Enum_Element) return Element_Type;

   procedure Add_Literal (Node : in out Enum_Element;
                          Id   : in Util.Beans.Objects.Object;
                          Name : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Literal
   --  ------------------------------
   --  The literal describes a possible value for an enum.
   type Literal_Element is new Model_Element with null record;
   type Literal_Element_Access is access all Literal_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Literal_Element) return Element_Type;

   --  ------------------------------
   --  Stereotype
   --  ------------------------------

   type Stereotype_Element is new Model_Element with null record;
   type Stereotype_Element_Access is access all Stereotype_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Stereotype_Element) return Element_Type;

   --  Returns True if the model element has the stereotype with the given name.
   function Has_Stereotype (Node       : in Model_Element'Class;
                            Stereotype : in Stereotype_Element_Access) return Boolean;

   --  ------------------------------
   --  Comment
   --  ------------------------------
   type Comment_Element is new Model_Element with record
      Text       : Ada.Strings.Unbounded.Unbounded_String;
      Ref_Id     : Ada.Strings.Unbounded.Unbounded_String;
   end record;
   type Comment_Element_Access is access all Comment_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Comment_Element) return Element_Type;

   --  ------------------------------
   --  An operation
   --  ------------------------------
   type Operation_Element is new Model_Element with record
      Visibility : Visibility_Type := VISIBILITY_PUBLIC;
   end record;
   type Operation_Element_Access is access all Operation_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Operation_Element) return Element_Type;

   --  ------------------------------
   --  An attribute
   --  ------------------------------
   type Attribute_Element is new Model_Element with record
      Ref_Id             : Ada.Strings.Unbounded.Unbounded_String;
      Visibility         : Visibility_Type := VISIBILITY_PUBLIC;
      Changeability      : Changeability_Type := CHANGEABILITY_CHANGEABLE;
      Initial_Value      : Util.Beans.Objects.Object;
      Multiplicity_Lower : Integer := 0;
      Multiplicity_Upper : Integer := 1;
   end record;
   type Attribute_Element_Access is access all Attribute_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Attribute_Element) return Element_Type;

   --  ------------------------------
   --  An association end
   --  ------------------------------
   type Association_End_Element is new Model_Element with record
      Visibility : Visibility_Type := VISIBILITY_PUBLIC;
   end record;
   type Association_End_Element_Access is access all Association_End_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Association_End_Element) return Element_Type;

   --  ------------------------------
   --  An association
   --  ------------------------------
   type Association_Element is new Model_Element with record
      Visibility : Visibility_Type := VISIBILITY_PUBLIC;
   end record;
   type Association_Element_Access is access all Association_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Association_Element) return Element_Type;

   --  ------------------------------
   --  Tag Definition
   --  ------------------------------
   TAG_DOCUMENTATION : constant String := "documentation";
   TAG_AUTHOR        : constant String := "author";

   type Tag_Definition_Element is new Model_Element with record
      Multiplicity_Lower : Natural := 0;
      Multiplicity_Upper : Natural := 0;
   end record;
   type Tag_Definition_Element_Access is access all Tag_Definition_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Tag_Definition_Element) return Element_Type;

   --  ------------------------------
   --  Tagged value
   --  ------------------------------
   type Tagged_Value_Element is new Model_Element with record
      Value      : Ada.Strings.Unbounded.Unbounded_String;
      Value_Type : Ada.Strings.Unbounded.Unbounded_String;
      Ref_Id     : Ada.Strings.Unbounded.Unbounded_String;
      Tag_Def    : Tag_Definition_Element_Access;
   end record;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Tagged_Value_Element) return Element_Type;

   --  Reconcile the element by resolving the references to other elements in the model.
   overriding
   procedure Reconcile (Node  : in out Tagged_Value_Element;
                        Model : in UML_Model);

   --  ------------------------------
   --  A class
   --  ------------------------------
   type Class_Element is new Model_Element with record
      Operations   : Model_Vector;
      Attributes   : Model_Vector;
      Associations : Model_Vector;
      Visibility   : Visibility_Type := VISIBILITY_PUBLIC;
   end record;
   type Class_Element_Access is access all Class_Element'Class;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Class_Element) return Element_Type;

   --  ------------------------------
   --  A package
   --  ------------------------------
   type Package_Element;
   type Package_Element_Access is access all Package_Element'Class;

   type Package_Element is new Model_Element with record
      Classes      : Model_Vector;
   end record;

   --  Get the element type.
   overriding
   function Get_Type (Node : in Package_Element) return Element_Type;

end Gen.Model.XMI;

Add some comments.

Add some comments.


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

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

with Util.Beans.Objects;
with Util.Properties;

with ASF.Applications.Main;
with ASF.Contexts.Faces;

with Gen.Model.Packages;
with Gen.Model.Projects;
with Gen.Artifacts.Hibernate;
with Gen.Artifacts.Query;
with Gen.Artifacts.Mappings;
with Gen.Artifacts.Distribs;
with Gen.Artifacts.XMI;
package Gen.Generator is

   --  A fatal error that prevents the generator to proceed has occurred.
   Fatal_Error : exception;

   G_URI : constant String := "http://code.google.com/p/ada-ado/generator";

   type Package_Type is (PACKAGE_MODEL, PACKAGE_FORMS);

   type Mapping_File is record
      Path   : Ada.Strings.Unbounded.Unbounded_String;
      Output : Ada.Text_IO.File_Type;
   end record;

   type Handler is new ASF.Applications.Main.Application and Gen.Artifacts.Generator with private;

   --  Initialize the generator
   procedure Initialize (H : in out Handler;
                         Config_Dir : in Ada.Strings.Unbounded.Unbounded_String;
                         Debug : in Boolean);

   --  Get the configuration properties.
   function Get_Properties (H : in Handler) return Util.Properties.Manager;

   --  Report an error and set the exit status accordingly
   procedure Error (H : in out Handler;
                    Message : in String;
                    Arg1    : in String := "";
                    Arg2    : in String := "");

   --  Report an info message.
   procedure Info (H : in out Handler;
                   Message : in String;
                   Arg1    : in String := "";
                   Arg2    : in String := "");

   --  Read the XML package file
   procedure Read_Package (H    : in out Handler;
                           File : in String);

   --  Read the model mapping types and initialize the hibernate artifact.
   procedure Read_Mappings (H    : in out Handler);

   --  Read the XML model file
   procedure Read_Model (H      : in out Handler;
                         File   : in String;
                         Silent : in Boolean);

   --  Read the model and query files stored in the application directory db.
   procedure Read_Models (H : in out Handler;
                          Dirname : in String);

   --  Read the XML project file.  When Recursive is set, read the GNAT project
   --  files used by the main project and load all the dynamo.xml files defined
   --  by these project.
   procedure Read_Project (H         : in out Handler;
                           File      : in String;
                           Recursive : in Boolean := False);

   --  Prepare the model by checking, verifying and initializing it after it is completely known.
   procedure Prepare (H : in out Handler);

   --  Finish the generation.  Some artifacts could generate other files that take into
   --  account files generated previously.
   procedure Finish (H : in out Handler);

   --  Tell the generator to activate the generation of the given template name.
   --  The name is a property name that must be defined in generator.properties to
   --  indicate the template file.  Several artifacts can trigger the generation
   --  of a given template.  The template is generated only once.
   procedure Add_Generation (H    : in out Handler;
                             Name : in String;
                             Mode : in Gen.Artifacts.Iteration_Mode;
                             Mapping : in String);

   --  Enable the generation of the Ada package given by the name.  By default all the Ada
   --  packages found in the model are generated.  When called, this enables the generation
   --  only for the Ada packages registered here.
   procedure Enable_Package_Generation (H    : in out Handler;
                                        Name : in String);

   --  Save the content generated by the template generator.
   procedure Save_Content (H       : in out Handler;
                           File    : in String;
                           Content : in Ada.Strings.Unbounded.Unbounded_String);

   --  Generate the code using the template file
   procedure Generate (H     : in out Handler;
                       Mode  : in Gen.Artifacts.Iteration_Mode;
                       File  : in String;
                       Save  : not null access
                         procedure (H       : in out Handler;
                                    File    : in String;
                                    Content : in Ada.Strings.Unbounded.Unbounded_String));

   --  Generate the code using the template file
   procedure Generate (H     : in out Handler;
                       File  : in String;
                       Model : in Gen.Model.Definition_Access;
                       Save  : not null access
                         procedure (H       : in out Handler;
                                    File    : in String;
                                    Content : in Ada.Strings.Unbounded.Unbounded_String));

   --  Generate all the code for the templates activated through Add_Generation.
   procedure Generate_All (H    : in out Handler);

   --  Generate all the code generation files stored in the directory
   procedure Generate_All (H    : in out Handler;
                           Mode : in Gen.Artifacts.Iteration_Mode;
                           Name : in String);

   --  Set the directory where template files are stored.
   procedure Set_Template_Directory (H    : in out Handler;
                                     Path : in Ada.Strings.Unbounded.Unbounded_String);

   --  Set the directory where results files are generated.
   procedure Set_Result_Directory (H    : in out Handler;
                                   Path : in String);

   --  Get the result directory path.
   function Get_Result_Directory (H : in Handler) return String;

   --  Get the project plugin directory path.
   function Get_Plugin_Directory (H : in Handler) return String;

   --  Get the config directory path.
   function Get_Config_Directory (H : in Handler) return String;

   --  Get the dynamo installation directory path.
   function Get_Install_Directory (H : in Handler) return String;

   --  Return the search directories that the AWA application can use to find files.
   --  The search directories is built by using the project dependencies.
   function Get_Search_Directories (H : in Handler) return String;

   --  Get the exit status
   --  Returns 0 if the generation was successful
   --  Returns 1 if there was a generation error
   function Get_Status (H : in Handler) return Ada.Command_Line.Exit_Status;

   --  Get the configuration parameter.
   function Get_Parameter (H       : in Handler;
                           Name    : in String;
                           Default : in String := "") return String;

   --  Get the configuration parameter.
   function Get_Parameter (H       : in Handler;
                           Name    : in String;
                           Default : in Boolean := False) return Boolean;

   --  Set the force-save file mode.  When False, if the generated file exists already,
   --  an error message is reported.
   procedure Set_Force_Save (H  : in out Handler;
                             To : in Boolean);

   --  Set the project name.
   procedure Set_Project_Name (H    : in out Handler;
                               Name : in String);

   --  Get the project name.
   function Get_Project_Name (H : in Handler) return String;

   --  Set the project property.
   procedure Set_Project_Property (H     : in out Handler;
                                   Name  : in String;
                                   Value : in String);

   --  Get the project property identified by the given name.  If the project property
   --  does not exist, returns the default value.  Project properties are loaded
   --  by Read_Project.
   function Get_Project_Property (H       : in Handler;
                                  Name    : in String;
                                  Default : in String := "") return String;

   --  Save the project description and parameters.
   procedure Save_Project (H : in out Handler);

   --  Get the path of the last generated file.
   function Get_Generated_File (H : in Handler) return String;

   --  Update the project model through the Process procedure.
   procedure Update_Project (H : in out Handler;
                             Process : not null access
                               procedure (P : in out Model.Projects.Root_Project_Definition));

   --  Scan the dynamo directories and execute the Process procedure with the
   --  directory path.
   procedure Scan_Directories (H : in Handler;
                               Process : not null access
                                 procedure (Dir : in String));

private

   use Ada.Strings.Unbounded;
   use Gen.Artifacts;

   type Template_Context is record
      Mode    : Gen.Artifacts.Iteration_Mode;
      Mapping : Unbounded_String;
   end record;

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

   type Handler is new ASF.Applications.Main.Application and Gen.Artifacts.Generator with record
      Conf       : ASF.Applications.Config;

      --  Config directory.
      Config_Dir : Ada.Strings.Unbounded.Unbounded_String;

      --  Output base directory.
      Output_Dir : Ada.Strings.Unbounded.Unbounded_String;

      Model  : aliased Gen.Model.Packages.Model_Definition;
      Status : Ada.Command_Line.Exit_Status := 0;

      --  The file that must be saved (the file attribute in <f:view>.
      File     : access Util.Beans.Objects.Object;

      --  Indicates whether the file must be saved at each generation or only once.
      --  This is the mode attribute in <f:view>.
      Mode     : access Util.Beans.Objects.Object;

      --  Indicates whether the file must be ignored after the generation.
      --  This is the ignore attribute in <f:view>.  It is intended to be used for the package
      --  body generation to skip that in some cases when it turns out there is no operation.
      Ignore   : access Util.Beans.Objects.Object;

      --  Whether the AdaMappings.xml file was loaded or not.
      Type_Mapping_Loaded : Boolean := False;

      --  The root project document.
      Project : aliased Gen.Model.Projects.Root_Project_Definition;

      --  Hibernate XML artifact
      Hibernate : Gen.Artifacts.Hibernate.Artifact;

      --  Query generation artifact.
      Query     : Gen.Artifacts.Query.Artifact;

      --  Type mapping artifact.
      Mappings  : Gen.Artifacts.Mappings.Artifact;

      --  The distribution artifact.
      Distrib   : Gen.Artifacts.Distribs.Artifact;

      --  Ada generation from UML-XMI models.
      XMI       : Gen.Artifacts.XMI.Artifact;

      --  The list of templates that must be generated.
      Templates : Template_Map.Map;

      --  Force the saving of a generated file, even if a file already exist.
      Force_Save : Boolean := True;
   end record;

   --  Execute the lifecycle phases on the faces context.
   overriding
   procedure Execute_Lifecycle (App     : in Handler;
                                Context : in out ASF.Contexts.Faces.Faces_Context'Class);

end Gen.Generator;

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

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

with Util.Beans.Objects;
with Util.Properties;

with ASF.Applications.Main;
with ASF.Contexts.Faces;

with Gen.Model.Packages;
with Gen.Model.Projects;
with Gen.Artifacts.Hibernate;
with Gen.Artifacts.Query;
with Gen.Artifacts.Mappings;
with Gen.Artifacts.Distribs;
with Gen.Artifacts.XMI;
package Gen.Generator is

   --  A fatal error that prevents the generator to proceed has occurred.
   Fatal_Error : exception;

   G_URI : constant String := "http://code.google.com/p/ada-ado/generator";

   type Package_Type is (PACKAGE_MODEL, PACKAGE_FORMS);

   type Mapping_File is record
      Path   : Ada.Strings.Unbounded.Unbounded_String;
      Output : Ada.Text_IO.File_Type;
   end record;

   type Handler is new ASF.Applications.Main.Application and Gen.Artifacts.Generator with private;

   --  Initialize the generator
   procedure Initialize (H : in out Handler;
                         Config_Dir : in Ada.Strings.Unbounded.Unbounded_String;
                         Debug : in Boolean);

   --  Get the configuration properties.
   function Get_Properties (H : in Handler) return Util.Properties.Manager;

   --  Report an error and set the exit status accordingly
   procedure Error (H : in out Handler;
                    Message : in String;
                    Arg1    : in String := "";
                    Arg2    : in String := "");

   --  Report an info message.
   procedure Info (H : in out Handler;
                   Message : in String;
                   Arg1    : in String := "";
                   Arg2    : in String := "";
                   Arg3    : in String := "");

   --  Read the XML package file
   procedure Read_Package (H    : in out Handler;
                           File : in String);

   --  Read the model mapping types and initialize the hibernate artifact.
   procedure Read_Mappings (H    : in out Handler);

   --  Read the XML model file
   procedure Read_Model (H      : in out Handler;
                         File   : in String;
                         Silent : in Boolean);

   --  Read the model and query files stored in the application directory db.
   procedure Read_Models (H : in out Handler;
                          Dirname : in String);

   --  Read the XML project file.  When Recursive is set, read the GNAT project
   --  files used by the main project and load all the dynamo.xml files defined
   --  by these project.
   procedure Read_Project (H         : in out Handler;
                           File      : in String;
                           Recursive : in Boolean := False);

   --  Prepare the model by checking, verifying and initializing it after it is completely known.
   procedure Prepare (H : in out Handler);

   --  Finish the generation.  Some artifacts could generate other files that take into
   --  account files generated previously.
   procedure Finish (H : in out Handler);

   --  Tell the generator to activate the generation of the given template name.
   --  The name is a property name that must be defined in generator.properties to
   --  indicate the template file.  Several artifacts can trigger the generation
   --  of a given template.  The template is generated only once.
   procedure Add_Generation (H    : in out Handler;
                             Name : in String;
                             Mode : in Gen.Artifacts.Iteration_Mode;
                             Mapping : in String);

   --  Enable the generation of the Ada package given by the name.  By default all the Ada
   --  packages found in the model are generated.  When called, this enables the generation
   --  only for the Ada packages registered here.
   procedure Enable_Package_Generation (H    : in out Handler;
                                        Name : in String);

   --  Save the content generated by the template generator.
   procedure Save_Content (H       : in out Handler;
                           File    : in String;
                           Content : in Ada.Strings.Unbounded.Unbounded_String);

   --  Generate the code using the template file
   procedure Generate (H     : in out Handler;
                       Mode  : in Gen.Artifacts.Iteration_Mode;
                       File  : in String;
                       Save  : not null access
                         procedure (H       : in out Handler;
                                    File    : in String;
                                    Content : in Ada.Strings.Unbounded.Unbounded_String));

   --  Generate the code using the template file
   procedure Generate (H     : in out Handler;
                       File  : in String;
                       Model : in Gen.Model.Definition_Access;
                       Save  : not null access
                         procedure (H       : in out Handler;
                                    File    : in String;
                                    Content : in Ada.Strings.Unbounded.Unbounded_String));

   --  Generate all the code for the templates activated through Add_Generation.
   procedure Generate_All (H    : in out Handler);

   --  Generate all the code generation files stored in the directory
   procedure Generate_All (H    : in out Handler;
                           Mode : in Gen.Artifacts.Iteration_Mode;
                           Name : in String);

   --  Set the directory where template files are stored.
   procedure Set_Template_Directory (H    : in out Handler;
                                     Path : in Ada.Strings.Unbounded.Unbounded_String);

   --  Set the directory where results files are generated.
   procedure Set_Result_Directory (H    : in out Handler;
                                   Path : in String);

   --  Get the result directory path.
   function Get_Result_Directory (H : in Handler) return String;

   --  Get the project plugin directory path.
   function Get_Plugin_Directory (H : in Handler) return String;

   --  Get the config directory path.
   function Get_Config_Directory (H : in Handler) return String;

   --  Get the dynamo installation directory path.
   function Get_Install_Directory (H : in Handler) return String;

   --  Return the search directories that the AWA application can use to find files.
   --  The search directories is built by using the project dependencies.
   function Get_Search_Directories (H : in Handler) return String;

   --  Get the exit status
   --  Returns 0 if the generation was successful
   --  Returns 1 if there was a generation error
   function Get_Status (H : in Handler) return Ada.Command_Line.Exit_Status;

   --  Get the configuration parameter.
   function Get_Parameter (H       : in Handler;
                           Name    : in String;
                           Default : in String := "") return String;

   --  Get the configuration parameter.
   function Get_Parameter (H       : in Handler;
                           Name    : in String;
                           Default : in Boolean := False) return Boolean;

   --  Set the force-save file mode.  When False, if the generated file exists already,
   --  an error message is reported.
   procedure Set_Force_Save (H  : in out Handler;
                             To : in Boolean);

   --  Set the project name.
   procedure Set_Project_Name (H    : in out Handler;
                               Name : in String);

   --  Get the project name.
   function Get_Project_Name (H : in Handler) return String;

   --  Set the project property.
   procedure Set_Project_Property (H     : in out Handler;
                                   Name  : in String;
                                   Value : in String);

   --  Get the project property identified by the given name.  If the project property
   --  does not exist, returns the default value.  Project properties are loaded
   --  by Read_Project.
   function Get_Project_Property (H       : in Handler;
                                  Name    : in String;
                                  Default : in String := "") return String;

   --  Save the project description and parameters.
   procedure Save_Project (H : in out Handler);

   --  Get the path of the last generated file.
   function Get_Generated_File (H : in Handler) return String;

   --  Update the project model through the Process procedure.
   procedure Update_Project (H : in out Handler;
                             Process : not null access
                               procedure (P : in out Model.Projects.Root_Project_Definition));

   --  Scan the dynamo directories and execute the Process procedure with the
   --  directory path.
   procedure Scan_Directories (H : in Handler;
                               Process : not null access
                                 procedure (Dir : in String));

private

   use Ada.Strings.Unbounded;
   use Gen.Artifacts;

   type Template_Context is record
      Mode    : Gen.Artifacts.Iteration_Mode;
      Mapping : Unbounded_String;
   end record;

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

   type Handler is new ASF.Applications.Main.Application and Gen.Artifacts.Generator with record
      Conf       : ASF.Applications.Config;

      --  Config directory.
      Config_Dir : Ada.Strings.Unbounded.Unbounded_String;

      --  Output base directory.
      Output_Dir : Ada.Strings.Unbounded.Unbounded_String;

      Model  : aliased Gen.Model.Packages.Model_Definition;
      Status : Ada.Command_Line.Exit_Status := 0;

      --  The file that must be saved (the file attribute in <f:view>.
      File     : access Util.Beans.Objects.Object;

      --  Indicates whether the file must be saved at each generation or only once.
      --  This is the mode attribute in <f:view>.
      Mode     : access Util.Beans.Objects.Object;

      --  Indicates whether the file must be ignored after the generation.
      --  This is the ignore attribute in <f:view>.  It is intended to be used for the package
      --  body generation to skip that in some cases when it turns out there is no operation.
      Ignore   : access Util.Beans.Objects.Object;

      --  Whether the AdaMappings.xml file was loaded or not.
      Type_Mapping_Loaded : Boolean := False;

      --  The root project document.
      Project : aliased Gen.Model.Projects.Root_Project_Definition;

      --  Hibernate XML artifact
      Hibernate : Gen.Artifacts.Hibernate.Artifact;

      --  Query generation artifact.
      Query     : Gen.Artifacts.Query.Artifact;

      --  Type mapping artifact.
      Mappings  : Gen.Artifacts.Mappings.Artifact;

      --  The distribution artifact.
      Distrib   : Gen.Artifacts.Distribs.Artifact;

      --  Ada generation from UML-XMI models.
      XMI       : Gen.Artifacts.XMI.Artifact;

      --  The list of templates that must be generated.
      Templates : Template_Map.Map;

      --  Force the saving of a generated file, even if a file already exist.
      Force_Save : Boolean := True;
   end record;

   --  Execute the lifecycle phases on the faces context.
   overriding
   procedure Execute_Lifecycle (App     : in Handler;
                                Context : in out ASF.Contexts.Faces.Faces_Context'Class);

end Gen.Generator;

Add an optional third string parameter to the Info procedure


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

with Util.Test_Caller;
with Util.Strings;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Principals;
with ASF.Tests;
with AWA.Users.Models;
with AWA.Services.Contexts;
with AWA.Tests.Helpers.Users;
with Security.Contexts;

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);
   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_Contains (T, "The post you are looking for does not exist",
                                 Reply, "Blog post missing page is invalid");

      if Post = "" then
         return;
      end if;

      ASF.Tests.Do_Get (Request, Reply, "/blogs/post.html?post=" & Post, "blog-post.html");
      ASF.Tests.Assert_Contains (T, "post-title", 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");
         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", "1");
      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 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 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);
   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_Contains (T, "The post you are looking for does not exist",
                                 Reply, "Blog post missing page is invalid");

      if Post = "" then
         return;
      end if;

      ASF.Tests.Do_Get (Request, Reply, "/blogs/post.html?post=" & Post, "blog-post.html");
      ASF.Tests.Assert_Contains (T, "post-title", 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");
         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", "1");
      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 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 compilation warnings

Fix compilation warnings


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

with Util.Processes;
with Util.Beans.Objects;
with Util.Log.Loggers;
with Util.Streams.Pipes;
with Util.Streams.Texts;
with Util.Strings;

with ADO.Sessions;

with AWA.Images.Models;
with AWA.Services.Contexts;
with AWA.Storages.Services;
with AWA.Storages.Modules;
with Ada.Strings.Unbounded;

with EL.Variables.Default;
with EL.Contexts.Default;

--  == Storage Service ==
--  The <tt>Storage_Service</tt> provides the operations to access and use the persisent storage.
--  It controls the permissions that grant access to the service for users.
--
--  Other modules can be notified of storage changes by registering a listener
--  on the storage module.
package body AWA.Images.Services is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Image Service
   --  ------------------------------

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

   --  ------------------------------
   --  Initializes the storage service.
   --  ------------------------------
   overriding
   procedure Initialize (Service : in out Image_Service;
                         Module  : in AWA.Modules.Module'Class) is
   begin
      AWA.Modules.Module_Manager (Service).Initialize (Module);

      Service.Thumbnail_Command := Module.Get_Config (PARAM_THUMBNAIL_COMMAND);
   end Initialize;

   procedure Create_Thumbnail (Service : in Image_Service;
                               Source  : in String;
                               Into    : in String;
                               Width   : in out Natural;
                               Height  : in out Natural) is
      Ctx       : EL.Contexts.Default.Default_Context;
      Variables : aliased EL.Variables.Default.Default_Variable_Mapper;

      Proc    : Util.Processes.Process;
      Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
   begin
      Variables.Bind ("src", Util.Beans.Objects.To_Object (Source));
      Variables.Bind ("dst", Util.Beans.Objects.To_Object (Into));
      Variables.Bind ("width", Util.Beans.Objects.To_Object (Width));
      Variables.Bind ("height", Util.Beans.Objects.To_Object (Height));
      Ctx.Set_Variable_Mapper (Variables'Unchecked_Access);
      declare
         Cmd     : constant Util.Beans.Objects.Object := Service.Thumbnail_Command.Get_Value (Ctx);
         Command : constant String := Util.Beans.Objects.To_String (Cmd);
         Input   : Util.Streams.Texts.Reader_Stream;
      begin
         Width  := 0;
         Height := 0;
         Pipe.Open (Command, Util.Processes.READ_ALL);
         Input.Initialize (null, Pipe'Unchecked_Access, 1024);
         while not Input.Is_Eof loop
            declare
               use Ada.Strings;

               Line : Ada.Strings.Unbounded.Unbounded_String;
               Pos  : Natural;
               Sep  : Natural;
               Last : Natural;
            begin
               Input.Read_Line (Into  => Line, Strip => False);
               exit when Ada.Strings.Unbounded.Length (Line) = 0;
               Log.Info ("Received: {0}", Line);

               --  The '-verbose' option of ImageMagick reports information about the original
               --  image.  Extract the picture width and height.
               --  image.png PNG 120x282 120x282+0+0 8-bit DirectClass 34.4KB 0.000u 0:00.018
               Pos := Ada.Strings.Unbounded.Index (Line, " ");
               if Pos > 0 and Width = 0 then
                  Pos := Ada.Strings.Unbounded.Index (Line, " ", Pos + 1);
                  if Pos > 0 then
                     Sep := Ada.Strings.Unbounded.Index (Line, "x", Pos + 1);
                     Last := Ada.Strings.Unbounded.Index (Line, "=", Pos + 1);
                     if Sep > 0 and Sep < Last then
                        Log.Info ("Dimension {0} - {1}..{2}",
                                  Ada.Strings.Unbounded.Slice (Line, Pos, Last),
                                  Natural'Image (Pos), Natural'Image (Last));
                        Width := Natural'Value (Unbounded.Slice (Line, Pos + 1, Sep - 1));
                        Height := Natural'Value (Unbounded.Slice (Line, Sep + 1, Last - 1));
                     end if;
                  end if;
               end if;
            end;
         end loop;
         Pipe.Close;

         Util.Processes.Wait (Proc);
         if Pipe.Get_Exit_Status /= 0 then
            Log.Error ("Command {0} exited with status {1}", Command,
                       Integer'Image (Pipe.Get_Exit_Status));
         end if;
      end;
   end Create_Thumbnail;

   --  Build a thumbnail for the image identified by the Id.
   procedure Build_Thumbnail (Service : in Image_Service;
                              Id      : in ADO.Identifier) is
      Storage_Service : constant AWA.Storages.Services.Storage_Service_Access
        := AWA.Storages.Modules.Get_Storage_Manager;
      Ctx         : constant ASC.Service_Context_Access := ASC.Current;
      DB          : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Img         : AWA.Images.Models.Image_Ref;
      Thumb       : AWA.Images.Models.Image_Ref;
      Target_File : AWA.Storages.Storage_File (AWA.Storages.TMP);
      Local_File  : AWA.Storages.Storage_File (AWA.Storages.CACHE);
      Thumbnail   : AWA.Storages.Models.Storage_Ref;
      Width       : Natural := 64;
      Height      : Natural := 64;
   begin
      Img.Load (DB, Id);
      declare
         Image_File : constant AWA.Storages.Models.Storage_Ref'Class := Img.Get_Storage;
      begin
         Storage_Service.Get_Local_File (From => Image_File.Get_Id, Into => Local_File);
         Storage_Service.Create_Local_File (Target_File);

         Service.Create_Thumbnail (AWA.Storages.Get_Path (Local_File),
                                   AWA.Storages.Get_Path (Target_File), Width, Height);
         Thumbnail.Set_Mime_Type ("image/jpeg");
         Thumbnail.Set_Original (Image_File);
         Thumbnail.Set_Workspace (Image_File.Get_Workspace);
         Thumbnail.Set_Folder (Image_File.Get_Folder);
         Thumbnail.Set_Owner (Image_File.Get_Owner);
         Thumbnail.Set_Name (String '(Image_File.Get_Name));
         Storage_Service.Save (Thumbnail, AWA.Storages.Get_Path (Target_File),
                               AWA.Storages.Models.DATABASE);
         Thumb.Set_Width (64);
         Thumb.Set_Height (64);
         Thumb.Set_Owner (Image_File.Get_Owner);
         Thumb.Set_Folder (Image_File.Get_Folder);
         Thumb.Set_Storage (Thumbnail);
         Img.Set_Width (Width);
         Img.Set_Height (Height);
         Img.Set_Thumb_Width (64);
         Img.Set_Thumb_Height (64);
         Img.Set_Thumbnail (Thumbnail);
         Ctx.Start;
         Img.Save (DB);
         Thumb.Save (DB);
         Ctx.Commit;
      end;
   end Build_Thumbnail;

   --  Save the data object contained in the Data part element into the
   --  target storage represented by Into.
   procedure Create_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
      pragma Unreferenced (Service);

      Ctx : constant AWA.Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB  : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Img : AWA.Images.Models.Image_Ref;
   begin
      Ctx.Start;
      Img.Set_Width (0);
      Img.Set_Height (0);
      Img.Set_Thumb_Height (0);
      Img.Set_Thumb_Width (0);
      Img.Set_Storage (File);
      Img.Set_Folder (File.Get_Folder);
      Img.Set_Owner (File.Get_Owner);
      Img.Save (DB);
      Ctx.Commit;
   end Create_Image;

   --  Deletes the storage instance.
   procedure Delete_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
   begin
      null;
   end Delete_Image;

   --  ------------------------------
   --  Scale the image dimension.
   --  ------------------------------
   procedure Scale (Width     : in Natural;
                    Height    : in Natural;
                    To_Width  : in out Natural;
                    To_Height : in out Natural) is
   begin
      if To_Width = Natural'Last or To_Height = Natural'Last
        or (To_Width = 0 and To_Height = 0)
      then
         To_Width  := Width;
         To_Height := Height;
      elsif To_Width = 0 then
         To_Width := (Width * To_Height) / Height;
      elsif To_Height = 0 then
         To_Height := (Height * To_Width) / Width;
      end if;
   end Scale;

   --  ------------------------------
   --  Get the dimension represented by the string.  The string has one of the following
   --  formats:
   --    original          -> Width, Height := Natural'Last
   --    default           -> Width, Height := 0
   --    <width>x          -> Width := <width>, Height := 0
   --    x<height>         -> Width := 0, Height := <height>
   --    <width>x<height>  -> Width := <width>, Height := <height>
   --  ------------------------------
   procedure Get_Sizes (Dimension : in String;
                        Width     : out Natural;
                        Height    : out Natural) is
      Pos : Natural;
   begin
      if Dimension = "original" then
         Width  := Natural'Last;
         Height := Natural'Last;
      elsif Dimension = "default" then
         Width  := 800;
         Height := 0;
      else
         Pos := Util.Strings.Index (Dimension, 'x');
         if Pos > Dimension'First then
            Width := Natural'Value (Dimension (Dimension'First .. Pos - 1));
         else
            Width := 0;
         end if;
         if Pos < Dimension'Last then
            Height := Natural'Value (Dimension (Pos + 1 .. Dimension'Last));
         else
            Height := 0;
         end if;
      end if;
   end Get_Sizes;

end AWA.Images.Services;

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

with Util.Processes;
with Util.Beans.Objects;
with Util.Log.Loggers;
with Util.Streams.Pipes;
with Util.Streams.Texts;
with Util.Strings;

with ADO.Sessions;

with AWA.Images.Models;
with AWA.Services.Contexts;
with AWA.Storages.Services;
with AWA.Storages.Modules;
with Ada.Strings.Unbounded;

with EL.Variables.Default;
with EL.Contexts.Default;

--  == Storage Service ==
--  The <tt>Storage_Service</tt> provides the operations to access and use the persisent storage.
--  It controls the permissions that grant access to the service for users.
--
--  Other modules can be notified of storage changes by registering a listener
--  on the storage module.
package body AWA.Images.Services is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Image Service
   --  ------------------------------

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

   --  ------------------------------
   --  Initializes the storage service.
   --  ------------------------------
   overriding
   procedure Initialize (Service : in out Image_Service;
                         Module  : in AWA.Modules.Module'Class) is
   begin
      AWA.Modules.Module_Manager (Service).Initialize (Module);

      Service.Thumbnail_Command := Module.Get_Config (PARAM_THUMBNAIL_COMMAND);
   end Initialize;

   procedure Create_Thumbnail (Service : in Image_Service;
                               Source  : in String;
                               Into    : in String;
                               Width   : in out Natural;
                               Height  : in out Natural) is
      Ctx       : EL.Contexts.Default.Default_Context;
      Variables : aliased EL.Variables.Default.Default_Variable_Mapper;

      Proc    : Util.Processes.Process;
      Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
   begin
      Variables.Bind ("src", Util.Beans.Objects.To_Object (Source));
      Variables.Bind ("dst", Util.Beans.Objects.To_Object (Into));
      Variables.Bind ("width", Util.Beans.Objects.To_Object (Width));
      Variables.Bind ("height", Util.Beans.Objects.To_Object (Height));
      Ctx.Set_Variable_Mapper (Variables'Unchecked_Access);
      declare
         Cmd     : constant Util.Beans.Objects.Object := Service.Thumbnail_Command.Get_Value (Ctx);
         Command : constant String := Util.Beans.Objects.To_String (Cmd);
         Input   : Util.Streams.Texts.Reader_Stream;
      begin
         Width  := 0;
         Height := 0;
         Pipe.Open (Command, Util.Processes.READ_ALL);
         Input.Initialize (Pipe'Unchecked_Access, 1024);
         while not Input.Is_Eof loop
            declare
               use Ada.Strings;

               Line : Ada.Strings.Unbounded.Unbounded_String;
               Pos  : Natural;
               Sep  : Natural;
               Last : Natural;
            begin
               Input.Read_Line (Into  => Line, Strip => False);
               exit when Ada.Strings.Unbounded.Length (Line) = 0;
               Log.Info ("Received: {0}", Line);

               --  The '-verbose' option of ImageMagick reports information about the original
               --  image.  Extract the picture width and height.
               --  image.png PNG 120x282 120x282+0+0 8-bit DirectClass 34.4KB 0.000u 0:00.018
               Pos := Ada.Strings.Unbounded.Index (Line, " ");
               if Pos > 0 and Width = 0 then
                  Pos := Ada.Strings.Unbounded.Index (Line, " ", Pos + 1);
                  if Pos > 0 then
                     Sep := Ada.Strings.Unbounded.Index (Line, "x", Pos + 1);
                     Last := Ada.Strings.Unbounded.Index (Line, "=", Pos + 1);
                     if Sep > 0 and Sep < Last then
                        Log.Info ("Dimension {0} - {1}..{2}",
                                  Ada.Strings.Unbounded.Slice (Line, Pos, Last),
                                  Natural'Image (Pos), Natural'Image (Last));
                        Width := Natural'Value (Unbounded.Slice (Line, Pos + 1, Sep - 1));
                        Height := Natural'Value (Unbounded.Slice (Line, Sep + 1, Last - 1));
                     end if;
                  end if;
               end if;
            end;
         end loop;
         Pipe.Close;

         Util.Processes.Wait (Proc);
         if Pipe.Get_Exit_Status /= 0 then
            Log.Error ("Command {0} exited with status {1}", Command,
                       Integer'Image (Pipe.Get_Exit_Status));
         end if;
      end;
   end Create_Thumbnail;

   --  Build a thumbnail for the image identified by the Id.
   procedure Build_Thumbnail (Service : in Image_Service;
                              Id      : in ADO.Identifier) is
      Storage_Service : constant AWA.Storages.Services.Storage_Service_Access
        := AWA.Storages.Modules.Get_Storage_Manager;
      Ctx         : constant ASC.Service_Context_Access := ASC.Current;
      DB          : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Img         : AWA.Images.Models.Image_Ref;
      Thumb       : AWA.Images.Models.Image_Ref;
      Target_File : AWA.Storages.Storage_File (AWA.Storages.TMP);
      Local_File  : AWA.Storages.Storage_File (AWA.Storages.CACHE);
      Thumbnail   : AWA.Storages.Models.Storage_Ref;
      Width       : Natural := 64;
      Height      : Natural := 64;
   begin
      Img.Load (DB, Id);
      declare
         Image_File : constant AWA.Storages.Models.Storage_Ref'Class := Img.Get_Storage;
      begin
         Storage_Service.Get_Local_File (From => Image_File.Get_Id, Into => Local_File);
         Storage_Service.Create_Local_File (Target_File);

         Service.Create_Thumbnail (AWA.Storages.Get_Path (Local_File),
                                   AWA.Storages.Get_Path (Target_File), Width, Height);
         Thumbnail.Set_Mime_Type ("image/jpeg");
         Thumbnail.Set_Original (Image_File);
         Thumbnail.Set_Workspace (Image_File.Get_Workspace);
         Thumbnail.Set_Folder (Image_File.Get_Folder);
         Thumbnail.Set_Owner (Image_File.Get_Owner);
         Thumbnail.Set_Name (String '(Image_File.Get_Name));
         Storage_Service.Save (Thumbnail, AWA.Storages.Get_Path (Target_File),
                               AWA.Storages.Models.DATABASE);
         Thumb.Set_Width (64);
         Thumb.Set_Height (64);
         Thumb.Set_Owner (Image_File.Get_Owner);
         Thumb.Set_Folder (Image_File.Get_Folder);
         Thumb.Set_Storage (Thumbnail);
         Img.Set_Width (Width);
         Img.Set_Height (Height);
         Img.Set_Thumb_Width (64);
         Img.Set_Thumb_Height (64);
         Img.Set_Thumbnail (Thumbnail);
         Ctx.Start;
         Img.Save (DB);
         Thumb.Save (DB);
         Ctx.Commit;
      end;
   end Build_Thumbnail;

   --  Save the data object contained in the Data part element into the
   --  target storage represented by Into.
   procedure Create_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
      pragma Unreferenced (Service);

      Ctx : constant AWA.Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB  : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Img : AWA.Images.Models.Image_Ref;
   begin
      Ctx.Start;
      Img.Set_Width (0);
      Img.Set_Height (0);
      Img.Set_Thumb_Height (0);
      Img.Set_Thumb_Width (0);
      Img.Set_Storage (File);
      Img.Set_Folder (File.Get_Folder);
      Img.Set_Owner (File.Get_Owner);
      Img.Save (DB);
      Ctx.Commit;
   end Create_Image;

   --  Deletes the storage instance.
   procedure Delete_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
   begin
      null;
   end Delete_Image;

   --  ------------------------------
   --  Scale the image dimension.
   --  ------------------------------
   procedure Scale (Width     : in Natural;
                    Height    : in Natural;
                    To_Width  : in out Natural;
                    To_Height : in out Natural) is
   begin
      if To_Width = Natural'Last or To_Height = Natural'Last
        or (To_Width = 0 and To_Height = 0)
      then
         To_Width  := Width;
         To_Height := Height;
      elsif To_Width = 0 then
         To_Width := (Width * To_Height) / Height;
      elsif To_Height = 0 then
         To_Height := (Height * To_Width) / Width;
      end if;
   end Scale;

   --  ------------------------------
   --  Get the dimension represented by the string.  The string has one of the following
   --  formats:
   --    original          -> Width, Height := Natural'Last
   --    default           -> Width, Height := 0
   --    <width>x          -> Width := <width>, Height := 0
   --    x<height>         -> Width := 0, Height := <height>
   --    <width>x<height>  -> Width := <width>, Height := <height>
   --  ------------------------------
   procedure Get_Sizes (Dimension : in String;
                        Width     : out Natural;
                        Height    : out Natural) is
      Pos : Natural;
   begin
      if Dimension = "original" then
         Width  := Natural'Last;
         Height := Natural'Last;
      elsif Dimension = "default" then
         Width  := 800;
         Height := 0;
      else
         Pos := Util.Strings.Index (Dimension, 'x');
         if Pos > Dimension'First then
            Width := Natural'Value (Dimension (Dimension'First .. Pos - 1));
         else
            Width := 0;
         end if;
         if Pos < Dimension'Last then
            Height := Natural'Value (Dimension (Pos + 1 .. Dimension'Last));
         else
            Height := 0;
         end if;
      end if;
   end Get_Sizes;

end AWA.Images.Services;

Update initialization of input reader stream