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

with Ada.Strings.Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;

with ADO;

with AWA.Blogs.Modules;
with AWA.Blogs.Models;
package AWA.Blogs.Beans is

   --  Attributes exposed by Post_Bean
   BLOG_ID_ATTR      : constant String := "blogId";
   POST_ID_ATTR      : constant String := "id";
   POST_TITLE_ATTR   : constant String := "title";
   POST_TEXT_ATTR    : constant String := "text";
   POST_URI_ATTR     : constant String := "uri";
   POST_STATUS_ATTR  : constant String := "status";
   POST_USERNAME_ATTR : constant String := "username";

   --  ------------------------------
   --  Blog Bean
   --  ------------------------------
   --  The Blog_Bean holds the information about the current blog.
   --  It allows to create the blog as well as update its primary title.
   type Blog_Bean is new AWA.Blogs.Models.Blog_Bean with record
      Module  : AWA.Blogs.Modules.Blog_Module_Access := null;
   end record;
   type Blog_Bean_Access is access all Blog_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Blog_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Blog_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Create a new blog.
   overriding
   procedure Create (Bean    : in out Blog_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   type Post_Bean is new AWA.Blogs.Models.Post_Bean with record
      Module  : AWA.Blogs.Modules.Blog_Module_Access := null;
      Blog_Id : ADO.Identifier;
   end record;
   type Post_Bean_Access is access all Post_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Post_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Post_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the post.
   procedure Load_Post (Post : in out Post_Bean;
                        Id   : in ADO.Identifier);

   --  Create or save the post.
   overriding
   procedure Save (Bean    : in out Post_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Delete a post.
   overriding
   procedure Delete (Bean    : in out Post_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Blog_Bean bean instance.
   function Create_Blog_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Post_Bean bean instance.
   function Create_Post_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Post_List_Bean bean instance.
   function Create_Post_List_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Blog_Admin_Bean bean instance.
   function Create_Blog_Admin_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access;

   --  Get a select item list which contains a list of post status.
   function Create_Status_List (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access;

   type Init_Flag is (INIT_BLOG_LIST, INIT_POST_LIST);
   type Init_Map is array (Init_Flag) of Boolean;

   type Blog_Admin_Bean is new Util.Beans.Basic.Bean with record
      Module : AWA.Blogs.Modules.Blog_Module_Access := null;

      --  The blog identifier.
      Blog_Id          : ADO.Identifier := ADO.NO_IDENTIFIER;

      --  List of blogs.
      Blog_List        : aliased AWA.Blogs.Models.Blog_Info_List_Bean;
      Blog_List_Bean   : AWA.Blogs.Models.Blog_Info_List_Bean_Access;

      --  List of posts.
      Post_List        : aliased AWA.Blogs.Models.Admin_Post_Info_List_Bean;
      Post_List_Bean   : AWA.Blogs.Models.Admin_Post_Info_List_Bean_Access;

      --  Initialization flags.
      Init_Flags       : aliased Init_Map := (others => False);
      Flags            : access Init_Map;
   end record;
   type Blog_Admin_Bean_Access is access all Blog_Admin_Bean;

   --  Get the blog identifier.
   function Get_Blog_Id (List : in Blog_Admin_Bean) return ADO.Identifier;

   --  Load the posts associated with the current blog.
   procedure Load_Posts (List : in Blog_Admin_Bean);

   overriding
   function Get_Value (List : in Blog_Admin_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Blog_Admin_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the list of blogs.
   procedure Load_Blogs (List : in Blog_Admin_Bean);

end AWA.Blogs.Beans;

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

with Ada.Strings.Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;

with ADO;

with AWA.Blogs.Modules;
with AWA.Blogs.Models;
with AWA.Tags.Beans;
package AWA.Blogs.Beans is

   --  Attributes exposed by Post_Bean
   BLOG_ID_ATTR      : constant String := "blogId";
   POST_ID_ATTR      : constant String := "id";
   POST_TITLE_ATTR   : constant String := "title";
   POST_TEXT_ATTR    : constant String := "text";
   POST_URI_ATTR     : constant String := "uri";
   POST_STATUS_ATTR  : constant String := "status";
   POST_USERNAME_ATTR : constant String := "username";
   POST_TAG_ATTR      : constant String := "tags";

   --  ------------------------------
   --  Blog Bean
   --  ------------------------------
   --  The Blog_Bean holds the information about the current blog.
   --  It allows to create the blog as well as update its primary title.
   type Blog_Bean is new AWA.Blogs.Models.Blog_Bean with record
      Module  : AWA.Blogs.Modules.Blog_Module_Access := null;
   end record;
   type Blog_Bean_Access is access all Blog_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Blog_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Blog_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Create a new blog.
   overriding
   procedure Create (Bean    : in out Blog_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   type Post_Bean is new AWA.Blogs.Models.Post_Bean with record
      Module  : AWA.Blogs.Modules.Blog_Module_Access := null;
      Blog_Id : ADO.Identifier;

      --  List of tags associated with the post.
      Tags      : aliased AWA.Tags.Beans.Tag_List_Bean;
      Tags_Bean : Util.Beans.Basic.Readonly_Bean_Access;
   end record;
   type Post_Bean_Access is access all Post_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Post_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Post_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the post.
   procedure Load_Post (Post : in out Post_Bean;
                        Id   : in ADO.Identifier);

   --  Create or save the post.
   overriding
   procedure Save (Bean    : in out Post_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Delete a post.
   overriding
   procedure Delete (Bean    : in out Post_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Blog_Bean bean instance.
   function Create_Blog_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Post_Bean bean instance.
   function Create_Post_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Post_List_Bean bean instance.
   function Create_Post_List_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Blog_Admin_Bean bean instance.
   function Create_Blog_Admin_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access;

   --  Get a select item list which contains a list of post status.
   function Create_Status_List (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access;

   type Init_Flag is (INIT_BLOG_LIST, INIT_POST_LIST);
   type Init_Map is array (Init_Flag) of Boolean;

   type Blog_Admin_Bean is new Util.Beans.Basic.Bean with record
      Module : AWA.Blogs.Modules.Blog_Module_Access := null;

      --  The blog identifier.
      Blog_Id          : ADO.Identifier := ADO.NO_IDENTIFIER;

      --  List of blogs.
      Blog_List        : aliased AWA.Blogs.Models.Blog_Info_List_Bean;
      Blog_List_Bean   : AWA.Blogs.Models.Blog_Info_List_Bean_Access;

      --  List of posts.
      Post_List        : aliased AWA.Blogs.Models.Admin_Post_Info_List_Bean;
      Post_List_Bean   : AWA.Blogs.Models.Admin_Post_Info_List_Bean_Access;

      --  Initialization flags.
      Init_Flags       : aliased Init_Map := (others => False);
      Flags            : access Init_Map;
   end record;
   type Blog_Admin_Bean_Access is access all Blog_Admin_Bean;

   --  Get the blog identifier.
   function Get_Blog_Id (List : in Blog_Admin_Bean) return ADO.Identifier;

   --  Load the posts associated with the current blog.
   procedure Load_Posts (List : in Blog_Admin_Bean);

   overriding
   function Get_Value (List : in Blog_Admin_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Blog_Admin_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the list of blogs.
   procedure Load_Blogs (List : in Blog_Admin_Bean);

end AWA.Blogs.Beans;

Add a list of tags to the post

Add a list of tags to the post


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

with AWA.Modules.Beans;
with AWA.Modules.Get;
with AWA.Mail.Beans;
with AWA.Mail.Components.Factory;
with AWA.Applications;

with Security;
with Servlet.Core;
with Servlet.Sessions;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with Util.Beans.Basic;
with Util.Beans.Objects;
with Util.Log.Loggers;

package body AWA.Mail.Modules is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Mail.Module");

   package Register is new AWA.Modules.Beans (Module => Mail_Module,
                                              Module_Access => Mail_Module_Access);

   type Mail_Principal is new Security.Principal with null record;

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

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   overriding
   function Get_Name (From : in Mail_Principal) return String is
      pragma Unreferenced (From);
   begin
      return "AWA Mailer";
   end Get_Name;

   --  ------------------------------
   --  Initialize the mail module.
   --  ------------------------------
   overriding
   procedure Initialize (Plugin : in out Mail_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config) is
   begin
      Log.Info ("Initializing the mail module");

      --  Add the Mail UI components.
      App.Add_Components (AWA.Mail.Components.Factory.Definition);

      --  Register here any bean class, servlet, filter.
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Mail.Beans.Mail_Bean",
                         Handler => AWA.Mail.Beans.Create_Mail_Bean'Access);

      AWA.Modules.Module (Plugin).Initialize (App, Props);
   end Initialize;

   --  ------------------------------
   --  Configures the module after its initialization and after having read its XML configuration.
   --  ------------------------------
   overriding
   procedure Configure (Plugin : in out Mail_Module;
                        Props  : in ASF.Applications.Config) is
      Mailer : constant String := Props.Get ("mailer", "smtp");
   begin
      Log.Info ("Mail plugin is using {0} mailer", Mailer);
      Plugin.Mailer := AWA.Mail.Clients.Factory (Mailer, Props);
   end Configure;

   --  ------------------------------
   --  Create a new mail message.
   --  ------------------------------
   function Create_Message (Plugin : in Mail_Module)
                            return AWA.Mail.Clients.Mail_Message_Access is
   begin
      return Plugin.Mailer.Create_Message;
   end Create_Message;

   --  ------------------------------
   --  Receive an event sent by another module with <b>Send_Event</b> method.
   --  Format and send an email.
   --  ------------------------------
   procedure Send_Mail (Plugin   : in Mail_Module;
                        Template : in String;
                        Props    : in Util.Beans.Objects.Maps.Map;
                        Content  : in AWA.Events.Module_Event'Class) is
      Name       : constant String := Content.Get_Parameter ("name");
      Locale     : constant String := Content.Get_Parameter ("locale");
      App     : constant AWA.Modules.Application_Access := Plugin.Get_Application;
   begin
      Log.Info ("Receive event {0} with template {1}", Name, Template);

      if Template = "" then
         Log.Debug ("No email template associated with event {0}", Name);
         return;
      end if;

      declare
         Req     : ASF.Requests.Mockup.Request;
         Reply   : ASF.Responses.Mockup.Response;
         Session : Servlet.Sessions.Session;
         Ptr     : constant Util.Beans.Basic.Readonly_Bean_Access := Content'Unrestricted_Access;
         Bean    : constant Util.Beans.Objects.Object
           := Util.Beans.Objects.To_Object (Ptr, Util.Beans.Objects.STATIC);
         Dispatcher : constant Servlet.Core.Request_Dispatcher
           := App.Get_Request_Dispatcher (Template);
      begin
         App.Create_Session (Session);
         Session.Set_Principal (new Mail_Principal);

         Req.Set_Session (Session);
         Req.Set_Request_URI (Template);
         Req.Set_Method ("GET");
         Req.Set_Attribute (Name => "event", Value => Bean);
         Req.Set_Attributes (Props);
         if Locale'Length > 0 then
            Req.Set_Header ("Accept-Language", Locale);
         end if;
         Servlet.Core.Forward (Dispatcher, Req, Reply);
         App.Delete_Session (Session);
      end;
   end Send_Mail;

   --  ------------------------------
   --  Get the mail module instance associated with the current application.
   --  ------------------------------
   function Get_Mail_Module return Mail_Module_Access is
      function Get is new AWA.Modules.Get (Mail_Module, Mail_Module_Access, NAME);
   begin
      return Get;
   end Get_Mail_Module;

end AWA.Mail.Modules;

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

with AWA.Modules.Beans;
with AWA.Modules.Get;
with AWA.Mail.Beans;
with AWA.Mail.Components.Factory;
with AWA.Applications;

with Security;
with Servlet.Core;
with Servlet.Sessions;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with Util.Beans.Basic;
with Util.Beans.Objects;
with Util.Log.Loggers;

package body AWA.Mail.Modules is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Mail.Module");

   package Register is new AWA.Modules.Beans (Module => Mail_Module,
                                              Module_Access => Mail_Module_Access);

   type Mail_Principal is new Security.Principal with null record;

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

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   overriding
   function Get_Name (From : in Mail_Principal) return String is
      pragma Unreferenced (From);
   begin
      return "AWA Mailer";
   end Get_Name;

   --  ------------------------------
   --  Initialize the mail module.
   --  ------------------------------
   overriding
   procedure Initialize (Plugin : in out Mail_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config) is
   begin
      Log.Info ("Initializing the mail module");

      --  Add the Mail UI components.
      App.Add_Components (AWA.Mail.Components.Factory.Definition);

      --  Register here any bean class, servlet, filter.
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Mail.Beans.Mail_Bean",
                         Handler => AWA.Mail.Beans.Create_Mail_Bean'Access);

      AWA.Modules.Module (Plugin).Initialize (App, Props);
   end Initialize;

   --  ------------------------------
   --  Configures the module after its initialization and after having read its XML configuration.
   --  ------------------------------
   overriding
   procedure Configure (Plugin : in out Mail_Module;
                        Props  : in ASF.Applications.Config) is
      Mailer : constant String := Props.Get ("mailer", "smtp");
   begin
      Log.Info ("Mail plugin is using {0} mailer", Mailer);
      Plugin.Mailer := AWA.Mail.Clients.Factory (Mailer, Props);
   end Configure;

   --  ------------------------------
   --  Create a new mail message.
   --  ------------------------------
   function Create_Message (Plugin : in Mail_Module)
                            return AWA.Mail.Clients.Mail_Message_Access is
   begin
      return Plugin.Mailer.Create_Message;
   end Create_Message;

   --  ------------------------------
   --  Receive an event sent by another module with <b>Send_Event</b> method.
   --  Format and send an email.
   --  ------------------------------
   procedure Send_Mail (Plugin   : in Mail_Module;
                        Template : in String;
                        Props    : in Util.Beans.Objects.Maps.Map;
                        Params   : in Util.Beans.Objects.Maps.Map;
                        Content  : in AWA.Events.Module_Event'Class) is
      Name       : constant String := Content.Get_Parameter ("name");
      Locale     : constant String := Content.Get_Parameter ("locale");
      App     : constant AWA.Modules.Application_Access := Plugin.Get_Application;
   begin
      Log.Info ("Receive event {0} with template {1}", Name, Template);

      if Template = "" then
         Log.Debug ("No email template associated with event {0}", Name);
         return;
      end if;

      declare
         use Util.Beans.Objects;

         Req     : ASF.Requests.Mockup.Request;
         Reply   : ASF.Responses.Mockup.Response;
         Session : Servlet.Sessions.Session;
         Ptr     : constant Util.Beans.Basic.Readonly_Bean_Access := Content'Unrestricted_Access;
         Bean    : constant Object := To_Object (Ptr, STATIC);
         Dispatcher : constant Servlet.Core.Request_Dispatcher
           := App.Get_Request_Dispatcher (Template);
         Iter : Maps.Cursor := Params.First;
      begin
         App.Create_Session (Session);
         Session.Set_Principal (new Mail_Principal);

         Req.Set_Session (Session);
         Req.Set_Request_URI (Template);
         Req.Set_Method ("GET");
         Req.Set_Attribute (Name => "event", Value => Bean);
         Req.Set_Attributes (Props);
         if Locale'Length > 0 then
            Req.Set_Header ("Accept-Language", Locale);
         end if;

         --  Setup the request parameters.
         while Maps.Has_Element (Iter) loop
            Req.Set_Parameter (Maps.Key (Iter), To_String (Maps.Element (Iter)));
            Maps.Next (Iter);
         end loop;
         Servlet.Core.Forward (Dispatcher, Req, Reply);
         App.Delete_Session (Session);
      end;
   end Send_Mail;

   --  ------------------------------
   --  Get the mail module instance associated with the current application.
   --  ------------------------------
   function Get_Mail_Module return Mail_Module_Access is
      function Get is new AWA.Modules.Get (Mail_Module, Mail_Module_Access, NAME);
   begin
      return Get;
   end Get_Mail_Module;

end AWA.Mail.Modules;

Update Send_Mail to setup some request parameters by using the new Params parameter


-----------------------------------------------------------------------
--  awa-wikis-servlets -- Serve files saved in the storage service
--  Copyright (C) 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 Ada.Strings.Unbounded;
with Ada.Calendar;

with Util.Log.Loggers;

with ADO.Objects;

with ASF.Streams;

with AWA.Wikis.Modules;
package body AWA.Wikis.Servlets is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Wikis.Servlets");

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   overriding
   procedure Initialize (Server  : in out Image_Servlet;
                         Context : in ASF.Servlets.Servlet_Registry'Class) is
   begin
      null;
   end Initialize;

   --  ------------------------------
   --  Called by the server (via the service method) to allow a servlet to handle
   --  a GET request.
   --
   --  Overriding this method to support a GET request also automatically supports
   --  an HTTP HEAD request. A HEAD request is a GET request that returns no body
   --  in the response, only the request header fields.
   --
   --  When overriding this method, read the request data, write the response headers,
   --  get the response's writer or output stream object, and finally, write the
   --  response data. It's best to include content type and encoding.
   --  When using a PrintWriter object to return the response, set the content type
   --  before accessing the PrintWriter object.
   --
   --  The servlet container must write the headers before committing the response,
   --  because in HTTP the headers must be sent before the response body.
   --
   --  Where possible, set the Content-Length header (with the
   --  Response.Set_Content_Length method), to allow the servlet container
   --  to use a persistent connection to return its response to the client,
   --  improving performance. The content length is automatically set if the entire
   --  response fits inside the response buffer.
   --
   --  When using HTTP 1.1 chunked encoding (which means that the response has a
   --  Transfer-Encoding header), do not set the Content-Length header.
   --
   --  The GET method should be safe, that is, without any side effects for which
   --  users are held responsible. For example, most form queries have no side effects.
   --  If a client request is intended to change stored data, the request should use
   --  some other HTTP method.
   --
   --  The GET method should also be idempotent, meaning that it can be safely repeated.
   --  Sometimes making a method safe also makes it idempotent. For example, repeating
   --  queries is both safe and idempotent, but buying a product online or modifying
   --  data is neither safe nor idempotent.
   --
   --  If the request is incorrectly formatted, Do_Get  returns an HTTP "Bad Request"
   --  ------------------------------
   overriding
   procedure Do_Get (Server   : in Image_Servlet;
                     Request  : in out ASF.Requests.Request'Class;
                     Response : in out ASF.Responses.Response'Class) is
      pragma Unreferenced (Server);

      Data    : ADO.Blob_Ref;
      Mime    : Ada.Strings.Unbounded.Unbounded_String;
      Date    : Ada.Calendar.Time;
      Module  : constant AWA.Wikis.Modules.Wiki_Module_Access := Wikis.Modules.Get_Wiki_Module;
      Wiki    : constant String := Request.Get_Path_Parameter (1);
      File    : constant String := Request.Get_Path_Parameter (2);
      Name    : constant String := Request.Get_Path_Parameter (3);
      Wiki_Id : ADO.Identifier;
      File_Id : ADO.Identifier;
   begin
      Wiki_Id := ADO.Identifier'Value (Wiki);
      File_Id := ADO.Identifier'Value (File);

      Log.Info ("GET storage file {0}/{1}/{2}", Wiki, File, Name);
      Module.Load_Image (Wiki_Id  => Wiki_Id,
                         Image_Id => File_Id,
                         Mime     => Mime,
                         Date     => Date,
                         Into     => Data);

      --  Send the file.
      Response.Set_Content_Type (Ada.Strings.Unbounded.To_String (Mime));
      declare
         Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
      begin
         Output.Write (Data.Value.Data);
      end;

   exception
      when ADO.Objects.NOT_FOUND | Constraint_Error =>
         Log.Info ("Storage file {0}/{1}/{2} not found", Wiki, File, Name);
         Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         return;
   end Do_Get;

end AWA.Wikis.Servlets;

-----------------------------------------------------------------------
--  awa-wikis-servlets -- Serve files saved in the storage service
--  Copyright (C) 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.Log.Loggers;

with AWA.Images.Services;
with AWA.Wikis.Modules;
package body AWA.Wikis.Servlets is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Wikis.Servlets");

   --  ------------------------------
   --  Load the data content that correspond to the GET request and get the name as well
   --  as mime-type and date.
   --  ------------------------------
   overriding
   procedure Load (Server   : in Image_Servlet;
                   Request  : in out ASF.Requests.Request'Class;
                   Name     : out Ada.Strings.Unbounded.Unbounded_String;
                   Mime     : out Ada.Strings.Unbounded.Unbounded_String;
                   Date     : out Ada.Calendar.Time;
                   Data     : out ADO.Blob_Ref) is
      Wiki      : constant String := Request.Get_Path_Parameter (1);
      File      : constant String := Request.Get_Path_Parameter (2);
      Size      : constant String := Request.Get_Path_Parameter (3);
      File_Name : constant String := Request.Get_Path_Parameter (4);
      Module    : constant AWA.Wikis.Modules.Wiki_Module_Access := Wikis.Modules.Get_Wiki_Module;
      Wiki_Id   : ADO.Identifier;
      File_Id   : ADO.Identifier;
      Width     : Natural;
      Height    : Natural;
   begin
      Wiki_Id := ADO.Identifier'Value (Wiki);
      File_Id := ADO.Identifier'Value (File);

      AWA.Images.Services.Get_Sizes (Dimension => Size,
                                     Width     => Width,
                                     Height    => Height);

      Module.Load_Image (Wiki_Id  => Wiki_Id,
                         Image_Id => File_Id,
                         Mime     => Mime,
                         Date     => Date,
                         Into     => Data);

   end Load;

end AWA.Wikis.Servlets;

Implement the Image_Servlet by using the AWA storage servlet and overloading the Load procedure


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

with Ada.Strings.Fixed;

with Orka.Logging;
with Orka.Terminals;

with EGL.Objects.Configs;
with EGL.Objects.Surfaces;

with Wayland.Protocols.Client.AWT;

package body Orka.Contexts.EGL.Wayland.AWT is

   use all type Orka.Logging.Source;
   use all type Orka.Logging.Severity;
   use Orka.Logging;

   package Messages is new Orka.Logging.Messages (Window_System);

   procedure Print_Monitor (Monitor : Standard.AWT.Monitors.Monitor'Class) is
      State : constant Standard.AWT.Monitors.Monitor_State := Monitor.State;

      use Standard.AWT.Monitors;
   begin
      Messages.Log (Debug, "Window visible on monitor");
      Messages.Log (Debug, "  name:       " & (+State.Name));
      Messages.Log (Debug, "  offset:     " &
        Trim (State.X'Image) & ", " & Trim (State.Y'Image));
      Messages.Log (Debug, "  size:       " &
        Trim (State.Width'Image) & " × " & Trim (State.Height'Image));
      Messages.Log (Debug, "  refresh: " & Orka.Terminals.Image (State.Refresh));
   end Print_Monitor;

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

   overriding
   function Width (Object : AWT_Window) return Positive is
      State : Standard.AWT.Windows.Framebuffer_State renames Object.State;
   begin
      return State.Width;
   end Width;

   overriding
   function Height (Object : AWT_Window) return Positive is
      State : Standard.AWT.Windows.Framebuffer_State renames Object.State;
   begin
      return State.Height;
   end Height;

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

   overriding
   procedure On_Move
     (Object   : in out AWT_Window;
      Monitor  : Standard.AWT.Monitors.Monitor'Class;
      Presence : Standard.AWT.Windows.Monitor_Presence)
   is
      use all type Standard.AWT.Windows.Monitor_Presence;
      use Standard.AWT.Monitors;
   begin
      case Presence is
         when Entered =>
            Print_Monitor (Monitor);
         when Left =>
            Messages.Log (Debug, "Window no longer visible on monitor");
            Messages.Log (Debug, "  name:       " & (+Monitor.State.Name));
      end case;
   end On_Move;

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

   overriding
   procedure Make_Current
     (Object : AWT_Context;
      Window : in out Orka.Windows.Window'Class) is
   begin
      if Window not in AWT_Window'Class then
         raise Constraint_Error;
      end if;

      AWT_Window (Window).Make_Current (Object.Context);
   end Make_Current;

   overriding
   function Create_Context
     (Version : Orka.Contexts.Context_Version;
      Flags   : Orka.Contexts.Context_Flags := (others => False)) return AWT_Context is
   begin
      if not Standard.AWT.Is_Initialized then
         Standard.AWT.Initialize;
      end if;

      return Create_Context
        (Standard.Wayland.Protocols.Client.AWT.Get_Display (Standard.AWT.Wayland.Get_Display.all),
         Version, Flags);
   end Create_Context;

   overriding
   function Create_Window
     (Context            : Orka.Contexts.Surface_Context'Class;
      Width, Height      : Positive;
      Title              : String  := "";
      Samples            : Natural := 0;
      Visible, Resizable : Boolean := True;
      Transparent        : Boolean := False) return AWT_Window
   is
      package EGL_Configs  renames Standard.EGL.Objects.Configs;
      package EGL_Surfaces renames Standard.EGL.Objects.Surfaces;

      use all type Standard.EGL.Objects.Contexts.Buffer_Kind;
      use type EGL_Configs.Config;

      package SF renames Ada.Strings.Fixed;

      Object : AWT_Context renames AWT_Context (Context);
   begin
      return Result : AWT_Window do
         declare
            Configs : constant EGL_Configs.Config_Array :=
              EGL_Configs.Get_Configs
                (Object.Context.Display,
                 8, 8, 8, (if Transparent then 8 else 0),
                 24, 8, EGL_Configs.Sample_Size (Samples));

            Used_Config : EGL_Configs.Config renames Configs (Configs'First);
         begin
            Messages.Log (Debug, "EGL configs: (" & Trim (Natural'Image (Configs'Length)) & ")");
            Messages.Log (Debug, "    Re Gr Bl Al De St Ms");
            Messages.Log (Debug, "    --------------------");
            for Config of Configs loop
               declare
                  State : constant EGL_Configs.Config_State := Config.State;
               begin
                  Messages.Log (Debug, "  - " &
                    SF.Tail (Trim (State.Red'Image), 2) & " " &
                    SF.Tail (Trim (State.Green'Image), 2) & " " &
                    SF.Tail (Trim (State.Blue'Image), 2) & " " &
                    SF.Tail (Trim (State.Alpha'Image), 2) & " " &
                    SF.Tail (Trim (State.Depth'Image), 2) & " " &
                    SF.Tail (Trim (State.Stencil'Image), 2) & " " &
                    SF.Tail (Trim (State.Samples'Image), 2) &
                    (if Config = Used_Config then " (used)" else ""));
               end;
            end loop;

            Result.Set_EGL_Data (Object.Context, Used_Config, sRGB => True);

            Result.Create_Window ("", Title, Width, Height,
              Visible     => Visible,
              Resizable   => Resizable,
              Decorated   => True,
              Transparent => Transparent);

            Result.Make_Current (Object.Context);

            pragma Assert (Object.Context.Buffer = Back);

            Messages.Log (Debug, "Created AWT window");
            Messages.Log (Debug, "  size:        " &
              Trim (Width'Image) & " × " & Trim (Height'Image));
            Messages.Log (Debug, "  visible:     " & (if Visible then "yes" else "no"));
            Messages.Log (Debug, "  resizable:   " & (if Resizable then "yes" else "no"));
            Messages.Log (Debug, "  transparent: " & (if Transparent then "yes" else "no"));
         end;
      end return;
   end Create_Window;

end Orka.Contexts.EGL.Wayland.AWT;

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

with Ada.Strings.Fixed;

with Orka.Logging;
with Orka.Terminals;

with EGL.Objects.Configs;
with EGL.Objects.Surfaces;

with Wayland.Protocols.Client.AWT;

package body Orka.Contexts.EGL.Wayland.AWT is

   use all type Orka.Logging.Source;
   use all type Orka.Logging.Severity;
   use Orka.Logging;

   package Messages is new Orka.Logging.Messages (Window_System);

   procedure Print_Monitor (Monitor : Standard.AWT.Monitors.Monitor'Class) is
      State : constant Standard.AWT.Monitors.Monitor_State := Monitor.State;

      use Standard.AWT.Monitors;
   begin
      Messages.Log (Debug, "Window visible on monitor " & (+State.Name));
      Messages.Log (Debug, "  offset:     " &
        Trim (State.X'Image) & ", " & Trim (State.Y'Image));
      Messages.Log (Debug, "  size:       " &
        Trim (State.Width'Image) & " × " & Trim (State.Height'Image));
      Messages.Log (Debug, "  refresh: " & Orka.Terminals.Image (State.Refresh));
   end Print_Monitor;

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

   overriding
   function Width (Object : AWT_Window) return Positive is
      State : Standard.AWT.Windows.Framebuffer_State renames Object.State;
   begin
      return State.Width;
   end Width;

   overriding
   function Height (Object : AWT_Window) return Positive is
      State : Standard.AWT.Windows.Framebuffer_State renames Object.State;
   begin
      return State.Height;
   end Height;

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

   overriding
   procedure On_Move
     (Object   : in out AWT_Window;
      Monitor  : Standard.AWT.Monitors.Monitor'Class;
      Presence : Standard.AWT.Windows.Monitor_Presence)
   is
      use all type Standard.AWT.Windows.Monitor_Presence;
      use Standard.AWT.Monitors;
   begin
      case Presence is
         when Entered =>
            Print_Monitor (Monitor);
         when Left =>
            Messages.Log (Debug, "Window no longer visible on monitor " & (+Monitor.State.Name));
      end case;
   end On_Move;

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

   overriding
   procedure Make_Current
     (Object : AWT_Context;
      Window : in out Orka.Windows.Window'Class) is
   begin
      if Window not in AWT_Window'Class then
         raise Constraint_Error;
      end if;

      AWT_Window (Window).Make_Current (Object.Context);
   end Make_Current;

   overriding
   function Create_Context
     (Version : Orka.Contexts.Context_Version;
      Flags   : Orka.Contexts.Context_Flags := (others => False)) return AWT_Context is
   begin
      if not Standard.AWT.Is_Initialized then
         Standard.AWT.Initialize;
      end if;

      return Create_Context
        (Standard.Wayland.Protocols.Client.AWT.Get_Display (Standard.AWT.Wayland.Get_Display.all),
         Version, Flags);
   end Create_Context;

   overriding
   function Create_Window
     (Context            : Orka.Contexts.Surface_Context'Class;
      Width, Height      : Positive;
      Title              : String  := "";
      Samples            : Natural := 0;
      Visible, Resizable : Boolean := True;
      Transparent        : Boolean := False) return AWT_Window
   is
      package EGL_Configs  renames Standard.EGL.Objects.Configs;
      package EGL_Surfaces renames Standard.EGL.Objects.Surfaces;

      use all type Standard.EGL.Objects.Contexts.Buffer_Kind;
      use type EGL_Configs.Config;

      package SF renames Ada.Strings.Fixed;

      Object : AWT_Context renames AWT_Context (Context);
   begin
      return Result : AWT_Window do
         declare
            Configs : constant EGL_Configs.Config_Array :=
              EGL_Configs.Get_Configs
                (Object.Context.Display,
                 8, 8, 8, (if Transparent then 8 else 0),
                 24, 8, EGL_Configs.Sample_Size (Samples));

            Used_Config : EGL_Configs.Config renames Configs (Configs'First);
         begin
            Messages.Log (Debug, "EGL configs: (" & Trim (Natural'Image (Configs'Length)) & ")");
            Messages.Log (Debug, "    Re Gr Bl Al De St Ms");
            Messages.Log (Debug, "    --------------------");
            for Config of Configs loop
               declare
                  State : constant EGL_Configs.Config_State := Config.State;
               begin
                  Messages.Log (Debug, "  - " &
                    SF.Tail (Trim (State.Red'Image), 2) & " " &
                    SF.Tail (Trim (State.Green'Image), 2) & " " &
                    SF.Tail (Trim (State.Blue'Image), 2) & " " &
                    SF.Tail (Trim (State.Alpha'Image), 2) & " " &
                    SF.Tail (Trim (State.Depth'Image), 2) & " " &
                    SF.Tail (Trim (State.Stencil'Image), 2) & " " &
                    SF.Tail (Trim (State.Samples'Image), 2) &
                    (if Config = Used_Config then " (used)" else ""));
               end;
            end loop;

            Result.Set_EGL_Data (Object.Context, Used_Config, sRGB => True);

            Result.Create_Window ("", Title, Width, Height,
              Visible     => Visible,
              Resizable   => Resizable,
              Decorated   => True,
              Transparent => Transparent);

            Result.Make_Current (Object.Context);

            pragma Assert (Object.Context.Buffer = Back);

            Messages.Log (Debug, "Created AWT window");
            Messages.Log (Debug, "  size:        " &
              Trim (Width'Image) & " × " & Trim (Height'Image));
            Messages.Log (Debug, "  visible:     " & (if Visible then "yes" else "no"));
            Messages.Log (Debug, "  resizable:   " & (if Resizable then "yes" else "no"));
            Messages.Log (Debug, "  transparent: " & (if Transparent then "yes" else "no"));
         end;
      end return;
   end Create_Window;

end Orka.Contexts.EGL.Wayland.AWT;

awt: Simplify log output of whether window is visible/hidden on a monitor

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


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

with Ada.Text_IO;
with Ada.Directories;

with Gen.Utils;
with Gen.Utils.GNAT;
with Gen.Model.Projects;

with Util.Files;
package body Gen.Commands.Info is

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   procedure Execute (Cmd       : in Command;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd);

      procedure Collect_Directories (List   : in Gen.Utils.String_List.Vector;
                                     Result : out Gen.Utils.String_List.Vector);

      procedure Print_Model_File (Name : in String;
                                  File : in String;
                                  Done : out Boolean);

      procedure Print_GNAT_Projects (Project : in out Gen.Model.Projects.Project_Definition);

      procedure Print_Dynamo_Projects (Project : in out Gen.Model.Projects.Root_Project_Definition);

      procedure Print_Modules (Project : in out Gen.Model.Projects.Project_Definition'Class;
                               Indent  : in Ada.Text_IO.Positive_Count);

      procedure Print_Project (Project : in out Gen.Model.Projects.Root_Project_Definition);

      List : Gen.Utils.String_List.Vector;

      procedure Collect_Directories (List : in Gen.Utils.String_List.Vector;
                                     Result : out Gen.Utils.String_List.Vector) is

         procedure Add_Model_Dir (Base_Dir : in String;
                                  Dir : in String);

         procedure Add_Model_Dir (Base_Dir : in String;
                                  Dir : in String) is
            Path : constant String := Util.Files.Compose (Base_Dir, Dir);
         begin
            if not Result.Contains (Path)
              and then Ada.Directories.Exists (Path) then
               Result.Append (Path);
            end if;
         end Add_Model_Dir;

         Iter : Gen.Utils.String_List.Cursor := List.First;
      begin
         while Gen.Utils.String_List.Has_Element (Iter) loop
            declare
               Path : constant String := Gen.Utils.String_List.Element (Iter);
               Dir  : constant String := Ada.Directories.Containing_Directory (Path);
            begin
               Add_Model_Dir (Dir, "db");
               Add_Model_Dir (Dir, "db/regtests");
               Add_Model_Dir (Dir, "db/samples");
            end;
            Gen.Utils.String_List.Next (Iter);
         end loop;
      end Collect_Directories;

      procedure Print_Model_File (Name : in String;
                                  File : in String;
                                  Done : out Boolean) is
         pragma Unreferenced (Name);
      begin
         Ada.Text_IO.Put ("    ");
         Ada.Text_IO.Put_Line (File);
         Done := False;
      end Print_Model_File;

      --  ------------------------------
      --  Print the list of GNAT projects used by the main project.
      --  ------------------------------
      procedure Print_GNAT_Projects (Project : in out Gen.Model.Projects.Project_Definition) is
         use Gen.Utils.GNAT;

         Iter : Project_Info_Vectors.Cursor := Project.Project_Files.First;
         Info : Project_Info;
      begin
         if Project_Info_Vectors.Has_Element (Iter) then
            Ada.Text_IO.Put_Line ("GNAT project files:");
            while Project_Info_Vectors.Has_Element (Iter) loop
               Ada.Text_IO.Put ("   ");
               Info := Project_Info_Vectors.Element (Iter);
               Ada.Text_IO.Put_Line (Ada.Strings.Unbounded.To_String (Info.Path));
               Project_Info_Vectors.Next (Iter);
            end loop;
         end if;
      end Print_GNAT_Projects;

      --  ------------------------------
      --  Print the list of Dynamo modules
      --  ------------------------------
      procedure Print_Modules (Project : in out Gen.Model.Projects.Project_Definition'Class;
                               Indent  : in Ada.Text_IO.Positive_Count) is
         use Gen.Model.Projects;
         use type Ada.Text_IO.Positive_Count;

         Iter : Project_Vectors.Cursor := Project.Modules.First;
         Ref  : Model.Projects.Project_Reference;
      begin
         if Project_Vectors.Has_Element (Iter) then
            Ada.Text_IO.Set_Col (Indent);
            Ada.Text_IO.Put_Line ("Dynamo plugins:");
            while Project_Vectors.Has_Element (Iter) loop
               Ref := Project_Vectors.Element (Iter);
               Ada.Text_IO.Set_Col (Indent);
               Ada.Text_IO.Put ("   ");
               Ada.Text_IO.Put (Ada.Strings.Unbounded.To_String (Ref.Name));
               Ada.Text_IO.Set_Col (Indent + 30);
               if Ref.Project /= null then
                  Ada.Text_IO.Put_Line (Ada.Strings.Unbounded.To_String (Ref.Project.Path));
               else
                  Ada.Text_IO.Put_Line ("?");
               end if;
               Project_Vectors.Next (Iter);
            end loop;

            Iter := Project.Modules.First;
            while Project_Vectors.Has_Element (Iter) loop
               Ref := Project_Vectors.Element (Iter);
               if Ref.Project /= null then
                  Ada.Text_IO.Set_Col (Indent);
                  Ada.Text_IO.Put_Line ("== " & Ada.Strings.Unbounded.To_String (Ref.Name));
                  Print_Modules (Ref.Project.all, Indent + 4);
               end if;
               Project_Vectors.Next (Iter);
            end loop;
         end if;
      end Print_Modules;

      --  ------------------------------
      --  Print the list of Dynamo projects used by the main project.
      --  ------------------------------
      procedure Print_Dynamo_Projects (Project : in out Gen.Model.Projects.Root_Project_Definition) is
         Iter : Gen.Utils.String_List.Cursor := Project.Dynamo_Files.First;
      begin
         if Gen.Utils.String_List.Has_Element (Iter) then
            Ada.Text_IO.Put_Line ("Dynamo project files:");
            while Gen.Utils.String_List.Has_Element (Iter) loop
               Ada.Text_IO.Put ("   ");
               Ada.Text_IO.Put_Line (Gen.Utils.String_List.Element (Iter));
               Gen.Utils.String_List.Next (Iter);
            end loop;
         end if;
      end Print_Dynamo_Projects;

      procedure Print_Project (Project : in out Gen.Model.Projects.Root_Project_Definition) is
      begin
         Print_GNAT_Projects (Gen.Model.Projects.Project_Definition (Project));
         Print_Dynamo_Projects (Project);

         Print_Modules (Project, 1);
         declare
            Model_Dirs : Gen.Utils.String_List.Vector;
         begin
            Collect_Directories (List, Model_Dirs);
            declare
               Iter : Gen.Utils.String_List.Cursor := Model_Dirs.First;
            begin
               Ada.Text_IO.Put_Line ("ADO model files:");
               while Gen.Utils.String_List.Has_Element (Iter) loop
                  Ada.Text_IO.Put ("   ");
                  Ada.Text_IO.Put_Line (Gen.Utils.String_List.Element (Iter));
                  Util.Files.Iterate_Files_Path (Pattern => "*.xml",
                                                 Path    => Gen.Utils.String_List.Element (Iter),
                                                 Process => Print_Model_File'Access);
                  Gen.Utils.String_List.Next (Iter);
               end loop;
            end;
         end;
      end Print_Project;

   begin
      Generator.Read_Project ("dynamo.xml", True);

      Generator.Update_Project (Print_Project'Access);
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
   begin
      Ada.Text_IO.Put_Line ("info: Print information about the current project");
      Ada.Text_IO.Put_Line ("Usage: info");
      Ada.Text_IO.New_Line;
   end Help;

end Gen.Commands.Info;

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

with Ada.Text_IO;
with Ada.Directories;

with Gen.Utils;
with Gen.Utils.GNAT;
with Gen.Model.Projects;

with Util.Files;
package body Gen.Commands.Info is

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   procedure Execute (Cmd       : in Command;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd);

      procedure Collect_Directories (List   : in Gen.Utils.String_List.Vector;
                                     Result : out Gen.Utils.String_List.Vector);

      procedure Print_Model_File (Name : in String;
                                  File : in String;
                                  Done : out Boolean);

      procedure Print_GNAT_Projects (Project : in out Gen.Model.Projects.Project_Definition);

      procedure Print_Dynamo_Projects (Project : in out Model.Projects.Root_Project_Definition);

      procedure Print_Modules (Project : in out Gen.Model.Projects.Project_Definition'Class;
                               Indent  : in Ada.Text_IO.Positive_Count);

      procedure Print_Project (Project : in out Gen.Model.Projects.Root_Project_Definition);

      List : Gen.Utils.String_List.Vector;

      procedure Collect_Directories (List : in Gen.Utils.String_List.Vector;
                                     Result : out Gen.Utils.String_List.Vector) is

         procedure Add_Model_Dir (Base_Dir : in String;
                                  Dir : in String);

         procedure Add_Model_Dir (Base_Dir : in String;
                                  Dir : in String) is
            Path : constant String := Util.Files.Compose (Base_Dir, Dir);
         begin
            if not Result.Contains (Path)
              and then Ada.Directories.Exists (Path) then
               Result.Append (Path);
            end if;
         end Add_Model_Dir;

         Iter : Gen.Utils.String_List.Cursor := List.First;
      begin
         while Gen.Utils.String_List.Has_Element (Iter) loop
            declare
               Path : constant String := Gen.Utils.String_List.Element (Iter);
               Dir  : constant String := Ada.Directories.Containing_Directory (Path);
            begin
               Add_Model_Dir (Dir, "db");
               Add_Model_Dir (Dir, "db/regtests");
               Add_Model_Dir (Dir, "db/samples");
            end;
            Gen.Utils.String_List.Next (Iter);
         end loop;
      end Collect_Directories;

      procedure Print_Model_File (Name : in String;
                                  File : in String;
                                  Done : out Boolean) is
         pragma Unreferenced (Name);
      begin
         Ada.Text_IO.Put ("    ");
         Ada.Text_IO.Put_Line (File);
         Done := False;
      end Print_Model_File;

      --  ------------------------------
      --  Print the list of GNAT projects used by the main project.
      --  ------------------------------
      procedure Print_GNAT_Projects (Project : in out Gen.Model.Projects.Project_Definition) is
         use Gen.Utils.GNAT;

         Iter : Project_Info_Vectors.Cursor := Project.Project_Files.First;
         Info : Project_Info;
      begin
         if Project_Info_Vectors.Has_Element (Iter) then
            Ada.Text_IO.Put_Line ("GNAT project files:");
            while Project_Info_Vectors.Has_Element (Iter) loop
               Ada.Text_IO.Put ("   ");
               Info := Project_Info_Vectors.Element (Iter);
               Ada.Text_IO.Put_Line (Ada.Strings.Unbounded.To_String (Info.Path));
               Project_Info_Vectors.Next (Iter);
            end loop;
         end if;
      end Print_GNAT_Projects;

      --  ------------------------------
      --  Print the list of Dynamo modules
      --  ------------------------------
      procedure Print_Modules (Project : in out Gen.Model.Projects.Project_Definition'Class;
                               Indent  : in Ada.Text_IO.Positive_Count) is
         use Gen.Model.Projects;
         use type Ada.Text_IO.Positive_Count;

         Iter : Project_Vectors.Cursor := Project.Modules.First;
         Ref  : Model.Projects.Project_Reference;
      begin
         if Project_Vectors.Has_Element (Iter) then
            Ada.Text_IO.Set_Col (Indent);
            Ada.Text_IO.Put_Line ("Dynamo plugins:");
            while Project_Vectors.Has_Element (Iter) loop
               Ref := Project_Vectors.Element (Iter);
               Ada.Text_IO.Set_Col (Indent);
               Ada.Text_IO.Put ("   ");
               Ada.Text_IO.Put (Ada.Strings.Unbounded.To_String (Ref.Name));
               Ada.Text_IO.Set_Col (Indent + 30);
               if Ref.Project /= null then
                  Ada.Text_IO.Put_Line (Ada.Strings.Unbounded.To_String (Ref.Project.Path));
               else
                  Ada.Text_IO.Put_Line ("?");
               end if;
               Project_Vectors.Next (Iter);
            end loop;

            Iter := Project.Modules.First;
            while Project_Vectors.Has_Element (Iter) loop
               Ref := Project_Vectors.Element (Iter);
               if Ref.Project /= null and then not Ref.Project.Modules.Is_Empty then
                  Ada.Text_IO.Set_Col (Indent);
                  Ada.Text_IO.Put_Line ("== " & Ada.Strings.Unbounded.To_String (Ref.Name));
                  Print_Modules (Ref.Project.all, Indent + 4);
               end if;
               Project_Vectors.Next (Iter);
            end loop;
         end if;
      end Print_Modules;

      --  ------------------------------
      --  Print the list of Dynamo projects used by the main project.
      --  ------------------------------
      procedure Print_Dynamo_Projects (Project : in out Model.Projects.Root_Project_Definition) is
         Iter : Gen.Utils.String_List.Cursor := Project.Dynamo_Files.First;
      begin
         if Gen.Utils.String_List.Has_Element (Iter) then
            Ada.Text_IO.Put_Line ("Dynamo project files:");
            while Gen.Utils.String_List.Has_Element (Iter) loop
               Ada.Text_IO.Put ("   ");
               Ada.Text_IO.Put_Line (Gen.Utils.String_List.Element (Iter));
               Gen.Utils.String_List.Next (Iter);
            end loop;
         end if;
      end Print_Dynamo_Projects;

      procedure Print_Project (Project : in out Gen.Model.Projects.Root_Project_Definition) is
      begin
         Print_GNAT_Projects (Gen.Model.Projects.Project_Definition (Project));
         Print_Dynamo_Projects (Project);

         Print_Modules (Project, 1);
         declare
            Model_Dirs : Gen.Utils.String_List.Vector;
         begin
            Collect_Directories (List, Model_Dirs);
            declare
               Iter : Gen.Utils.String_List.Cursor := Model_Dirs.First;
            begin
               Ada.Text_IO.Put_Line ("ADO model files:");
               while Gen.Utils.String_List.Has_Element (Iter) loop
                  Ada.Text_IO.Put ("   ");
                  Ada.Text_IO.Put_Line (Gen.Utils.String_List.Element (Iter));
                  Util.Files.Iterate_Files_Path (Pattern => "*.xml",
                                                 Path    => Gen.Utils.String_List.Element (Iter),
                                                 Process => Print_Model_File'Access);
                  Gen.Utils.String_List.Next (Iter);
               end loop;
            end;
         end;
      end Print_Project;

   begin
      Generator.Read_Project ("dynamo.xml", True);

      Generator.Update_Project (Print_Project'Access);
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
   begin
      Ada.Text_IO.Put_Line ("info: Print information about the current project");
      Ada.Text_IO.Put_Line ("Usage: info");
      Ada.Text_IO.New_Line;
   end Help;

end Gen.Commands.Info;

Fix compilation warnings and simplify the output


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

with Util.Test_Caller;

with Security.Contexts;

with ASF.Tests;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with Servlet.Responses;

with AWA.Services.Contexts;
with AWA.Tests.Helpers.Users;
with AWA.Images.Modules;
with AWA.Storages.Beans;
with AWA.Storages.Services;
with AWA.Storages.Modules;
package body AWA.Images.Modules.Tests is

   use type AWA.Storages.Services.Storage_Service_Access;

   package Caller is new Util.Test_Caller (Test, "Images.Modules");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Images.Modules.Create_Image",
                       Test_Create_Image'Access);
      Caller.Add_Test (Suite, "Test AWA.Images.Modules.Get_Sizes",
                       Test_Get_Sizes'Access);
      Caller.Add_Test (Suite, "Test AWA.Images.Modules.Scale",
                       Test_Scale'Access);
      Caller.Add_Test (Suite, "Test AWA.Images.Modules.On_Create",
                       Test_Store_Image'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a storage object
   --  ------------------------------
   procedure Test_Create_Image (T : in out Test) is
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Source    : constant String := Util.Tests.Get_Path ("regtests/files/images/bast-12.jpg");
      Thumb     : constant String
        := Util.Tests.Get_Test_Path ("regtests/result/bast-12-thumb.jpg");
      Width     : Natural := 64;
      Height    : Natural := 64;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");
      T.Manager := AWA.Images.Modules.Get_Image_Module;

      T.Manager.Create_Thumbnail (Source, Thumb, Width, Height);
      Util.Tests.Assert_Equals (T, 1720, Width, "Invalid image width");
      Util.Tests.Assert_Equals (T, 1098, Height, "Invalid image height");
   end Test_Create_Image;

   --  ------------------------------
   --  Test the Get_Sizes operation.
   --  ------------------------------
   procedure Test_Get_Sizes (T : in out Test) is
      Width  : Natural;
      Height : Natural;
   begin
      AWA.Images.Modules.Get_Sizes ("default", Width, Height);
      Util.Tests.Assert_Equals (T, 800, Width, "Default width should be 800");
      Util.Tests.Assert_Equals (T, 0, Height, "Default height should be 0");

      AWA.Images.Modules.Get_Sizes ("123x456", Width, Height);
      Util.Tests.Assert_Equals (T, 123, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 456, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("x56", Width, Height);
      Util.Tests.Assert_Equals (T, 0, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 56, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("123x", Width, Height);
      Util.Tests.Assert_Equals (T, 123, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 0, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("123xtoto", Width, Height);
      Util.Tests.Assert_Equals (T, 123, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 0, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("xtoto", Width, Height);
      Util.Tests.Assert_Equals (T, 0, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 0, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("original", Width, Height);
      Util.Tests.Assert_Equals (T, Natural'Last, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, Natural'Last, Height, "Invalid height");
   end Test_Get_Sizes;

   --  ------------------------------
   --  Test the Scale operation.
   --  ------------------------------
   procedure Test_Scale (T : in out Test) is
      Width  : Natural;
      Height : Natural;
   begin
      Width := 0;
      Height := 0;
      AWA.Images.Modules.Scale (123, 456, Width, Height);
      Util.Tests.Assert_Equals (T, 123, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 456, Height, "Invalid height");

      Width := 100;
      Height := 0;
      AWA.Images.Modules.Scale (10000, 2000, Width, Height);
      Util.Tests.Assert_Equals (T, 100, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 20, Height, "Invalid height");

      Width := 0;
      Height := 200;
      AWA.Images.Modules.Scale (10000, 2000, Width, Height);
      Util.Tests.Assert_Equals (T, 1000, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 200, Height, "Invalid height");

   end Test_Scale;

   --  ------------------------------
   --  Test the creation of an image through the storage service.
   --  ------------------------------
   procedure Test_Store_Image (T : in out Test) is
      Sec_Ctx : Security.Contexts.Security_Context;
      Context : AWA.Services.Contexts.Service_Context;
      Folder  : AWA.Storages.Beans.Folder_Bean;
      Store   : AWA.Storages.Models.Storage_Ref;
      Mgr     : AWA.Storages.Services.Storage_Service_Access;
      Outcome : Ada.Strings.Unbounded.Unbounded_String;
      Path    : constant String
        := Util.Tests.Get_Path ("regtests/files/images/Ada-Lovelace.jpg");
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");

      Mgr := AWA.Storages.Modules.Get_Storage_Manager;
      T.Assert (Mgr /= null, "Null storage manager");

      --  Make a storage folder.
      Folder.Module := AWA.Storages.Modules.Get_Storage_Module;
      Folder.Set_Name ("Image folder");
      Folder.Save (Outcome);

      Store.Set_Folder (Folder);
      Store.Set_Mime_Type ("image/jpg");
      Store.Set_Name ("Ada-Lovelace.jpg");
      Mgr.Save (Store, Path, AWA.Storages.Models.FILE);

      declare
         Request : ASF.Requests.Mockup.Request;
         Reply   : ASF.Responses.Mockup.Response;
         Id      : constant String := ADO.Identifier'Image (Store.Get_Id);
      begin
         AWA.Tests.Helpers.Users.Login ("test-storage@test.com", Request);
         ASF.Tests.Do_Get (Request, Reply,
                           "/storages/images/" & Id (Id'First + 1 .. Id'Last)
                           & "/view/Ada-Lovelace.jpg",
                           "image-get-Ada-Lovelace.jpg");
         ASF.Tests.Assert_Header (T, "Content-Type", "image/jpg", Reply);
         Util.Tests.Assert_Equals (T, Servlet.Responses.SC_OK,
                                   Reply.Get_Status,
                                   "Invalid response for image");

         --  Try to get an invalid image
         ASF.Tests.Do_Get (Request, Reply,
                           "/storages/images/plop"
                           & "/view/Ada-Lovelace.jpg",
                           "image-get-plop.jpg");
         Util.Tests.Assert_Equals (T, Servlet.Responses.SC_NOT_FOUND,
                                   Reply.Get_Status,
                                   "Invalid response for image");

      end;
   end Test_Store_Image;

end AWA.Images.Modules.Tests;

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

with Util.Test_Caller;

with Security.Contexts;

with ASF.Tests;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with Servlet.Responses;

with AWA.Services.Contexts;
with AWA.Tests.Helpers.Users;
with AWA.Storages.Beans;
with AWA.Storages.Services;
with AWA.Storages.Modules;
package body AWA.Images.Modules.Tests is

   use type AWA.Storages.Services.Storage_Service_Access;

   package Caller is new Util.Test_Caller (Test, "Images.Modules");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Images.Modules.Create_Image",
                       Test_Create_Image'Access);
      Caller.Add_Test (Suite, "Test AWA.Images.Modules.Get_Sizes",
                       Test_Get_Sizes'Access);
      Caller.Add_Test (Suite, "Test AWA.Images.Modules.Scale",
                       Test_Scale'Access);
      Caller.Add_Test (Suite, "Test AWA.Images.Modules.On_Create",
                       Test_Store_Image'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a storage object
   --  ------------------------------
   procedure Test_Create_Image (T : in out Test) is
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Source    : constant String := Util.Tests.Get_Path ("regtests/files/images/bast-12.jpg");
      Thumb     : constant String
        := Util.Tests.Get_Test_Path ("regtests/result/bast-12-thumb.jpg");
      Width     : Natural := 64;
      Height    : Natural := 64;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");
      T.Manager := AWA.Images.Modules.Get_Image_Module;

      T.Manager.Create_Thumbnail (Source, Thumb, Width, Height);
      Util.Tests.Assert_Equals (T, 1720, Width, "Invalid image width");
      Util.Tests.Assert_Equals (T, 1098, Height, "Invalid image height");
   end Test_Create_Image;

   --  ------------------------------
   --  Test the Get_Sizes operation.
   --  ------------------------------
   procedure Test_Get_Sizes (T : in out Test) is
      Width  : Natural;
      Height : Natural;
   begin
      AWA.Images.Modules.Get_Sizes ("default", Width, Height);
      Util.Tests.Assert_Equals (T, 800, Width, "Default width should be 800");
      Util.Tests.Assert_Equals (T, 0, Height, "Default height should be 0");

      AWA.Images.Modules.Get_Sizes ("123x456", Width, Height);
      Util.Tests.Assert_Equals (T, 123, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 456, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("x56", Width, Height);
      Util.Tests.Assert_Equals (T, 0, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 56, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("123x", Width, Height);
      Util.Tests.Assert_Equals (T, 123, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 0, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("123xtoto", Width, Height);
      Util.Tests.Assert_Equals (T, 123, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 0, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("xtoto", Width, Height);
      Util.Tests.Assert_Equals (T, 0, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 0, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("original", Width, Height);
      Util.Tests.Assert_Equals (T, Natural'Last, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, Natural'Last, Height, "Invalid height");
   end Test_Get_Sizes;

   --  ------------------------------
   --  Test the Scale operation.
   --  ------------------------------
   procedure Test_Scale (T : in out Test) is
      Width  : Natural;
      Height : Natural;
   begin
      Width := 0;
      Height := 0;
      AWA.Images.Modules.Scale (123, 456, Width, Height);
      Util.Tests.Assert_Equals (T, 123, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 456, Height, "Invalid height");

      Width := 100;
      Height := 0;
      AWA.Images.Modules.Scale (10000, 2000, Width, Height);
      Util.Tests.Assert_Equals (T, 100, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 20, Height, "Invalid height");

      Width := 0;
      Height := 200;
      AWA.Images.Modules.Scale (10000, 2000, Width, Height);
      Util.Tests.Assert_Equals (T, 1000, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 200, Height, "Invalid height");

   end Test_Scale;

   --  ------------------------------
   --  Test the creation of an image through the storage service.
   --  ------------------------------
   procedure Test_Store_Image (T : in out Test) is
      Sec_Ctx : Security.Contexts.Security_Context;
      Context : AWA.Services.Contexts.Service_Context;
      Folder  : AWA.Storages.Beans.Folder_Bean;
      Store   : AWA.Storages.Models.Storage_Ref;
      Mgr     : AWA.Storages.Services.Storage_Service_Access;
      Outcome : Ada.Strings.Unbounded.Unbounded_String;
      Path    : constant String
        := Util.Tests.Get_Path ("regtests/files/images/Ada-Lovelace.jpg");
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");

      Mgr := AWA.Storages.Modules.Get_Storage_Manager;
      T.Assert (Mgr /= null, "Null storage manager");

      --  Make a storage folder.
      Folder.Module := AWA.Storages.Modules.Get_Storage_Module;
      Folder.Set_Name ("Image folder");
      Folder.Save (Outcome);

      Store.Set_Folder (Folder);
      Store.Set_Mime_Type ("image/jpg");
      Store.Set_Name ("Ada-Lovelace.jpg");
      Mgr.Save (Store, Path, AWA.Storages.Models.FILE);

      declare
         Request : ASF.Requests.Mockup.Request;
         Reply   : ASF.Responses.Mockup.Response;
         Id      : constant String := ADO.Identifier'Image (Store.Get_Id);
      begin
         AWA.Tests.Helpers.Users.Login ("test-storage@test.com", Request);
         ASF.Tests.Do_Get (Request, Reply,
                           "/storages/images/" & Id (Id'First + 1 .. Id'Last)
                           & "/view/Ada-Lovelace.jpg",
                           "image-get-Ada-Lovelace.jpg");
         ASF.Tests.Assert_Header (T, "Content-Type", "image/jpg", Reply);
         Util.Tests.Assert_Equals (T, Servlet.Responses.SC_OK,
                                   Reply.Get_Status,
                                   "Invalid response for image");

         --  Try to get an invalid image
         ASF.Tests.Do_Get (Request, Reply,
                           "/storages/images/plop"
                           & "/view/Ada-Lovelace.jpg",
                           "image-get-plop.jpg");
         Util.Tests.Assert_Equals (T, Servlet.Responses.SC_NOT_FOUND,
                                   Reply.Get_Status,
                                   "Invalid response for image");

      end;
   end Test_Store_Image;

end AWA.Images.Modules.Tests;

Remove unused with clause

Remove unused with clause


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

with AdaBase.Connection.Base.MySQL;
with AdaBase.Bindings.MySQL;
with Ada.Containers.Vectors;

package AdaBase.Statement.Base.MySQL is

   package ACM renames AdaBase.Connection.Base.MySQL;
   package ABM renames AdaBase.Bindings.MySQL;
   package ARS renames AdaBase.Results.Sets;
   package AC  renames Ada.Containers;

   type MySQL_statement (type_of_statement : stmt_type;
                         log_handler       : ALF.LogFacility_access;
                         mysql_conn        : ACM.MySQL_Connection_Access;
                         initial_sql       : SQL_access;
                         con_error_mode    : ErrorMode;
                         con_case_mode     : CaseMode;
                         con_max_blob      : BLOB_maximum;
                         con_buffered      : Boolean)
   is new Base_Statement and AIS.iStatement with private;
   type MySQL_statement_access is access MySQL_statement;

   overriding
   function column_count (Stmt : MySQL_statement) return Natural;

   overriding
   function last_insert_id (Stmt : MySQL_statement) return TraxID;

   overriding
   function last_sql_state (Stmt : MySQL_statement) return TSqlState;

   overriding
   function last_driver_code (Stmt : MySQL_statement) return DriverCodes;

   overriding
   function last_driver_message (Stmt : MySQL_statement) return String;

   overriding
   procedure discard_rest   (Stmt : out MySQL_statement);

   overriding
   function execute         (Stmt : out MySQL_statement) return Boolean;

   overriding
   function execute         (Stmt : out MySQL_statement; parameters : String;
                             delimiter  : Character := '|') return Boolean;

   overriding
   function rows_returned   (Stmt : MySQL_statement) return AffectedRows;

   overriding
   function column_name     (Stmt : MySQL_statement; index : Positive)
                             return String;

   overriding
   function column_table    (Stmt : MySQL_statement; index : Positive)
                             return String;

   overriding
   function column_native_type (Stmt : MySQL_statement; index : Positive)
                                return field_types;

   overriding
   function fetch_next (Stmt : out MySQL_statement) return ARS.DataRow;

   overriding
   function fetch_all  (Stmt : out MySQL_statement) return ARS.DataRowSet;

   overriding
   function fetch_bound (Stmt : out MySQL_statement) return Boolean;

   overriding
   procedure fetch_next_set (Stmt         : out MySQL_statement;
                             data_present : out Boolean;
                             data_fetched : out Boolean);

   overriding
   procedure iterate        (Stmt         : out MySQL_statement;
                             process      : not null access procedure);

   overriding
   procedure iterate (Stmt    : out MySQL_statement;
                      process : not null access procedure (row : ARS.DataRow));

private

   type mysql_canvas;

   procedure initialize (Object : in out MySQL_statement);
   procedure Adjust     (Object : in out MySQL_statement);
   procedure finalize   (Object : in out MySQL_statement);
   procedure internal_post_prep_stmt   (Stmt   : out MySQL_statement);
   procedure internal_direct_post_exec (Stmt   : out MySQL_statement;
                                        newset : Boolean := False);
   procedure process_direct_result     (Stmt : out MySQL_statement);
   procedure scan_column_information   (Stmt : out MySQL_statement);
   procedure clear_column_information  (Stmt : out MySQL_statement);
   procedure construct_bind_slot (Stmt   : MySQL_statement;
                                  struct : out ABM.MYSQL_BIND;
                                  canvas : out mysql_canvas;
                                  marker : Positive);
   procedure auto_assign         (Stmt  : out MySQL_statement;
                                  index : Positive;
                                  value : String);
   function internal_fetch_bound (Stmt : out MySQL_statement) return Boolean;
   function internal_fetch_row   (Stmt : out MySQL_statement)
                                  return ARS.DataRow;

   function internal_ps_fetch_row (Stmt : out MySQL_statement)
                                   return ARS.DataRow;

   function internal_ps_fetch_bound (Stmt : out MySQL_statement)
                                     return Boolean;

   function num_set_items (nv : String) return Natural;
   function bincopy (data : ABM.ICS.char_array_access;
                     datalen, max_size : Natural)
                     return String;
   function bincopy (data : ABM.ICS.char_array_access;
                     datalen, max_size : Natural;
                     hard_limit : Natural := 0)
                     return AR.chain;

   procedure log_problem
     (statement  : MySQL_statement;
      category   : LogCategory;
      message    : String;
      pull_codes : Boolean := False;
      break      : Boolean := False);

   type column_info is record
      table         : CT.Text;
      field_name    : CT.Text;
      field_type    : field_types;
      field_size    : Natural;
      null_possible : Boolean;
      mysql_type    : ABM.enum_field_types;
   end record;

   type fetch_status is (pending, progressing, completed);

   package VColumns is new AC.Vectors (Index_Type   => Positive,
                                       Element_Type => column_info);

   --  mysql_canvas is used by prepared statement execution
   --  The Ada types are converted to C types and stored in this record which
   --  MySQL finds through pointers.

   type mysql_canvas is record
      length        : aliased ABM.IC.unsigned_long := 0;
      is_null       : aliased ABM.my_bool          := 0;
      error         : aliased ABM.my_bool          := 0;
      buffer_uint8  : ABM.IC.unsigned_char         := 0;
      buffer_uint16 : ABM.IC.unsigned_short        := 0;
      buffer_uint32 : ABM.IC.unsigned              := 0;
      buffer_uint64 : ABM.IC.unsigned_long         := 0;
      buffer_int8   : ABM.IC.signed_char           := 0;
      buffer_int16  : ABM.IC.short                 := 0;
      buffer_int32  : ABM.IC.int                   := 0;
      buffer_int64  : ABM.IC.long                  := 0;
      buffer_float  : ABM.IC.C_float               := 0.0;
      buffer_double : ABM.IC.double                := 0.0;
      buffer_binary : ABM.ICS.char_array_access    := null;
      buffer_time   : ABM.MYSQL_TIME;
   end record;
   type mysql_canvases is array (Positive range <>) of aliased mysql_canvas;
   type mysql_canvases_Access is access all mysql_canvases;
   procedure free_canvas is new Ada.Unchecked_Deallocation
     (mysql_canvases, mysql_canvases_Access);
   procedure free_binary is new Ada.Unchecked_Deallocation
     (ABM.IC.char_array, ABM.ICS.char_array_access);
   procedure free_sql is new Ada.Unchecked_Deallocation
     (String, SQL_access);
   procedure reclaim_canvas (Stmt : out MySQL_statement);

   type MySQL_statement (type_of_statement : stmt_type;
                         log_handler       : ALF.LogFacility_access;
                         mysql_conn        : ACM.MySQL_Connection_Access;
                         initial_sql       : SQL_access;
                         con_error_mode    : ErrorMode;
                         con_case_mode     : CaseMode;
                         con_max_blob      : BLOB_maximum;
                         con_buffered      : Boolean)
   is new Base_Statement and AIS.iStatement with
      record
         delivery       : fetch_status          := completed;
         result_handle  : ABM.MYSQL_RES_Access  := null;
         stmt_handle    : ABM.MYSQL_STMT_Access := null;
         bind_canvas    : mysql_canvases_Access := null;
         assign_counter : Natural               := 0;
         num_columns    : Natural               := 0;
         size_of_rowset : TraxID                := 0;
         column_info    : VColumns.Vector;
         sql_final      : SQL_access;
      end record;

end AdaBase.Statement.Base.MySQL;

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

with AdaBase.Connection.Base.MySQL;
with AdaBase.Bindings.MySQL;
with Ada.Containers.Vectors;

package AdaBase.Statement.Base.MySQL is

   package ACM renames AdaBase.Connection.Base.MySQL;
   package ABM renames AdaBase.Bindings.MySQL;
   package ARS renames AdaBase.Results.Sets;
   package AC  renames Ada.Containers;

   type MySQL_statement (type_of_statement : stmt_type;
                         log_handler       : ALF.LogFacility_access;
                         mysql_conn        : ACM.MySQL_Connection_Access;
                         initial_sql       : SQL_access;
                         con_error_mode    : ErrorMode;
                         con_case_mode     : CaseMode;
                         con_max_blob      : BLOB_maximum;
                         con_buffered      : Boolean)
   is new Base_Statement and AIS.iStatement with private;
   type MySQL_statement_access is access all MySQL_statement;

   overriding
   function column_count (Stmt : MySQL_statement) return Natural;

   overriding
   function last_insert_id (Stmt : MySQL_statement) return TraxID;

   overriding
   function last_sql_state (Stmt : MySQL_statement) return TSqlState;

   overriding
   function last_driver_code (Stmt : MySQL_statement) return DriverCodes;

   overriding
   function last_driver_message (Stmt : MySQL_statement) return String;

   overriding
   procedure discard_rest   (Stmt : out MySQL_statement);

   overriding
   function execute         (Stmt : out MySQL_statement) return Boolean;

   overriding
   function execute         (Stmt : out MySQL_statement; parameters : String;
                             delimiter  : Character := '|') return Boolean;

   overriding
   function rows_returned   (Stmt : MySQL_statement) return AffectedRows;

   overriding
   function column_name     (Stmt : MySQL_statement; index : Positive)
                             return String;

   overriding
   function column_table    (Stmt : MySQL_statement; index : Positive)
                             return String;

   overriding
   function column_native_type (Stmt : MySQL_statement; index : Positive)
                                return field_types;

   overriding
   function fetch_next (Stmt : out MySQL_statement) return ARS.DataRow;

   overriding
   function fetch_all  (Stmt : out MySQL_statement) return ARS.DataRowSet;

   overriding
   function fetch_bound (Stmt : out MySQL_statement) return Boolean;

   overriding
   procedure fetch_next_set (Stmt         : out MySQL_statement;
                             data_present : out Boolean;
                             data_fetched : out Boolean);

   overriding
   procedure iterate        (Stmt         : out MySQL_statement;
                             process      : not null access procedure);

   overriding
   procedure iterate (Stmt    : out MySQL_statement;
                      process : not null access procedure (row : ARS.DataRow));

private

   type mysql_canvas;

   procedure initialize (Object : in out MySQL_statement);
   procedure Adjust     (Object : in out MySQL_statement);
   procedure finalize   (Object : in out MySQL_statement);
   procedure internal_post_prep_stmt   (Stmt   : out MySQL_statement);
   procedure internal_direct_post_exec (Stmt   : out MySQL_statement;
                                        newset : Boolean := False);
   procedure process_direct_result     (Stmt : out MySQL_statement);
   procedure scan_column_information   (Stmt : out MySQL_statement);
   procedure clear_column_information  (Stmt : out MySQL_statement);
   procedure construct_bind_slot (Stmt   : MySQL_statement;
                                  struct : out ABM.MYSQL_BIND;
                                  canvas : out mysql_canvas;
                                  marker : Positive);
   procedure auto_assign         (Stmt  : out MySQL_statement;
                                  index : Positive;
                                  value : String);
   function internal_fetch_bound (Stmt : out MySQL_statement) return Boolean;
   function internal_fetch_row   (Stmt : out MySQL_statement)
                                  return ARS.DataRow;

   function internal_ps_fetch_row (Stmt : out MySQL_statement)
                                   return ARS.DataRow;

   function internal_ps_fetch_bound (Stmt : out MySQL_statement)
                                     return Boolean;

   function num_set_items (nv : String) return Natural;
   function bincopy (data : ABM.ICS.char_array_access;
                     datalen, max_size : Natural)
                     return String;
   function bincopy (data : ABM.ICS.char_array_access;
                     datalen, max_size : Natural;
                     hard_limit : Natural := 0)
                     return AR.chain;

   procedure log_problem
     (statement  : MySQL_statement;
      category   : LogCategory;
      message    : String;
      pull_codes : Boolean := False;
      break      : Boolean := False);

   type column_info is record
      table         : CT.Text;
      field_name    : CT.Text;
      field_type    : field_types;
      field_size    : Natural;
      null_possible : Boolean;
      mysql_type    : ABM.enum_field_types;
   end record;

   type fetch_status is (pending, progressing, completed);

   package VColumns is new AC.Vectors (Index_Type   => Positive,
                                       Element_Type => column_info);

   --  mysql_canvas is used by prepared statement execution
   --  The Ada types are converted to C types and stored in this record which
   --  MySQL finds through pointers.

   type mysql_canvas is record
      length        : aliased ABM.IC.unsigned_long := 0;
      is_null       : aliased ABM.my_bool          := 0;
      error         : aliased ABM.my_bool          := 0;
      buffer_uint8  : ABM.IC.unsigned_char         := 0;
      buffer_uint16 : ABM.IC.unsigned_short        := 0;
      buffer_uint32 : ABM.IC.unsigned              := 0;
      buffer_uint64 : ABM.IC.unsigned_long         := 0;
      buffer_int8   : ABM.IC.signed_char           := 0;
      buffer_int16  : ABM.IC.short                 := 0;
      buffer_int32  : ABM.IC.int                   := 0;
      buffer_int64  : ABM.IC.long                  := 0;
      buffer_float  : ABM.IC.C_float               := 0.0;
      buffer_double : ABM.IC.double                := 0.0;
      buffer_binary : ABM.ICS.char_array_access    := null;
      buffer_time   : ABM.MYSQL_TIME;
   end record;
   type mysql_canvases is array (Positive range <>) of aliased mysql_canvas;
   type mysql_canvases_Access is access all mysql_canvases;
   procedure free_canvas is new Ada.Unchecked_Deallocation
     (mysql_canvases, mysql_canvases_Access);
   procedure free_binary is new Ada.Unchecked_Deallocation
     (ABM.IC.char_array, ABM.ICS.char_array_access);
   procedure free_sql is new Ada.Unchecked_Deallocation
     (String, SQL_access);
   procedure reclaim_canvas (Stmt : out MySQL_statement);

   type MySQL_statement (type_of_statement : stmt_type;
                         log_handler       : ALF.LogFacility_access;
                         mysql_conn        : ACM.MySQL_Connection_Access;
                         initial_sql       : SQL_access;
                         con_error_mode    : ErrorMode;
                         con_case_mode     : CaseMode;
                         con_max_blob      : BLOB_maximum;
                         con_buffered      : Boolean)
   is new Base_Statement and AIS.iStatement with
      record
         delivery       : fetch_status          := completed;
         result_handle  : ABM.MYSQL_RES_Access  := null;
         stmt_handle    : ABM.MYSQL_STMT_Access := null;
         bind_canvas    : mysql_canvases_Access := null;
         assign_counter : Natural               := 0;
         num_columns    : Natural               := 0;
         size_of_rowset : TraxID                := 0;
         column_info    : VColumns.Vector;
         sql_final      : SQL_access;
      end record;

end AdaBase.Statement.Base.MySQL;

set mysql statement access type "all" attribute