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

with AWA.Users.Services.Tests;
with AWA.Users.Tests;
with AWA.Blogs.Modules.Tests;
with AWA.Blogs.Tests;
with AWA.Helpers.Selectors.Tests;
with AWA.Storages.Services.Tests;
with AWA.Events.Services.Tests;
with AWA.Mail.Clients.Tests;
with AWA.Mail.Modules.Tests;
with AWA.Images.Modules.Tests;
with AWA.Votes.Modules.Tests;
with AWA.Tags.Modules.Tests;
with AWA.Questions.Modules.Tests;
with AWA.Counters.Modules.Tests;
with AWA.Workspaces.Tests;
with AWA.Modules.Tests;

with ASF.Converters.Dates;

with AWA.Users.Modules;
with AWA.Mail.Modules;
with AWA.Blogs.Modules;
with AWA.Workspaces.Modules;
with AWA.Storages.Modules;
with AWA.Images.Modules;
with AWA.Questions.Modules;
with AWA.Votes.Modules;
with AWA.Tags.Modules;
with AWA.Changelogs.Modules;
with AWA.Counters.Modules;

with AWA.Converters.Dates;
with AWA.Tests;
with AWA.Services.Contexts;
with AWA.Jobs.Services.Tests;
with AWA.Jobs.Modules.Tests;
with AWA.Settings.Modules.Tests;
with AWA.Comments.Modules.Tests;
with AWA.Changelogs.Modules.Tests;
with AWA.Wikis.Modules.Tests;

with Servlet.Server;
package body AWA.Testsuite is
   Users          : aliased AWA.Users.Modules.User_Module;

   Workspaces     : aliased AWA.Workspaces.Modules.Workspace_Module;

   Mail           : aliased AWA.Mail.Modules.Mail_Module;

   Jobs           : aliased AWA.Jobs.Modules.Job_Module;

   Comments       : aliased AWA.Comments.Modules.Comment_Module;

   Blogs          : aliased AWA.Blogs.Modules.Blog_Module;

   Storages       : aliased AWA.Storages.Modules.Storage_Module;

   Images         : aliased AWA.Images.Modules.Image_Module;

   Questions      : aliased AWA.Questions.Modules.Question_Module;

   Votes          : aliased AWA.Votes.Modules.Vote_Module;

   Tags           : aliased AWA.Tags.Modules.Tag_Module;

   Settings       : aliased AWA.Settings.Modules.Setting_Module;

   Changelogs     : aliased AWA.Changelogs.Modules.Changelog_Module;

   Wikis          : aliased AWA.Wikis.Modules.Wiki_Module;

   Counters       : aliased AWA.Counters.Modules.Counter_Module;

   Date_Converter : aliased ASF.Converters.Dates.Date_Converter;

   Rel_Date_Converter : aliased AWA.Converters.Dates.Relative_Date_Converter;

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Ret : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      AWA.Modules.Tests.Add_Tests (Ret);
      AWA.Events.Services.Tests.Add_Tests (Ret);
      AWA.Mail.Clients.Tests.Add_Tests (Ret);
      AWA.Mail.Modules.Tests.Add_Tests (Ret);
      AWA.Users.Services.Tests.Add_Tests (Ret);
      AWA.Users.Tests.Add_Tests (Ret);
      AWA.Workspaces.Tests.Add_Tests (Ret);
      AWA.Counters.Modules.Tests.Add_Tests (Ret);
      AWA.Helpers.Selectors.Tests.Add_Tests (Ret);
      AWA.Jobs.Modules.Tests.Add_Tests (Ret);
      AWA.Jobs.Services.Tests.Add_Tests (Ret);
      AWA.Settings.Modules.Tests.Add_Tests (Ret);
      AWA.Comments.Modules.Tests.Add_Tests (Ret);
      AWA.Blogs.Modules.Tests.Add_Tests (Ret);
      AWA.Blogs.Tests.Add_Tests (Ret);
      AWA.Storages.Services.Tests.Add_Tests (Ret);
      AWA.Images.Modules.Tests.Add_Tests (Ret);
      AWA.Changelogs.Modules.Tests.Add_Tests (Ret);
      AWA.Votes.Modules.Tests.Add_Tests (Ret);
      AWA.Tags.Modules.Tests.Add_Tests (Ret);
      AWA.Questions.Modules.Tests.Add_Tests (Ret);
      AWA.Wikis.Modules.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

   procedure Initialize (Props : in Util.Properties.Manager) is
   begin
      Initialize (null, Props, True);
   end Initialize;

   --  ------------------------------
   --  Initialize the AWA test framework mockup.
   --  ------------------------------
   procedure Initialize (App         : in AWA.Applications.Application_Access;
                         Props       : in Util.Properties.Manager;
                         Add_Modules : in Boolean) is
      use AWA.Applications;
   begin
      AWA.Tests.Initialize (App, Props, Add_Modules);

      if Add_Modules then
         declare
            Application : constant Applications.Application_Access := AWA.Tests.Get_Application;
            Ctx         : AWA.Services.Contexts.Service_Context;
            Users  : constant AWA.Users.Modules.User_Module_Access := AWA.Testsuite.Users'Access;
         begin
            Ctx.Set_Context (Application, null);
            Register (App    => Application.all'Access,
                      Name   => AWA.Users.Modules.NAME,
                      URI    => "user",
                      Module => Users.all'Access);

            Register (App    => Application.all'Access,
                      Name   => "mail",
                      URI    => "mail",
                      Module => Mail'Access);

            Register (App    => Application.all'Access,
                      Name   => "workspaces",
                      URI    => "workspaces",
                      Module => Workspaces'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Counters.Modules.NAME,
                      URI    => "counters",
                      Module => Counters'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Comments.Modules.NAME,
                      URI    => "comments",
                      Module => Comments'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Storages.Modules.NAME,
                      URI    => "storages",
                      Module => Storages'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Jobs.Modules.NAME,
                      URI    => "jobs",
                      Module => Jobs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Images.Modules.NAME,
                      URI    => "images",
                      Module => Images'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Settings.Modules.NAME,
                      URI    => "settings",
                      Module => Settings'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Votes.Modules.NAME,
                      URI    => "votes",
                      Module => Votes'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Changelogs.Modules.NAME,
                      URI    => "changelogs",
                      Module => Changelogs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Tags.Modules.NAME,
                      URI    => "tags",
                      Module => Tags'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Blogs.Modules.NAME,
                      URI    => "blogs",
                      Module => Blogs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Questions.Modules.NAME,
                      URI    => "questions",
                      Module => Questions'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Wikis.Modules.NAME,
                      URI    => "wikis",
                      Module => Wikis'Access);

            Application.Add_Converter (Name      => "dateConverter",
                                       Converter => Date_Converter'Access);
            Application.Add_Converter (Name      => "smartDateConverter",
                                       Converter => Rel_Date_Converter'Access);
            Application.Start;
--              if Props.Exists ("test.server") then
--                 declare
--                    WS : ASF.Server.Web.AWS_Container;
--                 begin
--                    Application.Add_Converter (Name      => "dateConverter",
--                                               Converter => Date_Converter'Access);
--                    Application.Add_Converter (Name      => "smartDateConverter",
--                                               Converter => Rel_Date_Converter'Access);
--
--                    WS.Register_Application ("/asfunit", Application.all'Access);
--
--                    WS.Start;
--                    delay 6000.0;
--                 end;
--              end if;
            Servlet.Server.Set_Context (Application.all'Access);
         end;
      end if;
   end Initialize;

end AWA.Testsuite;

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

with AWA.Users.Services.Tests;
with AWA.Users.Tests;
with AWA.Blogs.Modules.Tests;
with AWA.Blogs.Tests;
with AWA.Helpers.Selectors.Tests;
with AWA.Storages.Services.Tests;
with AWA.Events.Services.Tests;
with AWA.Mail.Clients.Tests;
with AWA.Mail.Modules.Tests;
with AWA.Images.Modules.Tests;
with AWA.Votes.Modules.Tests;
with AWA.Tags.Modules.Tests;
with AWA.Questions.Modules.Tests;
with AWA.Counters.Modules.Tests;
with AWA.Workspaces.Tests;
with AWA.Modules.Tests;

with ASF.Converters.Dates;

with AWA.Users.Modules;
with AWA.Mail.Modules;
with AWA.Blogs.Modules;
with AWA.Workspaces.Modules;
with AWA.Storages.Modules;
with AWA.Images.Modules;
with AWA.Questions.Modules;
with AWA.Votes.Modules;
with AWA.Tags.Modules;
with AWA.Changelogs.Modules;
with AWA.Counters.Modules;

with AWA.Converters.Dates;
with AWA.Tests;
with AWA.Services.Contexts;
with AWA.Jobs.Services.Tests;
with AWA.Jobs.Modules.Tests;
with AWA.Settings.Modules.Tests;
with AWA.Comments.Modules.Tests;
with AWA.Changelogs.Modules.Tests;
with AWA.Wikis.Modules.Tests;
with AWA.Wikis.Tests;

with Servlet.Server;
package body AWA.Testsuite is
   Users          : aliased AWA.Users.Modules.User_Module;

   Workspaces     : aliased AWA.Workspaces.Modules.Workspace_Module;

   Mail           : aliased AWA.Mail.Modules.Mail_Module;

   Jobs           : aliased AWA.Jobs.Modules.Job_Module;

   Comments       : aliased AWA.Comments.Modules.Comment_Module;

   Blogs          : aliased AWA.Blogs.Modules.Blog_Module;

   Storages       : aliased AWA.Storages.Modules.Storage_Module;

   Images         : aliased AWA.Images.Modules.Image_Module;

   Questions      : aliased AWA.Questions.Modules.Question_Module;

   Votes          : aliased AWA.Votes.Modules.Vote_Module;

   Tags           : aliased AWA.Tags.Modules.Tag_Module;

   Settings       : aliased AWA.Settings.Modules.Setting_Module;

   Changelogs     : aliased AWA.Changelogs.Modules.Changelog_Module;

   Wikis          : aliased AWA.Wikis.Modules.Wiki_Module;

   Counters       : aliased AWA.Counters.Modules.Counter_Module;

   Date_Converter : aliased ASF.Converters.Dates.Date_Converter;

   Rel_Date_Converter : aliased AWA.Converters.Dates.Relative_Date_Converter;

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Ret : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      AWA.Modules.Tests.Add_Tests (Ret);
      AWA.Events.Services.Tests.Add_Tests (Ret);
      AWA.Mail.Clients.Tests.Add_Tests (Ret);
      AWA.Mail.Modules.Tests.Add_Tests (Ret);
      AWA.Users.Services.Tests.Add_Tests (Ret);
      AWA.Users.Tests.Add_Tests (Ret);
      AWA.Workspaces.Tests.Add_Tests (Ret);
      AWA.Counters.Modules.Tests.Add_Tests (Ret);
      AWA.Helpers.Selectors.Tests.Add_Tests (Ret);
      AWA.Jobs.Modules.Tests.Add_Tests (Ret);
      AWA.Jobs.Services.Tests.Add_Tests (Ret);
      AWA.Settings.Modules.Tests.Add_Tests (Ret);
      AWA.Comments.Modules.Tests.Add_Tests (Ret);
      AWA.Blogs.Modules.Tests.Add_Tests (Ret);
      AWA.Blogs.Tests.Add_Tests (Ret);
      AWA.Storages.Services.Tests.Add_Tests (Ret);
      AWA.Images.Modules.Tests.Add_Tests (Ret);
      AWA.Changelogs.Modules.Tests.Add_Tests (Ret);
      AWA.Votes.Modules.Tests.Add_Tests (Ret);
      AWA.Tags.Modules.Tests.Add_Tests (Ret);
      AWA.Questions.Modules.Tests.Add_Tests (Ret);
      AWA.Wikis.Modules.Tests.Add_Tests (Ret);
      AWA.Wikis.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

   procedure Initialize (Props : in Util.Properties.Manager) is
   begin
      Initialize (null, Props, True);
   end Initialize;

   --  ------------------------------
   --  Initialize the AWA test framework mockup.
   --  ------------------------------
   procedure Initialize (App         : in AWA.Applications.Application_Access;
                         Props       : in Util.Properties.Manager;
                         Add_Modules : in Boolean) is
      use AWA.Applications;
   begin
      AWA.Tests.Initialize (App, Props, Add_Modules);

      if Add_Modules then
         declare
            Application : constant Applications.Application_Access := AWA.Tests.Get_Application;
            Ctx         : AWA.Services.Contexts.Service_Context;
            Users  : constant AWA.Users.Modules.User_Module_Access := AWA.Testsuite.Users'Access;
         begin
            Ctx.Set_Context (Application, null);
            Register (App    => Application.all'Access,
                      Name   => AWA.Users.Modules.NAME,
                      URI    => "user",
                      Module => Users.all'Access);

            Register (App    => Application.all'Access,
                      Name   => "mail",
                      URI    => "mail",
                      Module => Mail'Access);

            Register (App    => Application.all'Access,
                      Name   => "workspaces",
                      URI    => "workspaces",
                      Module => Workspaces'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Counters.Modules.NAME,
                      URI    => "counters",
                      Module => Counters'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Comments.Modules.NAME,
                      URI    => "comments",
                      Module => Comments'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Storages.Modules.NAME,
                      URI    => "storages",
                      Module => Storages'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Jobs.Modules.NAME,
                      URI    => "jobs",
                      Module => Jobs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Images.Modules.NAME,
                      URI    => "images",
                      Module => Images'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Settings.Modules.NAME,
                      URI    => "settings",
                      Module => Settings'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Votes.Modules.NAME,
                      URI    => "votes",
                      Module => Votes'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Changelogs.Modules.NAME,
                      URI    => "changelogs",
                      Module => Changelogs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Tags.Modules.NAME,
                      URI    => "tags",
                      Module => Tags'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Blogs.Modules.NAME,
                      URI    => "blogs",
                      Module => Blogs'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Questions.Modules.NAME,
                      URI    => "questions",
                      Module => Questions'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Wikis.Modules.NAME,
                      URI    => "wikis",
                      Module => Wikis'Access);

            Application.Add_Converter (Name      => "dateConverter",
                                       Converter => Date_Converter'Access);
            Application.Add_Converter (Name      => "smartDateConverter",
                                       Converter => Rel_Date_Converter'Access);
            Application.Start;
--              if Props.Exists ("test.server") then
--                 declare
--                    WS : ASF.Server.Web.AWS_Container;
--                 begin
--                    Application.Add_Converter (Name      => "dateConverter",
--                                               Converter => Date_Converter'Access);
--                    Application.Add_Converter (Name      => "smartDateConverter",
--                                               Converter => Rel_Date_Converter'Access);
--
--                    WS.Register_Application ("/asfunit", Application.all'Access);
--
--                    WS.Start;
--                    delay 6000.0;
--                 end;
--              end if;
            Servlet.Server.Set_Context (Application.all'Access);
         end;
      end if;
   end Initialize;

end AWA.Testsuite;

Add more unit tests for Wiki module

Add more unit tests for Wiki module


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

with AWA.Users.Models;
with AWA.Users.Principals;
with AWA.Permissions.Services;
with AWA.Modules;
with AWA.Modules.Lifecycles;
with AWA.Events;
with Security.Auth;
with Security.Random;

with ADO;
with ADO.Sessions;

--  == Introduction ==
--  The *users* module provides a *users* service which controls the user data model.
--
--  == Events ==
--  The *users* module exposes a number of events which are posted when some action
--  are performed at the service level.
--
--  === user-register ===
--  This event is posted when a new user is registered in the application.
--  It can be used to send a registration email.
--
--  === user-create ===
--  This event is posted when a new user is created.  It can be used to trigger
--  the pre-initialization of the application for the new user.
--
--  === user-lost-password ===
--  This event is posted when a user asks for a password reset through an
--  anonymous form.  It is intended to be used to send the reset password email.
--
--  === user-reset-password ===
--  This event is posted when a user has successfully reset his password.
--  It can be used to send an email.
--
package AWA.Users.Services is

   use AWA.Users.Models;

   package User_Create_Event is new AWA.Events.Definition (Name => "user-create");
   package User_Register_Event is new AWA.Events.Definition (Name => "user-register");
   package User_Lost_Password_Event is new AWA.Events.Definition (Name => "user-lost-password");
   package User_Reset_Password_Event is new AWA.Events.Definition (Name => "user-reset-password");

   package User_Lifecycle is
     new AWA.Modules.Lifecycles (Element_Type => AWA.Users.Models.User_Ref'Class);

   subtype Listener is User_Lifecycle.Listener;

   NAME : constant String := "User_Service";

   Not_Found  : exception;

   User_Exist : exception;

   --  The session is an authenticate session.  The user authenticated using password or OpenID.
   --  When the user logout, this session is closed as well as any connection session linked to
   --  the authenticate session.
   AUTH_SESSION_TYPE    : constant Integer := 1;

   --  The session is a connection session.  It is linked to an authenticate session.
   --  This session can be closed automatically due to a timeout or user's inactivity.
   --  The AID cookie refers to this connection session to create a new connection session.
   --  Once re-connecting is done, the connection session refered to by AID is marked
   --  as <b<USED_SESSION_TYPE and a new AID cookie with the new connection session is
   --  returned to the user.
   CONNECT_SESSION_TYPE : constant Integer := 0;

   --  The session is a connection session whose associated AID cookie has been used.
   --  This session cannot be used to re-connect a user through the AID cookie.
   USED_SESSION_TYPE    : constant Integer := 2;

   --  Get the user name from the email address.
   --  Returns the possible user name from his email address.
   function Get_Name_From_Email (Email : in String) return String;

   type User_Service is new AWA.Modules.Module_Manager with private;
   type User_Service_Access is access all User_Service'Class;

   --  Build the authenticate cookie.  The cookie is signed using HMAC-SHA1 with a private key.
   function Get_Authenticate_Cookie (Model : in User_Service;
                                     Id    : in ADO.Identifier)
                                     return String;

   --  Get the authenticate identifier from the cookie.
   --  Verify that the cookie is valid, the signature is correct.
   --  Returns the identified or NO_IDENTIFIER
   function Get_Authenticate_Id (Model  : in User_Service;
                                 Cookie : in String) return ADO.Identifier;

   --  Get the password hash.  The password is signed using HMAC-SHA1 with the salt.
   function Get_Password_Hash (Model    : in User_Service;
                               Password : in String;
                               Salt     : in String)
                               return String;

   --  Create a user in the database with the given user information and
   --  the associated email address.  Verify that no such user already exist.
   --  Raises User_Exist exception if a user with such email is already registered.
   procedure Create_User (Model : in out User_Service;
                          User  : in out User_Ref'Class;
                          Email : in out Email_Ref'Class;
                          Key   : in String := "");

   --  Verify the access key and retrieve the user associated with that key.
   --  Starts a new session associated with the given IP address.
   --  The authenticated user is identified by a principal instance allocated
   --  and returned in Principal.
   --  Raises Not_Found if the access key does not exist.
   procedure Verify_User (Model     : in User_Service;
                          Key       : in String;
                          IpAddr    : in String;
                          Principal : out AWA.Users.Principals.Principal_Access);

   --  Authenticate the user with his email address and his password.
   --  If the user is authenticated, return the user information and
   --  create a new session.  The IP address of the connection is saved
   --  in the session.
   --  Raises Not_Found exception if the user is not recognized
   procedure Authenticate (Model     : in User_Service;
                           Email     : in String;
                           Password  : in String;
                           IpAddr    : in String;
                           Principal : out AWA.Users.Principals.Principal_Access);

   --  Authenticate the user with his OpenID identifier.  The authentication process
   --  was made by an external OpenID provider.  If the user does not yet exists in
   --  the database, a record is created for him.  Create a new session for the user.
   --  The IP address of the connection is saved in the session.
   --  Raises Not_Found exception if the user is not recognized
   procedure Authenticate (Model     : in User_Service;
                           Auth      : in Security.Auth.Authentication;
                           IpAddr    : in String;
                           Principal : out AWA.Users.Principals.Principal_Access);

   --  Authenticate the user with the authenticate cookie generated from a previous authenticate
   --  session.  If the cookie has the correct signature, matches a valid session,
   --  return the user information and create a new session.  The IP address of the connection
   --  is saved in the session.
   --  Raises Not_Found exception if the user is not recognized
   procedure Authenticate (Model     : in User_Service;
                           Cookie    : in String;
                           Ip_Addr   : in String;
                           Principal : out AWA.Users.Principals.Principal_Access);

   --  Start the lost password process for a user.  Find the user having
   --  the given email address and send that user a password reset key
   --  in an email.
   --  Raises Not_Found exception if no user with such email exist
   procedure Lost_Password (Model : in out User_Service;
                            Email : in String);

   --  Reset the password of the user associated with the secure key.
   --  Raises Not_Found if there is no key or if the user does not have any email
   procedure Reset_Password (Model    : in out User_Service;
                             Key      : in String;
                             Password : in String;
                             IpAddr   : in String;
                             Principal : out AWA.Users.Principals.Principal_Access);

   --  Verify that the user session identified by Id is valid and still active.
   --  Returns the user and the session objects.
   --  Raises Not_Found if the session does not exist or was closed.
   procedure Verify_Session (Model   : in User_Service;
                             Id      : in ADO.Identifier;
                             User    : out User_Ref'Class;
                             Session : out Session_Ref'Class);

   --  Closes the session identified by Id.  The session identified should refer to
   --  a valid and not closed connection session.
   --  When Logout is set, the authenticate session is also closed.  The connection
   --  sessions associated with the authenticate session are also closed.
   --  Raises Not_Found if the session is invalid or already closed.
   procedure Close_Session (Model  : in User_Service;
                            Id     : in ADO.Identifier;
                            Logout : in Boolean := False);

   --  Create and generate a new access key for the user.  The access key is saved in the
   --  database and it will expire after the expiration delay.
   procedure Create_Access_Key (Model   : in out User_Service;
                                User    : in AWA.Users.Models.User_Ref'Class;
                                Key     : in out AWA.Users.Models.Access_Key_Ref;
                                Kind    : in AWA.Users.Models.Key_Type;
                                Expire  : in Duration;
                                Session : in out ADO.Sessions.Master_Session);

   procedure Send_Alert (Model : in User_Service;
                         Kind  : in AWA.Events.Event_Index;
                         User  : in User_Ref'Class;
                         Props : in out AWA.Events.Module_Event);

   --  Initialize the user service.
   overriding
   procedure Initialize (Model  : in out User_Service;
                         Module : in AWA.Modules.Module'Class);

private

   function Create_Key (Model  : in out User_Service;
                        Number : in ADO.Identifier) return String;

   procedure Create_Session (Model   : in User_Service;
                             DB      : in out ADO.Sessions.Master_Session;
                             Session : out Session_Ref'Class;
                             User    : in User_Ref'Class;
                             Ip_Addr : in String;
                             Principal : out AWA.Users.Principals.Principal_Access);

   type User_Service is new AWA.Modules.Module_Manager with record
      Server_Id   : Integer := 0;
      Random      : Security.Random.Generator;
      Auth_Key    : Ada.Strings.Unbounded.Unbounded_String;
      Permissions : AWA.Permissions.Services.Permission_Manager_Access;
   end record;

end AWA.Users.Services;

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

with AWA.Users.Models;
with AWA.Users.Principals;
with AWA.Permissions.Services;
with AWA.Modules;
with AWA.Modules.Lifecycles;
with AWA.Events;
with Security.Auth;
with Security.Random;

with ADO;
with ADO.Sessions;

--  == Introduction ==
--  The *users* module provides a *users* service which controls the user data model.
--
--  == Events ==
--  The *users* module exposes a number of events which are posted when some action
--  are performed at the service level.
--
--  === user-register ===
--  This event is posted when a new user is registered in the application.
--  It can be used to send a registration email.
--
--  === user-create ===
--  This event is posted when a new user is created.  It can be used to trigger
--  the pre-initialization of the application for the new user.
--
--  === user-lost-password ===
--  This event is posted when a user asks for a password reset through an
--  anonymous form.  It is intended to be used to send the reset password email.
--
--  === user-reset-password ===
--  This event is posted when a user has successfully reset his password.
--  It can be used to send an email.
--
package AWA.Users.Services is

   use AWA.Users.Models;

   package User_Create_Event is new AWA.Events.Definition (Name => "user-create");
   package User_Register_Event is new AWA.Events.Definition (Name => "user-register");
   package User_Lost_Password_Event is new AWA.Events.Definition (Name => "user-lost-password");
   package User_Reset_Password_Event is new AWA.Events.Definition (Name => "user-reset-password");

   package User_Lifecycle is
     new AWA.Modules.Lifecycles (Element_Type => AWA.Users.Models.User_Ref'Class);

   subtype Listener is User_Lifecycle.Listener;

   NAME : constant String := "User_Service";

   Not_Found  : exception;

   User_Exist : exception;

   --  The session is an authenticate session.  The user authenticated using password or OpenID.
   --  When the user logout, this session is closed as well as any connection session linked to
   --  the authenticate session.
   AUTH_SESSION_TYPE    : constant Integer := 1;

   --  The session is a connection session.  It is linked to an authenticate session.
   --  This session can be closed automatically due to a timeout or user's inactivity.
   --  The AID cookie refers to this connection session to create a new connection session.
   --  Once re-connecting is done, the connection session refered to by AID is marked
   --  as <b<USED_SESSION_TYPE and a new AID cookie with the new connection session is
   --  returned to the user.
   CONNECT_SESSION_TYPE : constant Integer := 0;

   --  The session is a connection session whose associated AID cookie has been used.
   --  This session cannot be used to re-connect a user through the AID cookie.
   USED_SESSION_TYPE    : constant Integer := 2;

   --  Get the user name from the email address.
   --  Returns the possible user name from his email address.
   function Get_Name_From_Email (Email : in String) return String;

   type User_Service is new AWA.Modules.Module_Manager with private;
   type User_Service_Access is access all User_Service'Class;

   --  Build the authenticate cookie.  The cookie is signed using HMAC-SHA1 with a private key.
   function Get_Authenticate_Cookie (Model : in User_Service;
                                     Id    : in ADO.Identifier)
                                     return String;

   --  Get the authenticate identifier from the cookie.
   --  Verify that the cookie is valid, the signature is correct.
   --  Returns the identified or NO_IDENTIFIER
   function Get_Authenticate_Id (Model  : in User_Service;
                                 Cookie : in String) return ADO.Identifier;

   --  Get the password hash.  The password is signed using HMAC-SHA1 with the salt.
   function Get_Password_Hash (Model    : in User_Service;
                               Password : in String;
                               Salt     : in String)
                               return String;

   --  Create a user in the database with the given user information and
   --  the associated email address.  Verify that no such user already exist.
   --  Raises User_Exist exception if a user with such email is already registered.
   procedure Create_User (Model : in out User_Service;
                          User  : in out User_Ref'Class;
                          Email : in out Email_Ref'Class);

   --  Create a user in the database with the given user information and
   --  the associated email address and for the given access key.  The access key is first
   --  verified and the user instance associated with it is retrieved.  Verify that the email
   --  address is unique and can be used by the user.  Since the access key is verified,
   --  grant immediately the access by opening a session and setting up the principal instance.
   --  Raises User_Exist exception if a user with such email is already registered.
   procedure Create_User (Model     : in out User_Service;
                          User      : in out User_Ref'Class;
                          Email     : in out Email_Ref'Class;
                          Key       : in String;
                          IpAddr    : in String;
                          Principal : out AWA.Users.Principals.Principal_Access);

   --  Verify the access key and retrieve the user associated with that key.
   --  Starts a new session associated with the given IP address.
   --  The authenticated user is identified by a principal instance allocated
   --  and returned in Principal.
   --  Raises Not_Found if the access key does not exist.
   procedure Verify_User (Model     : in User_Service;
                          Key       : in String;
                          IpAddr    : in String;
                          Principal : out AWA.Users.Principals.Principal_Access);

   --  Authenticate the user with his email address and his password.
   --  If the user is authenticated, return the user information and
   --  create a new session.  The IP address of the connection is saved
   --  in the session.
   --  Raises Not_Found exception if the user is not recognized
   procedure Authenticate (Model     : in User_Service;
                           Email     : in String;
                           Password  : in String;
                           IpAddr    : in String;
                           Principal : out AWA.Users.Principals.Principal_Access);

   --  Authenticate the user with his OpenID identifier.  The authentication process
   --  was made by an external OpenID provider.  If the user does not yet exists in
   --  the database, a record is created for him.  Create a new session for the user.
   --  The IP address of the connection is saved in the session.
   --  Raises Not_Found exception if the user is not recognized
   procedure Authenticate (Model     : in User_Service;
                           Auth      : in Security.Auth.Authentication;
                           IpAddr    : in String;
                           Principal : out AWA.Users.Principals.Principal_Access);

   --  Authenticate the user with the authenticate cookie generated from a previous authenticate
   --  session.  If the cookie has the correct signature, matches a valid session,
   --  return the user information and create a new session.  The IP address of the connection
   --  is saved in the session.
   --  Raises Not_Found exception if the user is not recognized
   procedure Authenticate (Model     : in User_Service;
                           Cookie    : in String;
                           Ip_Addr   : in String;
                           Principal : out AWA.Users.Principals.Principal_Access);

   --  Start the lost password process for a user.  Find the user having
   --  the given email address and send that user a password reset key
   --  in an email.
   --  Raises Not_Found exception if no user with such email exist
   procedure Lost_Password (Model : in out User_Service;
                            Email : in String);

   --  Reset the password of the user associated with the secure key.
   --  Raises Not_Found if there is no key or if the user does not have any email
   procedure Reset_Password (Model    : in out User_Service;
                             Key      : in String;
                             Password : in String;
                             IpAddr   : in String;
                             Principal : out AWA.Users.Principals.Principal_Access);

   --  Verify that the user session identified by Id is valid and still active.
   --  Returns the user and the session objects.
   --  Raises Not_Found if the session does not exist or was closed.
   procedure Verify_Session (Model   : in User_Service;
                             Id      : in ADO.Identifier;
                             User    : out User_Ref'Class;
                             Session : out Session_Ref'Class);

   --  Closes the session identified by Id.  The session identified should refer to
   --  a valid and not closed connection session.
   --  When Logout is set, the authenticate session is also closed.  The connection
   --  sessions associated with the authenticate session are also closed.
   --  Raises Not_Found if the session is invalid or already closed.
   procedure Close_Session (Model  : in User_Service;
                            Id     : in ADO.Identifier;
                            Logout : in Boolean := False);

   --  Create and generate a new access key for the user.  The access key is saved in the
   --  database and it will expire after the expiration delay.
   procedure Create_Access_Key (Model   : in out User_Service;
                                User    : in AWA.Users.Models.User_Ref'Class;
                                Key     : in out AWA.Users.Models.Access_Key_Ref;
                                Kind    : in AWA.Users.Models.Key_Type;
                                Expire  : in Duration;
                                Session : in out ADO.Sessions.Master_Session);

   procedure Send_Alert (Model : in User_Service;
                         Kind  : in AWA.Events.Event_Index;
                         User  : in User_Ref'Class;
                         Props : in out AWA.Events.Module_Event);

   --  Initialize the user service.
   overriding
   procedure Initialize (Model  : in out User_Service;
                         Module : in AWA.Modules.Module'Class);

private

   function Create_Key (Model  : in out User_Service;
                        Number : in ADO.Identifier) return String;

   procedure Create_Session (Model   : in User_Service;
                             DB      : in out ADO.Sessions.Master_Session;
                             Session : out Session_Ref'Class;
                             User    : in User_Ref'Class;
                             Ip_Addr : in String;
                             Principal : out AWA.Users.Principals.Principal_Access);

   type User_Service is new AWA.Modules.Module_Manager with record
      Server_Id   : Integer := 0;
      Random      : Security.Random.Generator;
      Auth_Key    : Ada.Strings.Unbounded.Unbounded_String;
      Permissions : AWA.Permissions.Services.Permission_Manager_Access;
   end record;

end AWA.Users.Services;

Declare a Create_User procedure to register a new user with an access key


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

with ADO;
with AWA.Users.Models;
with ASF.Principals;
with Security.Permissions;
package AWA.Users.Principals is

   type Principal is new ASF.Principals.Principal with private;
   type Principal_Access is access all Principal'Class;

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

   --  Returns true if the given role is stored in the user principal.
   function Has_Role (User : in Principal;
                      Role : in Security.Permissions.Role_Type) return Boolean;

   --  Get the principal identifier (name)
   function Get_Id (From : in Principal) return String;

   --  Get the user associated with the principal.
   function Get_User (From : in Principal) return AWA.Users.Models.User_Ref;

   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none.
   function Get_User_Identifier (From : in Principal) return ADO.Identifier;

   --  Get the connection session used by the user.
   function Get_Session (From : in Principal) return AWA.Users.Models.Session_Ref;

   --  Get the connection session identifier used by the user.
   function Get_Session_Identifier (From : in Principal) return ADO.Identifier;

   --  Create a principal for the given user.
   function Create (User    : in AWA.Users.Models.User_Ref;
                    Session : in AWA.Users.Models.Session_Ref) return Principal_Access;

   --  Utility functions based on the security principal access type.

   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none or if the principal is not an AWA principal.
   function Get_User_Identifier (From : in Security.Permissions.Principal_Access)
                                 return ADO.Identifier;

private

   type Principal is new ASF.Principals.Principal with record
      User        : AWA.Users.Models.User_Ref;
      Session     : AWA.Users.Models.Session_Ref;
      Roles       : Security.Permissions.Role_Map;
   end record;

end AWA.Users.Principals;

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

with ADO;
with AWA.Users.Models;
with ASF.Principals;
with Security.Permissions;
package AWA.Users.Principals is

   type Principal is new ASF.Principals.Principal with private;
   type Principal_Access is access all Principal'Class;

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

   --  Returns true if the given role is stored in the user principal.
   function Has_Role (User : in Principal;
                      Role : in Security.Permissions.Role_Type) return Boolean;

   --  Get the principal identifier (name)
   function Get_Id (From : in Principal) return String;

   --  Get the user associated with the principal.
   function Get_User (From : in Principal) return AWA.Users.Models.User_Ref;

   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none.
   function Get_User_Identifier (From : in Principal) return ADO.Identifier;

   --  Get the connection session used by the user.
   function Get_Session (From : in Principal) return AWA.Users.Models.Session_Ref;

   --  Get the connection session identifier used by the user.
   function Get_Session_Identifier (From : in Principal) return ADO.Identifier;

   --  Create a principal for the given user.
   function Create (User    : in AWA.Users.Models.User_Ref;
                    Session : in AWA.Users.Models.Session_Ref) return Principal_Access;

   --  Utility functions based on the security principal access type.

   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none or if the principal is not an AWA principal.
   function Get_User_Identifier (From : in ASF.Principals.Principal_Access)
                                 return ADO.Identifier;

private

   type Principal is new ASF.Principals.Principal with record
      User        : AWA.Users.Models.User_Ref;
      Session     : AWA.Users.Models.Session_Ref;
      Roles       : Security.Permissions.Role_Map;
   end record;

end AWA.Users.Principals;

Use ASF Principal definitions

Use ASF Principal definitions


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

--  The Util.Encodes.SHA1 package generates SHA-1 hash according to
--  RFC3174 or [FIPS-180-1].
package Util.Encoders.AES is

   use type Ada.Streams.Stream_Element_Offset;

   type AES_Mode is (ECB, CBC, PCBC, CFB, OFB, CTR);

   type Key_Type is private;

   --  ------------------------------
   --  ------------------------------
   subtype Block_Type is Ada.Streams.Stream_Element_Array (1 .. 16);

   type Word_Block_Type is array (1 .. 4) of Interfaces.Unsigned_32;

   procedure Set_Encrypt_Key (Key  : out Key_Type;
                              Data : in Ada.Streams.Stream_Element_Array)
     with Pre => Data'Length = 16 or Data'Length = 24 or Data'Length = 32;

   procedure Set_Decrypt_Key (Key  : out Key_Type;
                              Data : in Ada.Streams.Stream_Element_Array);

   procedure Encrypt (Input  : in Block_Type;
                      Output : out Block_Type;
                      Key    : in Key_Type);
   procedure Encrypt (Input  : in Word_Block_Type;
                      Output : out Word_Block_Type;
                      Key    : in Key_Type);

   procedure Encrypt (Input  : in Ada.Streams.Stream_Element_Array;
                      Output : out Ada.Streams.Stream_Element_Array;
                      Last   : out Ada.Streams.Stream_Element_Offset;
                      Key    : in Key_Type);

   procedure Decrypt (Input  : in Block_Type;
                      Output : out Block_Type;
                      Key    : in Key_Type);

   procedure Decrypt (Input  : in Word_Block_Type;
                      Output : out Word_Block_Type;
                      Key    : in Key_Type);

   type Cipher is tagged limited private;

   --  Set the encryption initialization vector before starting the encryption.
   procedure Set_IV (E  : in out Cipher;
                     IV : in Word_Block_Type);

   --  ------------------------------
   --  AES encoder
   --  ------------------------------
   --  This Encoder translates the (binary) input stream into
   --  an SHA1 hexadecimal stream.  The encoding alphabet is: 0123456789ABCDEF.
   type Encoder is new Cipher and Util.Encoders.Transformer with private;

   --  Set the encryption key to use.
   procedure Set_Key (E    : in out Encoder;
                      Data : in Ada.Streams.Stream_Element_Array;
                      Mode : in AES_Mode := CBC);

   --  Encodes the binary input stream represented by Data into
   --  an SHA-1 hash output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   overriding
   procedure Transform (E       : in out Encoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset);

   --  Finish encoding the input array.
   overriding
   procedure Finish (E    : in out Encoder;
                     Into : in out Ada.Streams.Stream_Element_Array;
                     Last : in out Ada.Streams.Stream_Element_Offset)
     with Pre => Into'Length >= Block_Type'Length,
     Post => Last = Into'First - 1 or Last = Into'First + Block_Type'Length;

   --  ------------------------------
   --  AES encoder
   --  ------------------------------
   --  This Encoder translates the (binary) input stream into
   --  an SHA1 hexadecimal stream.  The encoding alphabet is: 0123456789ABCDEF.
   type Decoder is new Cipher and Util.Encoders.Transformer with private;

   --  Set the decryption key to use.
   procedure Set_Key (E    : in out Decoder;
                      Data : in Ada.Streams.Stream_Element_Array;
                      Mode : in AES_Mode := CBC);

   --  Encodes the binary input stream represented by Data into
   --  an SHA-1 hash output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   overriding
   procedure Transform (E       : in out Decoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset);

   --  Finish encoding the input array.
   overriding
   procedure Finish (E    : in out Decoder;
                     Into : in out Ada.Streams.Stream_Element_Array;
                     Last : in out Ada.Streams.Stream_Element_Offset);

private

   use Interfaces;

   type Block_Key is array (0 .. 59) of Unsigned_32;

   type Key_Type is record
      Key    : Block_Key;
      Rounds : Natural := 0;
   end record;

   type Cipher is limited new Ada.Finalization.Limited_Controlled with record
      IV         : Word_Block_Type;
      Key        : Key_Type;
      Mode       : AES_Mode := CBC;
      Data_Count : Ada.Streams.Stream_Element_Offset := 0;
      Data       : Block_Type;
   end record;

   overriding
   procedure Finalize (Object : in out Cipher);

   type Encoder is new Cipher and Util.Encoders.Transformer with null record;

   type Decoder is new Cipher and Util.Encoders.Transformer with null record;

end Util.Encoders.AES;

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

--  The Util.Encodes.SHA1 package generates SHA-1 hash according to
--  RFC3174 or [FIPS-180-1].
package Util.Encoders.AES is

   use type Ada.Streams.Stream_Element_Offset;

   type AES_Mode is (ECB, CBC, PCBC, CFB, OFB, CTR);

   type Key_Type is private;

   --  ------------------------------
   --  ------------------------------
   subtype Block_Type is Ada.Streams.Stream_Element_Array (1 .. 16);

   subtype AES_128_Key is Ada.Streams.Stream_Element_Array (1 .. 16);
   subtype AES_192_Key is Ada.Streams.Stream_Element_Array (1 .. 24);
   subtype AES_256_Key is Ada.Streams.Stream_Element_Array (1 .. 32);

   type Word_Block_Type is array (1 .. 4) of Interfaces.Unsigned_32;

   procedure Set_Encrypt_Key (Key  : out Key_Type;
                              Data : in Ada.Streams.Stream_Element_Array)
     with Pre => Data'Length = 16 or Data'Length = 24 or Data'Length = 32;

   procedure Set_Decrypt_Key (Key  : out Key_Type;
                              Data : in Ada.Streams.Stream_Element_Array);

   procedure Encrypt (Input  : in Block_Type;
                      Output : out Block_Type;
                      Key    : in Key_Type);
   procedure Encrypt (Input  : in Word_Block_Type;
                      Output : out Word_Block_Type;
                      Key    : in Key_Type);

   procedure Encrypt (Input  : in Ada.Streams.Stream_Element_Array;
                      Output : out Ada.Streams.Stream_Element_Array;
                      Last   : out Ada.Streams.Stream_Element_Offset;
                      Key    : in Key_Type);

   procedure Decrypt (Input  : in Block_Type;
                      Output : out Block_Type;
                      Key    : in Key_Type);

   procedure Decrypt (Input  : in Word_Block_Type;
                      Output : out Word_Block_Type;
                      Key    : in Key_Type);

   type Cipher is tagged limited private;

   --  Set the encryption initialization vector before starting the encryption.
   procedure Set_IV (E  : in out Cipher;
                     IV : in Word_Block_Type);

   --  ------------------------------
   --  AES encoder
   --  ------------------------------
   --  This Encoder translates the (binary) input stream into
   --  an SHA1 hexadecimal stream.  The encoding alphabet is: 0123456789ABCDEF.
   type Encoder is new Cipher and Util.Encoders.Transformer with private;

   --  Set the encryption key to use.
   procedure Set_Key (E    : in out Encoder;
                      Data : in Ada.Streams.Stream_Element_Array;
                      Mode : in AES_Mode := CBC);

   --  Encodes the binary input stream represented by Data into
   --  an SHA-1 hash output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   overriding
   procedure Transform (E       : in out Encoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset);

   --  Finish encoding the input array.
   overriding
   procedure Finish (E    : in out Encoder;
                     Into : in out Ada.Streams.Stream_Element_Array;
                     Last : in out Ada.Streams.Stream_Element_Offset)
     with Pre => Into'Length >= Block_Type'Length,
     Post => Last = Into'First - 1 or Last = Into'First + Block_Type'Length;

   --  ------------------------------
   --  AES encoder
   --  ------------------------------
   --  This Encoder translates the (binary) input stream into
   --  an SHA1 hexadecimal stream.  The encoding alphabet is: 0123456789ABCDEF.
   type Decoder is new Cipher and Util.Encoders.Transformer with private;

   --  Set the decryption key to use.
   procedure Set_Key (E    : in out Decoder;
                      Data : in Ada.Streams.Stream_Element_Array;
                      Mode : in AES_Mode := CBC);

   --  Encodes the binary input stream represented by Data into
   --  an SHA-1 hash output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   overriding
   procedure Transform (E       : in out Decoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset);

   --  Finish encoding the input array.
   overriding
   procedure Finish (E    : in out Decoder;
                     Into : in out Ada.Streams.Stream_Element_Array;
                     Last : in out Ada.Streams.Stream_Element_Offset);

private

   use Interfaces;

   type Block_Key is array (0 .. 59) of Unsigned_32;

   type Key_Type is record
      Key    : Block_Key := (others => 0);
      Rounds : Natural := 0;
   end record;

   type Cipher is limited new Ada.Finalization.Limited_Controlled with record
      IV         : Word_Block_Type;
      Key        : Key_Type;
      Mode       : AES_Mode := CBC;
      Data_Count : Ada.Streams.Stream_Element_Offset := 0;
      Data       : Block_Type;
   end record;

   overriding
   procedure Finalize (Object : in out Cipher);

   type Encoder is new Cipher and Util.Encoders.Transformer with null record;

   type Decoder is new Cipher and Util.Encoders.Transformer with null record;

end Util.Encoders.AES;

Declare AES_128_Key, AES_192_Key, AES_256_Key types


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

with Sqlite3_H;
with Interfaces.C;
package ADO.Drivers.Connections.Sqlite is

   subtype Sqlite3 is Sqlite3_H.sqlite3;

   --  The database connection manager
   type Sqlite_Driver is limited private;

   --  Initialize the SQLite driver.
   procedure Initialize;

private

   --  Database connection implementation
   type Database_Connection is new ADO.Drivers.Connections.Database_Connection with record
      Server : aliased access Sqlite3_H.sqlite3;
      Name   : Unbounded_String;
   end record;
   type Database_Connection_Access is access all Database_Connection'Class;

   --  Get the database driver which manages this connection.
   overriding
   function Get_Driver (Database : in Database_Connection)
                        return Driver_Access;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement_Access;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Query    : in String)
                              return Query_Statement_Access;

   --  Create a delete statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement_Access;

   --  Create an insert statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement_Access;

   --  Create an update statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement_Access;

   --  Start a transaction.
   overriding
   procedure Begin_Transaction (Database : in out Database_Connection);

   --  Commit the current transaction.
   overriding
   procedure Commit (Database : in out Database_Connection);

   --  Rollback the current transaction.
   overriding
   procedure Rollback (Database : in out Database_Connection);

   --  Load the database schema definition for the current database.
   overriding
   procedure Load_Schema (Database : in Database_Connection;
                          Schema   : out ADO.Schemas.Schema_Definition);

   --  Closes the database connection
   overriding
   procedure Close (Database : in out Database_Connection);

   --  Releases the sqlite connection if it is open
   overriding
   procedure Finalize (Database : in out Database_Connection);

   type Sqlite_Driver is new ADO.Drivers.Connections.Driver with null record;

   --  Create a new SQLite connection using the configuration parameters.
   overriding
   procedure Create_Connection (D      : in out Sqlite_Driver;
                                Config : in Configuration'Class;
                                Result : in out Ref.Ref'Class);

end ADO.Drivers.Connections.Sqlite;

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

with Sqlite3_H;
package ADO.Drivers.Connections.Sqlite is

   subtype Sqlite3 is Sqlite3_H.sqlite3;

   --  The database connection manager
   type Sqlite_Driver is limited private;

   --  Initialize the SQLite driver.
   procedure Initialize;

private

   --  Database connection implementation
   type Database_Connection is new ADO.Drivers.Connections.Database_Connection with record
      Server : aliased access Sqlite3_H.sqlite3;
      Name   : Unbounded_String;
   end record;
   type Database_Connection_Access is access all Database_Connection'Class;

   --  Get the database driver which manages this connection.
   overriding
   function Get_Driver (Database : in Database_Connection)
                        return Driver_Access;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement_Access;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Query    : in String)
                              return Query_Statement_Access;

   --  Create a delete statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement_Access;

   --  Create an insert statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement_Access;

   --  Create an update statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement_Access;

   --  Start a transaction.
   overriding
   procedure Begin_Transaction (Database : in out Database_Connection);

   --  Commit the current transaction.
   overriding
   procedure Commit (Database : in out Database_Connection);

   --  Rollback the current transaction.
   overriding
   procedure Rollback (Database : in out Database_Connection);

   --  Load the database schema definition for the current database.
   overriding
   procedure Load_Schema (Database : in Database_Connection;
                          Schema   : out ADO.Schemas.Schema_Definition);

   --  Create the database and initialize it with the schema SQL file.
   overriding
   procedure Create_Database (Database    : in Database_Connection;
                              Config      : in Configs.Configuration'Class;
                              Schema_Path : in String;
                              Messages    : out Util.Strings.Vectors.Vector);

   --  Closes the database connection
   overriding
   procedure Close (Database : in out Database_Connection);

   --  Releases the sqlite connection if it is open
   overriding
   procedure Finalize (Database : in out Database_Connection);

   type Sqlite_Driver is new ADO.Drivers.Connections.Driver with null record;

   --  Create a new SQLite connection using the configuration parameters.
   overriding
   procedure Create_Connection (D      : in out Sqlite_Driver;
                                Config : in Configuration'Class;
                                Result : in out Ref.Ref'Class);

end ADO.Drivers.Connections.Sqlite;

Declare the Create_Database procedure

Declare the Create_Database procedure


------------------------------------------------------------------------------
-- Copyright (c) 2015, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Ada.Directories;
with Ada.Streams.Stream_IO;
with Natools.File_Streams;
with Natools.S_Expressions.Atom_Ref_Constructors;

package body Natools.Web.Backends.Filesystem is

   package Stream_IO renames Ada.Streams.Stream_IO;

   function Compose
     (Self : File_Backend;
      Directory, Name : S_Expressions.Atom)
     return String;

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   function Compose
     (Self : File_Backend;
      Directory, Name : S_Expressions.Atom)
     return String is
   begin
      return Ada.Directories.Compose
        (S_Expressions.To_String (Self.Root.Query)
           & S_Expressions.To_String (Directory),
         S_Expressions.To_String (Name));
   end Compose;

   ----------------------
   -- Public Interface --
   ----------------------

   overriding function Append
     (Self : in out File_Backend;
      Directory, Name : in S_Expressions.Atom)
     return Ada.Streams.Root_Stream_Type'Class is
   begin
      return File_Streams.Open
        (Stream_IO.Append_File,
         Compose (Self, Directory, Name));
   end Append;

   not overriding function Create (Root : in String) return File_Backend is
   begin
      return (Root => S_Expressions.Atom_Ref_Constructors.Create
                        (S_Expressions.To_Atom (Root)));
   end Create;

   function Create
     (Arguments : in out S_Expressions.Lockable.Descriptor'Class)
     return Backend'Class is
   begin
      case Arguments.Current_Event is
         when S_Expressions.Events.Add_Atom =>
            return File_Backend'
              (Root => S_Expressions.Atom_Ref_Constructors.Create
                 (Arguments.Current_Atom));
         when others =>
            raise Constraint_Error with "File_System backend expects an atom";
      end case;
   end Create;

   overriding function Create
     (Self : in out File_Backend;
      Directory, Name : in S_Expressions.Atom)
     return Ada.Streams.Root_Stream_Type'Class is
   begin
      return File_Streams.Create
        (Stream_IO.Append_File,
         Compose (Self, Directory, Name));
   end Create;

   overriding procedure Delete
     (Self : in out File_Backend;
      Directory, Name : in S_Expressions.Atom) is
   begin
      Ada.Directories.Delete_File (Compose (Self, Directory, Name));
   end Delete;

   overriding procedure Iterate
     (Self : in File_Backend;
      Directory : in S_Expressions.Atom;
      Process : not null access procedure (Name : in S_Expressions.Atom))
   is
      Search : Ada.Directories.Search_Type;
      Directory_Entry : Ada.Directories.Directory_Entry_Type;
   begin
      Ada.Directories.Start_Search
        (Search => Search,
         Directory => S_Expressions.To_String (Self.Root.Query)
                        & S_Expressions.To_String (Directory),
         Pattern => "",
         Filter => (Ada.Directories.Ordinary_File => True, others => False));

      while Ada.Directories.More_Entries (Search) loop
         Ada.Directories.Get_Next_Entry (Search, Directory_Entry);
         Process.all
           (S_Expressions.To_Atom
              (Ada.Directories.Simple_Name (Directory_Entry)));
      end loop;

      Ada.Directories.End_Search (Search);
   end Iterate;

   overriding function Overwrite
     (Self : in out File_Backend;
      Directory, Name : in S_Expressions.Atom)
     return Ada.Streams.Root_Stream_Type'Class is
   begin
      return File_Streams.Open
        (Stream_IO.Out_File,
         Compose (Self, Directory, Name));
   end Overwrite;

   overriding function Read
     (Self : in File_Backend;
      Directory, Name : in S_Expressions.Atom)
     return Ada.Streams.Root_Stream_Type'Class is
   begin
      return File_Streams.Open
        (Stream_IO.In_File,
         Compose (Self, Directory, Name));
   end Read;

end Natools.Web.Backends.Filesystem;

------------------------------------------------------------------------------
-- Copyright (c) 2015, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Ada.Directories;
with Ada.Streams.Stream_IO;
with Natools.File_Streams;
with Natools.S_Expressions.Atom_Ref_Constructors;

package body Natools.Web.Backends.Filesystem is

   package Stream_IO renames Ada.Streams.Stream_IO;

   function Compose
     (Self : File_Backend;
      Directory, Name : S_Expressions.Atom)
     return String;

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   function Compose
     (Self : File_Backend;
      Directory, Name : S_Expressions.Atom)
     return String is
   begin
      return Ada.Directories.Compose
        (S_Expressions.To_String (Self.Root.Query)
           & S_Expressions.To_String (Directory),
         S_Expressions.To_String (Name));
   end Compose;

   ----------------------
   -- Public Interface --
   ----------------------

   overriding function Append
     (Self : in out File_Backend;
      Directory, Name : in S_Expressions.Atom)
     return Ada.Streams.Root_Stream_Type'Class is
   begin
      return File_Streams.Open
        (Stream_IO.Append_File,
         Compose (Self, Directory, Name));
   end Append;

   not overriding function Create (Root : in String) return File_Backend is
   begin
      return (Root => S_Expressions.Atom_Ref_Constructors.Create
                        (S_Expressions.To_Atom (Root)));
   end Create;

   function Create
     (Arguments : in out S_Expressions.Lockable.Descriptor'Class)
     return Backend'Class is
   begin
      case Arguments.Current_Event is
         when S_Expressions.Events.Add_Atom =>
            return File_Backend'
              (Root => S_Expressions.Atom_Ref_Constructors.Create
                 (Arguments.Current_Atom));
         when others =>
            raise Constraint_Error with "File_System backend expects an atom";
      end case;
   end Create;

   overriding function Create
     (Self : in out File_Backend;
      Directory, Name : in S_Expressions.Atom)
     return Ada.Streams.Root_Stream_Type'Class is
   begin
      Ada.Directories.Create_Path
        (S_Expressions.To_String (Self.Root.Query)
           & S_Expressions.To_String (Directory));

      return File_Streams.Create
        (Stream_IO.Append_File,
         Compose (Self, Directory, Name));
   end Create;

   overriding procedure Delete
     (Self : in out File_Backend;
      Directory, Name : in S_Expressions.Atom) is
   begin
      Ada.Directories.Delete_File (Compose (Self, Directory, Name));
   end Delete;

   overriding procedure Iterate
     (Self : in File_Backend;
      Directory : in S_Expressions.Atom;
      Process : not null access procedure (Name : in S_Expressions.Atom))
   is
      Search : Ada.Directories.Search_Type;
      Directory_Entry : Ada.Directories.Directory_Entry_Type;
   begin
      Ada.Directories.Start_Search
        (Search => Search,
         Directory => S_Expressions.To_String (Self.Root.Query)
                        & S_Expressions.To_String (Directory),
         Pattern => "",
         Filter => (Ada.Directories.Ordinary_File => True, others => False));

      while Ada.Directories.More_Entries (Search) loop
         Ada.Directories.Get_Next_Entry (Search, Directory_Entry);
         Process.all
           (S_Expressions.To_Atom
              (Ada.Directories.Simple_Name (Directory_Entry)));
      end loop;

      Ada.Directories.End_Search (Search);
   end Iterate;

   overriding function Overwrite
     (Self : in out File_Backend;
      Directory, Name : in S_Expressions.Atom)
     return Ada.Streams.Root_Stream_Type'Class is
   begin
      return File_Streams.Open
        (Stream_IO.Out_File,
         Compose (Self, Directory, Name));
   end Overwrite;

   overriding function Read
     (Self : in File_Backend;
      Directory, Name : in S_Expressions.Atom)
     return Ada.Streams.Root_Stream_Type'Class is
   begin
      return File_Streams.Open
        (Stream_IO.In_File,
         Compose (Self, Directory, Name));
   end Read;

end Natools.Web.Backends.Filesystem;

backends-filesystem: create the containing directory when creating a file