-----------------------------------------------------------------------
--  awa-commands-drivers -- Driver for AWA commands for server or admin tool
--  Copyright (C) 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 GNAT.Command_Line;
with GNAT.Strings;
with Util.Commands.Drivers;
with Util.Commands.Parsers.GNAT_Parser;
with Servlet.Server;
with AWA.Applications;
generic
   Driver_Name : String;
   type Container_Type is limited new Servlet.Server.Container with private;
package AWA.Commands.Drivers is

   package Main_Driver is
     new Util.Commands.Drivers (Context_Type  => Context_Type,
                                Config_Parser => Util.Commands.Parsers.GNAT_Parser.Config_Parser,
                                Driver_Name   => Driver_Name);

   subtype Help_Command_Type is Main_Driver.Help_Command_Type;
   subtype Driver_Type is Main_Driver.Driver_Type;

   type Command_Type is abstract new Main_Driver.Command_Type with null record;

   --  Setup the command before parsing the arguments and executing it.
   overriding
   procedure Setup (Command : in out Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration;
                    Context : in out Context_Type);

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in out Command_Type;
                   Name      : in String;
                   Context   : in out Context_Type);

   type Application_Command_Type is abstract new Command_Type with record
      Application_Name : aliased GNAT.Strings.String_Access;
   end record;

   function Is_Application (Command : in Application_Command_Type;
                            URI     : in String) return Boolean;

   procedure Execute (Command     : in out Application_Command_Type;
                      Application : in out AWA.Applications.Application'Class;
                      Args        : in Argument_List'Class;
                      Context     : in out Context_Type) is abstract;

   --  Setup the command before parsing the arguments and executing it.
   overriding
   procedure Setup (Command : in out Application_Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration;
                    Context : in out Context_Type);

   overriding
   procedure Execute (Command   : in out Application_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type);

   --  Print the command usage.
   procedure Usage (Args    : in Argument_List'Class;
                    Context : in out Context_Type;
                    Name    : in String := "");

   --  Execute the command with its arguments.
   procedure Execute (Name    : in String;
                      Args    : in Argument_List'Class;
                      Context : in out Context_Type);

   procedure Run (Context   : in out Context_Type;
                  Arguments : out Util.Commands.Dynamic_Argument_List);

   Driver   : Drivers.Driver_Type;
   WS       : Container_Type;

end AWA.Commands.Drivers;

-----------------------------------------------------------------------
--  awa-commands-drivers -- Driver for AWA commands for server or admin tool
--  Copyright (C) 2020, 2021 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with GNAT.Command_Line;
with GNAT.Strings;
with Util.Commands.Drivers;
with Util.Commands.Parsers.GNAT_Parser;
with Servlet.Server;
with AWA.Applications;
generic
   Driver_Name : String;
   type Container_Type is limited new Servlet.Server.Container with private;
package AWA.Commands.Drivers is

   package Main_Driver is
     new Util.Commands.Drivers (Context_Type  => Context_Type,
                                Config_Parser => Util.Commands.Parsers.GNAT_Parser.Config_Parser,
                                Driver_Name   => Driver_Name);

   subtype Help_Command_Type is Main_Driver.Help_Command_Type;
   subtype Driver_Type is Main_Driver.Driver_Type;

   --  Get the server configuration file path.
   function Get_Configuration_Path (Context : in out Context_Type) return String;

   type Command_Type is abstract new Main_Driver.Command_Type with null record;

   --  Setup the command before parsing the arguments and executing it.
   overriding
   procedure Setup (Command : in out Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration;
                    Context : in out Context_Type);

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in out Command_Type;
                   Name      : in String;
                   Context   : in out Context_Type);

   type Application_Command_Type is abstract new Command_Type with record
      Application_Name : aliased GNAT.Strings.String_Access;
   end record;

   function Is_Application (Command : in Application_Command_Type;
                            URI     : in String) return Boolean;

   procedure Execute (Command     : in out Application_Command_Type;
                      Application : in out AWA.Applications.Application'Class;
                      Args        : in Argument_List'Class;
                      Context     : in out Context_Type) is abstract;

   --  Setup the command before parsing the arguments and executing it.
   overriding
   procedure Setup (Command : in out Application_Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration;
                    Context : in out Context_Type);

   overriding
   procedure Execute (Command   : in out Application_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type);

   --  Print the command usage.
   procedure Usage (Args    : in Argument_List'Class;
                    Context : in out Context_Type;
                    Name    : in String := "");

   --  Execute the command with its arguments.
   procedure Execute (Name    : in String;
                      Args    : in Argument_List'Class;
                      Context : in out Context_Type);

   procedure Run (Context   : in out Context_Type;
                  Arguments : out Util.Commands.Dynamic_Argument_List);

   Driver   : Drivers.Driver_Type;
   WS       : Container_Type;

end AWA.Commands.Drivers;

Add Get_Configuration_Path function

Add Get_Configuration_Path function


with GL.Types;

with Orka.Logging;
with Orka.Resources.Locations.Directories;
with Orka.Rendering.Programs.Modules;
with Orka.Rendering.Drawing;
with Orka.Windows;

with AWT.Drag_And_Drop;

package body Package_Test 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);

   protected body Dnd_Signal is
      procedure Set is
      begin
         Dropped := True;
      end Set;

      entry Wait when Dropped is
      begin
         Dropped := False;
      end Wait;
   end Dnd_Signal;

   overriding
   function On_Close (Object : Test_Window) return Boolean is
   begin
      Messages.Log (Debug, "User is trying to close window");
      return True;
   end On_Close;

   overriding
   procedure On_Drag
     (Object : in out Test_Window;
      X, Y   : AWT.Inputs.Fixed)
   is
      use all type AWT.Inputs.Action_Kind;
      use type AWT.Inputs.Fixed;
   begin
      Messages.Log (Debug, "User dragged something to " &
        "(" & Trim (X'Image) & ", " & Trim (Y'Image) & ")");
      AWT.Drag_And_Drop.Set_Action (if X < 300.0 and Y < 300.0 then Copy else None);
   end On_Drag;

   overriding
   procedure On_Drop
     (Object : in out Test_Window)
   is
      use all type AWT.Inputs.Action_Kind;

      Action : constant AWT.Inputs.Action_Kind := AWT.Drag_And_Drop.Valid_Action;
   begin
      Messages.Log (Info, "User dropped something. Action is " & Action'Image);

      if Action /= None then
         Dnd_Signal.Set;
      end if;
   end On_Drop;

   overriding
   procedure On_Configure
     (Object       : in out Test_Window;
      State        : Standard.AWT.Windows.Window_State) is
   begin
      Messages.Log (Debug, "Configured window surface");
      Messages.Log (Debug, "  size:   " &
        Trim (State.Width'Image) & " × " & Trim (State.Height'Image));
      Messages.Log (Debug, "  margin: " & Trim (State.Margin'Image));

      Object.Resize := State.Visible and State.Width > 0 and State.Height > 0;
   end On_Configure;

   procedure Initialize_Framebuffer (Object : in out Test_Window) is
      Alpha : constant GL.Types.Single := (if Object.State.Transparent then 0.5 else 1.0);
   begin
      Object.FB :=
        Orka.Rendering.Framebuffers.Create_Default_Framebuffer (Object.Width, Object.Height);
      Object.FB.Set_Default_Values ((Color => (0.0, 0.0, 0.0, Alpha), others => <>));
      Object.FB.Use_Framebuffer;
      Messages.Log (Debug, "Changed size of framebuffer to " &
        Trim (Object.Width'Image) & " × " & Trim (Object.Height'Image));
   end Initialize_Framebuffer;

   procedure Post_Initialize (Object : in out Test_Window) is
      Location_Shaders : constant Orka.Resources.Locations.Location_Ptr :=
        Orka.Resources.Locations.Directories.Create_Location ("data");
   begin
      Object.Initialize_Framebuffer;

      Object.Program  := Orka.Rendering.Programs.Create_Program
        (Orka.Rendering.Programs.Modules.Create_Module
           (Location_Shaders,
            VS => "cursor.vert",
            FS => "cursor.frag"));
      Object.Program.Use_Program;

      Object.Cursor := Object.Program.Uniform ("cursor");
   end Post_Initialize;

   procedure Render (Object : in out Test_Window) is
      use type GL.Types.Single;
      use Standard.AWT.Inputs;

      Window_State  : constant Standard.AWT.Windows.Window_State := Object.State;
      Pointer_State : constant Standard.AWT.Inputs.Pointer_State := Object.State;

      subtype Single is GL.Types.Single;

      Width  : constant Single := Single (Window_State.Width + 2 * Window_State.Margin);
      Height : constant Single := Single (Window_State.Height + 2 * Window_State.Margin);

      PX : constant Single := Single (Pointer_State.Position (X));
      PY : constant Single := Single (Pointer_State.Position (Y));

      Horizontal : constant GL.Types.Single := PX / Width * 2.0 - 1.0;
      Vertical   : constant GL.Types.Single := PY / Height * 2.0 - 1.0;
   begin
      if Object.Resize then
         Object.Resize := False;

         Object.Initialize_Framebuffer;
      end if;

      Object.FB.Clear ((Color => True, others => False));

      Object.Cursor.Set_Vector (Orka.Float_32_Array'(Horizontal, -Vertical));
      Orka.Rendering.Drawing.Draw (GL.Types.Points, 0, 1);

      Object.Swap_Buffers;
   end Render;

   overriding
   function Create_Window
     (Context            : aliased Orka.Contexts.Surface_Context'Class;
      Width, Height      : Positive;
      Title              : String  := "";
      Samples            : Natural := 0;
      Visible, Resizable : Boolean := True;
      Transparent        : Boolean := False) return Test_Window is
   begin
      return Result : constant Test_Window :=
        (Orka.Contexts.AWT.Create_Window
          (Context, Width, Height, Title, Samples,
           Visible     => Visible,
           Resizable   => Resizable,
           Transparent => Transparent) with others => <>);
   end Create_Window;

end Package_Test;

with GL.Types;

with Orka.Logging;
with Orka.Resources.Locations.Directories;
with Orka.Rendering.Programs.Modules;
with Orka.Rendering.Drawing;
with Orka.Windows;

with AWT.Drag_And_Drop;

package body Package_Test 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);

   protected body Dnd_Signal is
      procedure Set is
      begin
         Dropped := True;
      end Set;

      entry Wait when Dropped is
      begin
         Dropped := False;
      end Wait;
   end Dnd_Signal;

   overriding
   function On_Close (Object : Test_Window) return Boolean is
   begin
      Messages.Log (Debug, "User is trying to close window");
      return True;
   end On_Close;

   overriding
   procedure On_Drag
     (Object : in out Test_Window;
      X, Y   : AWT.Inputs.Fixed)
   is
      use all type AWT.Inputs.Action_Kind;
      use type AWT.Inputs.Fixed;
   begin
      Messages.Log (Debug, "User dragged something to " &
        "(" & Trim (X'Image) & ", " & Trim (Y'Image) & ")");
      AWT.Drag_And_Drop.Set_Action (if X < 300.0 and Y < 300.0 then Copy else None);
   end On_Drag;

   overriding
   procedure On_Drop
     (Object : in out Test_Window)
   is
      use all type AWT.Inputs.Action_Kind;

      Action : constant AWT.Inputs.Action_Kind := AWT.Drag_And_Drop.Valid_Action;
   begin
      Messages.Log (Info, "User dropped something. Action is " & Action'Image);

      if Action /= None then
         Dnd_Signal.Set;
      end if;
   end On_Drop;

   overriding
   procedure On_Configure
     (Object       : in out Test_Window;
      State        : Standard.AWT.Windows.Window_State) is
   begin
      Messages.Log (Debug, "Configured window surface");
      Messages.Log (Debug, "  size:   " &
        Trim (State.Width'Image) & " × " & Trim (State.Height'Image));
      Messages.Log (Debug, "  margin: " & Trim (State.Margin'Image));

      Object.Resize := State.Visible and State.Width > 0 and State.Height > 0;
   end On_Configure;

   procedure Initialize_Framebuffer (Object : in out Test_Window) is
      Alpha : constant Orka.Float_32 := (if Object.State.Transparent then 0.5 else 1.0);
   begin
      Object.FB :=
        Orka.Rendering.Framebuffers.Create_Default_Framebuffer (Object.Width, Object.Height);
      Object.FB.Set_Default_Values ((Color => (0.0, 0.0, 0.0, Alpha), others => <>));
      Object.FB.Use_Framebuffer;
      Messages.Log (Debug, "Changed size of framebuffer to " &
        Trim (Object.Width'Image) & " × " & Trim (Object.Height'Image));
   end Initialize_Framebuffer;

   procedure Post_Initialize (Object : in out Test_Window) is
      Location_Shaders : constant Orka.Resources.Locations.Location_Ptr :=
        Orka.Resources.Locations.Directories.Create_Location ("data");
   begin
      Object.Initialize_Framebuffer;

      Object.Program  := Orka.Rendering.Programs.Create_Program
        (Orka.Rendering.Programs.Modules.Create_Module
           (Location_Shaders,
            VS => "cursor.vert",
            FS => "cursor.frag"));
      Object.Program.Use_Program;

      Object.Cursor := Object.Program.Uniform ("cursor");
   end Post_Initialize;

   procedure Render (Object : in out Test_Window) is
      use type Orka.Float_32;
      use Standard.AWT.Inputs;

      Window_State  : constant Standard.AWT.Windows.Window_State := Object.State;
      Pointer_State : constant Standard.AWT.Inputs.Pointer_State := Object.State;

      subtype Float_32 is Orka.Float_32;

      Width  : constant Float_32 := Float_32 (Window_State.Width + 2 * Window_State.Margin);
      Height : constant Float_32 := Float_32 (Window_State.Height + 2 * Window_State.Margin);

      PX : constant Float_32 := Float_32 (Pointer_State.Position (X));
      PY : constant Float_32 := Float_32 (Pointer_State.Position (Y));

      Horizontal : constant Float_32 := PX / Width * 2.0 - 1.0;
      Vertical   : constant Float_32 := PY / Height * 2.0 - 1.0;
   begin
      if Object.Resize then
         Object.Resize := False;

         Object.Initialize_Framebuffer;
      end if;

      Object.FB.Clear ((Color => True, others => False));

      Object.Cursor.Set_Vector (Orka.Float_32_Array'(Horizontal, -Vertical));
      Orka.Rendering.Drawing.Draw (GL.Types.Points, 0, 1);

      Object.Swap_Buffers;
   end Render;

   overriding
   function Create_Window
     (Context            : aliased Orka.Contexts.Surface_Context'Class;
      Width, Height      : Positive;
      Title              : String  := "";
      Samples            : Natural := 0;
      Visible, Resizable : Boolean := True;
      Transparent        : Boolean := False) return Test_Window is
   begin
      return Result : constant Test_Window :=
        (Orka.Contexts.AWT.Create_Window
          (Context, Width, Height, Title, Samples,
           Visible     => Visible,
           Resizable   => Resizable,
           Transparent => Transparent) with others => <>);
   end Create_Window;

end Package_Test;

awt: Reduce dependency on package GL.Types in example a bit

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


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

with Util.Properties;

--  = Database Drivers ==
--  The ADO.Drivers package represents the database driver that will create
--  database connections and provide the database specific implementation.  The driver
--  is either statically linked to the application and can be loaded dynamically if it was
--  built as a shared library.  For a dynamic load, the driver shared library name must be
--  prefixed by libada_ado_.  For example, for a <tt>mysql</tt> driver, the shared
--  library name is <tt>libada_ado_mysql.so</tt>.
--
--  == Initialization ==
--  The ADO runtime must be initialized by calling one of the Initialize operation.
--  A property file contains the configuration for the database drivers and the database
--  connection properties.
--
--    ADO.Drivers.Initialize ("db.properties");
--
--  Once initialized, a configuration property can be retrieved by using the <tt>Get_Config</tt>
--  operation.
--
--    URI : constant String := ADO.Drivers.Get_Config ("ado.database");
--
package ADO.Drivers is

   use Ada.Strings.Unbounded;

   --  Raised for all errors reported by the database.
   Database_Error   : exception;

   type Driver_Index is new Natural range 0 .. 4;

   --  Initialize the drivers and the library by reading the property file
   --  and configure the runtime with it.
   procedure Initialize (Config : in String);

   --  Initialize the drivers and the library and configure the runtime with the given properties.
   procedure Initialize (Config : in Util.Properties.Manager'Class);

   --  Get the global configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   function Get_Config (Name    : in String;
                        Default : in String := "") return String;

private

   --  Initialize the drivers which are available.
   procedure Initialize;

end ADO.Drivers;

-----------------------------------------------------------------------
--  ADO Drivers -- Database Drivers
--  Copyright (C) 2010, 2011, 2012, 2013, 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 Util.Properties;

--  == Database Drivers ==
--  Database drivers provide operations to access the database.  These operations are
--  specific to the database type and the `ADO.Drivers` package among others provide
--  an abstraction that allows to make the different databases look like they have almost
--  the same interface.
--
--  A database driver exists for SQLite, MySQL and PostgreSQL. The driver
--  is either statically linked to the application or it can be loaded dynamically if it was
--  built as a shared library.  For a dynamic load, the driver shared library name must be
--  prefixed by `libada_ado_`.  For example, for a `mysql` driver, the shared
--  library name is `libada_ado_mysql.so`.
--
--  | Driver name | Database       |
--  | ----------- | ---------      |
--  | mysql       | MySQL, MariaDB |
--  | sqlite      | SQLite         |
--  | postgresql  | PostgreSQL     |
--
--  The database drivers are initialized automatically but in some cases, you may want
--  to control some database driver configuration parameter.  In that case,
--  the initialization must be done only once before creating a session
--  factory and getting a database connection.  The initialization can be made using
--  a property file which contains the configuration for the database drivers and
--  the database connection properties.  For such initialization, you will have to
--  call one of the `Initialize` operation from the `ADO.Drivers` package.
--
--    ADO.Drivers.Initialize ("db.properties");
--
--  The set of configuration properties can be set programatically and passed to the
--  `Initialize` operation.
--
--    Config : Util.Properties.Manager;
--    ...
--      Config.Set ("ado.database", "sqlite:///mydatabase.db");
--      Config.Set ("ado.queries.path", ".;db");
--      ADO.Drivers.Initialize (Config);
--
--  Once initialized, a configuration property can be retrieved by using the `Get_Config`
--  operation.
--
--    URI : constant String := ADO.Drivers.Get_Config ("ado.database");
--
--  Dynamic loading of database drivers is disabled by default for security reasons and
--  it can be enabled by setting the following property in the configuration file:
--
--    ado.drivers.load=true
--
--  Dynamic loading is triggered when a database connection string refers to a database
--  driver which is not known.
package ADO.Drivers is

   use Ada.Strings.Unbounded;

   --  Raised for all errors reported by the database.
   Database_Error   : exception;

   type Driver_Index is new Natural range 0 .. 4;

   --  Initialize the drivers and the library by reading the property file
   --  and configure the runtime with it.
   procedure Initialize (Config : in String);

   --  Initialize the drivers and the library and configure the runtime with the given properties.
   procedure Initialize (Config : in Util.Properties.Manager'Class);

   --  Get the global configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   function Get_Config (Name    : in String;
                        Default : in String := "") return String;

private

   --  Initialize the drivers which are available.
   procedure Initialize;

end ADO.Drivers;

Add more information about the configuration


------------------------------------------------------------------------------
-- Copyright (c) 2017-2019, 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 Natools.S_Expressions.Atom_Ref_Constructors;
with Natools.S_Expressions.File_Readers;
with Natools.S_Expressions.Interpreter_Loop;

package body Natools.Web.ACL.Sx_Backends is

   type Hashed_Token_List_Array is array (Hash_Id range <>)
     of Containers.Unsafe_Atom_Lists.List;

   type Hashed_Token_Map_Array is array (Hash_Id range <>)
     of Token_Maps.Unsafe_Maps.Map;

   type User_Builder (Hash_Id_First, Hash_Id_Last : Hash_Id) is record
      Tokens, Groups : Containers.Unsafe_Atom_Lists.List;
      Hashed : Hashed_Token_List_Array (Hash_Id_First .. Hash_Id_Last);
   end record;

   type Backend_Builder (Hash_Id_First, Hash_Id_Last : Hash_Id) is record
      Map : Token_Maps.Unsafe_Maps.Map;
      Hashed : Hashed_Token_Map_Array (Hash_Id_First .. Hash_Id_Last);
   end record;

   Cookie_Name : constant String := "User-Token";
   Hash_Mark : constant Character := '$';

   procedure Process_User
     (Builder : in out Backend_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class);

   procedure Process_User_Element
     (Builder : in out User_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class);

   procedure Read_DB is new S_Expressions.Interpreter_Loop
     (Backend_Builder, Meaningless_Type, Process_User);

   procedure Read_User is new S_Expressions.Interpreter_Loop
     (User_Builder, Meaningless_Type, Process_User_Element);

   --------------------------
   -- Constructor Elements --
   --------------------------

   procedure Process_User
     (Builder : in out Backend_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      User : User_Builder (Builder.Hash_Id_First, Builder.Hash_Id_Last);
      Identity : Containers.Identity;
   begin
      Read_User (Arguments, User, Meaningless_Value);

      Identity :=
        (User => S_Expressions.Atom_Ref_Constructors.Create (Name),
         Groups => Containers.Create (User.Groups));

      for Token of User.Tokens loop
         Builder.Map.Include (Token, Identity);
      end loop;

      for Id in User.Hashed'Range loop
         for Hashed_Token of User.Hashed (Id) loop
            Builder.Hashed (Id).Include (Hashed_Token, Identity);
         end loop;
      end loop;
   end Process_User;

   procedure Process_User_Element
     (Builder : in out User_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      S_Name : constant String := S_Expressions.To_String (Name);
   begin
      if S_Name = "tokens" or else S_Name = "token" then
         Containers.Append_Atoms (Builder.Tokens, Arguments);
      elsif S_Name = "groups" or else S_Name = "group" then
         Containers.Append_Atoms (Builder.Groups, Arguments);
      elsif (S_Name'Length = 8
           or else (S_Name'Length = 9 and then S_Name (S_Name'Last) = 's'))
        and then S_Name (S_Name'First) = Hash_Mark
        and then S_Name (S_Name'First + 2 .. S_Name'First + 7)
           = Hash_Mark & "token"
        and then not Hash_Function_DB.Is_Empty
      then
         declare
            Id : constant Character := S_Name (S_Name'First + 1);
            Acc : constant Hash_Function_Array_Refs.Accessor
              := Hash_Function_DB.Query;
         begin
            if Id in Acc.Data.all'Range and then Acc.Data (Id) /= null then
               Containers.Append_Atoms (Builder.Hashed (Id), Arguments);
            else
               Log (Severities.Error, "Unknown hash function id"
                 & Character'Image (Id));
            end if;
         end;
      else
         Log (Severities.Error, "Unknown user element """ & S_Name & '"');
      end if;
   end Process_User_Element;

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

   overriding procedure Authenticate
     (Self : in Backend;
      Exchange : in out Exchanges.Exchange)
   is
      Cookie : constant String := Exchange.Cookie (Cookie_Name);
      Identity : Containers.Identity;
   begin
      if Cookie'Length > 3
        and then Cookie (Cookie'First) = Hash_Mark
        and then Cookie (Cookie'First + 2) = Hash_Mark
        and then not Self.Hashed.Is_Empty
        and then Cookie (Cookie'First + 1) in Self.Hashed.Query.Data.all'Range
      then
         declare
            Token : constant S_Expressions.Atom
              := S_Expressions.To_Atom
                 (Cookie (Cookie'First + 3 .. Cookie'Last));
            Hash : constant S_Expressions.Atom
              := Hash_Function_DB.Query.Data (Cookie (Cookie'First + 1)).all
                 (Token);
            Cursor : constant Token_Maps.Cursor
              := Self.Hashed.Query.Data (Cookie (Cookie'First + 1)).Find
                 (Hash);
         begin
            if Token_Maps.Has_Element (Cursor) then
               Identity := Token_Maps.Element (Cursor);
            end if;
         end;
      else
         declare
            Cursor : constant Token_Maps.Cursor
              := Self.Map.Find (S_Expressions.To_Atom (Cookie));
         begin
            if Token_Maps.Has_Element (Cursor) then
               Identity := Token_Maps.Element (Cursor);
            end if;
         end;
      end if;

      Exchange.Set_Identity (Identity);
   end Authenticate;

   function Create
     (Arguments : in out S_Expressions.Lockable.Descriptor'Class)
     return ACL.Backend'Class
   is
      Hash_Id_First : constant Hash_Id
        := (if Hash_Function_DB.Is_Empty
            then Hash_Id'Last
            else Hash_Function_DB.Query.Data.all'First);
      Hash_Id_Last : constant Hash_Id
        := (if Hash_Function_DB.Is_Empty
            then Hash_Id'First
            else Hash_Function_DB.Query.Data.all'Last);
      Builder : Backend_Builder (Hash_Id_First, Hash_Id_Last);
   begin
      case Arguments.Current_Event is
         when S_Expressions.Events.Open_List =>
            Read_DB (Arguments, Builder, Meaningless_Value);

         when S_Expressions.Events.Add_Atom =>
            declare
               Reader : S_Expressions.File_Readers.S_Reader
                 := S_Expressions.File_Readers.Reader
                    (S_Expressions.To_String (Arguments.Current_Atom));
            begin
               Read_DB (Reader, Builder, Meaningless_Value);
            end;

         when others =>
            Log (Severities.Error, "Unable to create ACL from S-expression"
              & " starting with " & Arguments.Current_Event'Img);
      end case;

      return Backend'(Map => Token_Maps.Create (Builder.Map),
                      Hashed => <>);
   end Create;

   procedure Register
     (Id : in Character;
      Fn : in Hash_Function) is
   begin
      if Fn = null then
         null;
      elsif Hash_Function_DB.Is_Empty then
         Hash_Function_DB.Replace (new Hash_Function_Array'(Id => Fn));
      elsif Id in Hash_Function_DB.Query.Data.all'Range then
         Hash_Function_DB.Update.Data.all (Id) := Fn;
      else
         declare
            New_First : constant Hash_Id
              := Hash_Id'Min (Id, Hash_Function_DB.Query.Data.all'First);
            New_Last : constant Hash_Id
              := Hash_Id'Max (Id, Hash_Function_DB.Query.Data.all'Last);
            New_Data : constant Hash_Function_Array_Refs.Data_Access
              := new Hash_Function_Array'(New_First .. New_Last => null);
         begin
            New_Data (Hash_Function_DB.Query.Data.all'First
                  ..  Hash_Function_DB.Query.Data.all'Last)
              := Hash_Function_DB.Query.Data.all;
            Hash_Function_DB.Replace (New_Data);
         end;
      end if;
   end Register;

end Natools.Web.ACL.Sx_Backends;

------------------------------------------------------------------------------
-- Copyright (c) 2017-2019, 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 Natools.S_Expressions.Atom_Ref_Constructors;
with Natools.S_Expressions.File_Readers;
with Natools.S_Expressions.Interpreter_Loop;

package body Natools.Web.ACL.Sx_Backends is

   type Hashed_Token_List_Array is array (Hash_Id range <>)
     of Containers.Unsafe_Atom_Lists.List;

   type Hashed_Token_Map_Array is array (Hash_Id range <>)
     of Token_Maps.Unsafe_Maps.Map;

   type User_Builder (Hash_Id_First, Hash_Id_Last : Hash_Id) is record
      Tokens, Groups : Containers.Unsafe_Atom_Lists.List;
      Hashed : Hashed_Token_List_Array (Hash_Id_First .. Hash_Id_Last);
   end record;

   type Backend_Builder (Hash_Id_First, Hash_Id_Last : Hash_Id) is record
      Map : Token_Maps.Unsafe_Maps.Map;
      Hashed : Hashed_Token_Map_Array (Hash_Id_First .. Hash_Id_Last);
   end record;

   Cookie_Name : constant String := "User-Token";
   Hash_Mark : constant Character := '$';

   procedure Process_User
     (Builder : in out Backend_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class);

   procedure Process_User_Element
     (Builder : in out User_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class);

   procedure Read_DB is new S_Expressions.Interpreter_Loop
     (Backend_Builder, Meaningless_Type, Process_User);

   procedure Read_User is new S_Expressions.Interpreter_Loop
     (User_Builder, Meaningless_Type, Process_User_Element);

   --------------------------
   -- Constructor Elements --
   --------------------------

   procedure Process_User
     (Builder : in out Backend_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      User : User_Builder (Builder.Hash_Id_First, Builder.Hash_Id_Last);
      Identity : Containers.Identity;
   begin
      Read_User (Arguments, User, Meaningless_Value);

      Identity :=
        (User => S_Expressions.Atom_Ref_Constructors.Create (Name),
         Groups => Containers.Create (User.Groups));

      for Token of User.Tokens loop
         Builder.Map.Include (Token, Identity);
      end loop;

      for Id in User.Hashed'Range loop
         for Hashed_Token of User.Hashed (Id) loop
            Builder.Hashed (Id).Include (Hashed_Token, Identity);
         end loop;
      end loop;
   end Process_User;

   procedure Process_User_Element
     (Builder : in out User_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      S_Name : constant String := S_Expressions.To_String (Name);
   begin
      if S_Name = "tokens" or else S_Name = "token" then
         Containers.Append_Atoms (Builder.Tokens, Arguments);
      elsif S_Name = "groups" or else S_Name = "group" then
         Containers.Append_Atoms (Builder.Groups, Arguments);
      elsif (S_Name'Length = 8
           or else (S_Name'Length = 9 and then S_Name (S_Name'Last) = 's'))
        and then S_Name (S_Name'First) = Hash_Mark
        and then S_Name (S_Name'First + 2 .. S_Name'First + 7)
           = Hash_Mark & "token"
        and then not Hash_Function_DB.Is_Empty
      then
         declare
            Id : constant Character := S_Name (S_Name'First + 1);
            Acc : constant Hash_Function_Array_Refs.Accessor
              := Hash_Function_DB.Query;
         begin
            if Id in Acc.Data.all'Range and then Acc.Data (Id) /= null then
               Containers.Append_Atoms (Builder.Hashed (Id), Arguments);
            else
               Log (Severities.Error, "Unknown hash function id"
                 & Character'Image (Id));
            end if;
         end;
      else
         Log (Severities.Error, "Unknown user element """ & S_Name & '"');
      end if;
   end Process_User_Element;

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

   overriding procedure Authenticate
     (Self : in Backend;
      Exchange : in out Exchanges.Exchange)
   is
      Cookie : constant String := Exchange.Cookie (Cookie_Name);
      Identity : Containers.Identity;
   begin
      if Cookie'Length > 3
        and then Cookie (Cookie'First) = Hash_Mark
        and then Cookie (Cookie'First + 2) = Hash_Mark
        and then not Self.Hashed.Is_Empty
        and then Cookie (Cookie'First + 1) in Self.Hashed.Query.Data.all'Range
      then
         declare
            Token : constant S_Expressions.Atom
              := S_Expressions.To_Atom
                 (Cookie (Cookie'First + 3 .. Cookie'Last));
            Hash : constant S_Expressions.Atom
              := Hash_Function_DB.Query.Data (Cookie (Cookie'First + 1)).all
                 (Token);
            Cursor : constant Token_Maps.Cursor
              := Self.Hashed.Query.Data (Cookie (Cookie'First + 1)).Find
                 (Hash);
         begin
            if Token_Maps.Has_Element (Cursor) then
               Identity := Token_Maps.Element (Cursor);
            end if;
         end;
      else
         declare
            Cursor : constant Token_Maps.Cursor
              := Self.Map.Find (S_Expressions.To_Atom (Cookie));
         begin
            if Token_Maps.Has_Element (Cursor) then
               Identity := Token_Maps.Element (Cursor);
            end if;
         end;
      end if;

      Exchange.Set_Identity (Identity);
   end Authenticate;

   function Create
     (Arguments : in out S_Expressions.Lockable.Descriptor'Class)
     return ACL.Backend'Class
   is
      Hash_Id_First : constant Hash_Id
        := (if Hash_Function_DB.Is_Empty
            then Hash_Id'Last
            else Hash_Function_DB.Query.Data.all'First);
      Hash_Id_Last : constant Hash_Id
        := (if Hash_Function_DB.Is_Empty
            then Hash_Id'First
            else Hash_Function_DB.Query.Data.all'Last);
      Builder : Backend_Builder (Hash_Id_First, Hash_Id_Last);
   begin
      case Arguments.Current_Event is
         when S_Expressions.Events.Open_List =>
            Read_DB (Arguments, Builder, Meaningless_Value);

         when S_Expressions.Events.Add_Atom =>
            declare
               Reader : S_Expressions.File_Readers.S_Reader
                 := S_Expressions.File_Readers.Reader
                    (S_Expressions.To_String (Arguments.Current_Atom));
            begin
               Read_DB (Reader, Builder, Meaningless_Value);
            end;

         when others =>
            Log (Severities.Error, "Unable to create ACL from S-expression"
              & " starting with " & Arguments.Current_Event'Img);
      end case;

      return Result : Backend
        := (Map => Token_Maps.Create (Builder.Map),
            Hashed => <>)
      do
         declare
            Min : Hash_Id := Hash_Id'Last;
            Max : Hash_Id := Hash_Id'First;
         begin
            for Id in Builder.Hashed'Range loop
               if not Builder.Hashed (Id).Is_Empty then
                  --  Hash_Id'Min seems broken, using a basic `if` instead
                  if Id < Min then
                     Min := Id;
                  end if;

                  if Id > Max then
                     Max := Id;
                  end if;
               end if;
            end loop;

            if Min <= Max then
               declare
                  Data : constant Hashed_Token_Array_Refs.Data_Access
                    := new Hashed_Token_Array (Min .. Max);
               begin
                  Result.Hashed := Hashed_Token_Array_Refs.Create (Data);
                  for Id in Min .. Max loop
                     if not Builder.Hashed (Id).Is_Empty then
                        Data (Id) := Token_Maps.Create (Builder.Hashed (Id));
                     end if;
                  end loop;
               end;
            end if;
         end;
      end return;
   end Create;

   procedure Register
     (Id : in Character;
      Fn : in Hash_Function) is
   begin
      if Fn = null then
         null;
      elsif Hash_Function_DB.Is_Empty then
         Hash_Function_DB.Replace (new Hash_Function_Array'(Id => Fn));
      elsif Id in Hash_Function_DB.Query.Data.all'Range then
         Hash_Function_DB.Update.Data.all (Id) := Fn;
      else
         declare
            New_First : constant Hash_Id
              := Hash_Id'Min (Id, Hash_Function_DB.Query.Data.all'First);
            New_Last : constant Hash_Id
              := Hash_Id'Max (Id, Hash_Function_DB.Query.Data.all'Last);
            New_Data : constant Hash_Function_Array_Refs.Data_Access
              := new Hash_Function_Array'(New_First .. New_Last => null);
         begin
            Log (Severities.Info,
              "Adding " & Id'Img & " to "
              & Hash_Function_DB.Query.Data.all'First'Img & " .. "
              & Hash_Function_DB.Query.Data.all'Last'Img & " -> "
              & New_First'Img & " .. " & New_Last'Img);
            New_Data (Hash_Function_DB.Query.Data.all'First
                  ..  Hash_Function_DB.Query.Data.all'Last)
              := Hash_Function_DB.Query.Data.all;
            Hash_Function_DB.Replace (New_Data);
         end;
      end if;
   end Register;

end Natools.Web.ACL.Sx_Backends;

store the hashed tokens in the backend

acl-sx_backends: store the hashed tokens in the backend


-----------------------------------------------------------------------
--  util-encoders-hmac-sha1 -- Compute HMAC-SHA1 authentication code
--  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.Streams;
with Ada.Finalization;
with Util.Encoders.SHA1;

--  The Util.Encodes.HMAC.SHA1 package generates HMAC-SHA1 authentication
--  (See RFC 2104 - HMAC: Keyed-Hashing for Message Authentication).
package Util.Encoders.HMAC.SHA1 is

   pragma Preelaborate;

   --  Sign the data string with the key and return the HMAC-SHA1 code in binary.
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA1.Hash_Array;

   --  Sign the data string with the key and return the HMAC-SHA1 code as hexadecimal string.
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA1.Digest;

   --  Sign the data string with the key and return the HMAC-SHA1 code as base64 string.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   function Sign_Base64 (Key  : in String;
                         Data : in String;
                         URL  : in Boolean := False) return Util.Encoders.SHA1.Base64_Digest;

   --  ------------------------------
   --  HMAC-SHA1 Context
   --  ------------------------------
   type Context is limited private;

   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   procedure Set_Key (E   : in out Context;
                      Key : in String);

   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   procedure Set_Key (E   : in out Context;
                      Key : in Ada.Streams.Stream_Element_Array);

   --  Update the hash with the string.
   procedure Update (E : in out Context;
                     S : in String);

   --  Update the hash with the string.
   procedure Update (E : in out Context;
                     S : in Ada.Streams.Stream_Element_Array);

   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the raw binary hash in Hash.
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA1.Hash_Array);

   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the hexadecimal hash in Hash.
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA1.Digest);

   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the base64 hash in Hash.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   procedure Finish_Base64 (E    : in out Context;
                            Hash : out Util.Encoders.SHA1.Base64_Digest;
                            URL  : in Boolean := False);

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

   --  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 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);

private

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

   type Context is new Ada.Finalization.Limited_Controlled with record
      SHA     : Util.Encoders.SHA1.Context;
      Key     : Ada.Streams.Stream_Element_Array (0 .. 63);
      Key_Len : Ada.Streams.Stream_Element_Offset;
   end record;

   --  Initialize the SHA-1 context.
   overriding
   procedure Initialize (E : in out Context);

end Util.Encoders.HMAC.SHA1;

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

--  The Util.Encodes.HMAC.SHA1 package generates HMAC-SHA1 authentication
--  (See RFC 2104 - HMAC: Keyed-Hashing for Message Authentication).
package Util.Encoders.HMAC.SHA1 is

   pragma Preelaborate;

   --  Sign the data string with the key and return the HMAC-SHA1 code in binary.
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA1.Hash_Array;

   --  Sign the data string with the key and return the HMAC-SHA1 code as hexadecimal string.
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA1.Digest;

   --  Sign the data string with the key and return the HMAC-SHA1 code as base64 string.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   function Sign_Base64 (Key  : in String;
                         Data : in String;
                         URL  : in Boolean := False) return Util.Encoders.SHA1.Base64_Digest;

   --  ------------------------------
   --  HMAC-SHA1 Context
   --  ------------------------------
   type Context is limited private;

   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   procedure Set_Key (E   : in out Context;
                      Key : in String);

   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   procedure Set_Key (E   : in out Context;
                      Key : in Ada.Streams.Stream_Element_Array);

   --  Update the hash with the string.
   procedure Update (E : in out Context;
                     S : in String);

   --  Update the hash with the string.
   procedure Update (E : in out Context;
                     S : in Ada.Streams.Stream_Element_Array);

   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the raw binary hash in Hash.
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA1.Hash_Array);

   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the hexadecimal hash in Hash.
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA1.Digest);

   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the base64 hash in Hash.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   procedure Finish_Base64 (E    : in out Context;
                            Hash : out Util.Encoders.SHA1.Base64_Digest;
                            URL  : in Boolean := False);

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

   --  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);

private

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

   type Context is new Ada.Finalization.Limited_Controlled with record
      SHA     : Util.Encoders.SHA1.Context;
      Key     : Ada.Streams.Stream_Element_Array (0 .. 63);
      Key_Len : Ada.Streams.Stream_Element_Offset;
   end record;

   --  Initialize the SHA-1 context.
   overriding
   procedure Initialize (E : in out Context);

end Util.Encoders.HMAC.SHA1;

Change the Transformer interface to accept in out parameter for the Transformer


-----------------------------------------------------------------------
--  asf.responses -- ASF Requests
--  Copyright (C) 2010 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.Locales;
with Ada.Calendar;
with Ada.Strings.Unbounded;
with Ada.Finalization;

with ASF.Streams;
with ASF.Cookies;
private with Util.Streams.Texts;

--  The ASF.Responses package is an Ada implementation of
--  the Java servlet response (JSR 315 5. The Response).
package ASF.Responses is

   SC_CONTINUE : constant Natural := 100;
   SC_SWITCHING_PROTOCOLS : constant Natural := 101;
   SC_OK : constant Natural := 200;
   SC_CREATED : constant Natural := 201;
   SC_ACCEPTED : constant Natural := 202;
   SC_NON_AUTHORITATIVE_INFORMATION : constant Natural := 203;
   SC_NO_CONTENT : constant Natural := 204;
   SC_RESET_CONTENT : constant Natural := 205;
   SC_PARTIAL_CONTENT : constant Natural := 206;
   SC_MULTIPLE_CHOICES : constant Natural := 300;
   SC_MOVED_PERMANENTLY : constant Natural := 301;
   SC_MOVED_TEMPORARILY : constant Natural := 302;
   SC_FOUND : constant Natural := 302;
   SC_SEE_OTHER : constant Natural := 303;
   SC_NOT_MODIFIED : constant Natural := 304;
   SC_USE_PROXY : constant Natural := 305;
   SC_TEMPORARY_REDIRECT : constant Natural := 307;
   SC_BAD_REQUEST : constant Natural := 400;
   SC_UNAUTHORIZED : constant Natural := 401;
   SC_PAYMENT_REQUIRED : constant Natural := 402;
   SC_FORBIDDEN : constant Natural := 403;
   SC_NOT_FOUND : constant Natural := 404;
   SC_METHOD_NOT_ALLOWED : constant Natural := 405;
   SC_NOT_ACCEPTABLE : constant Natural := 406;
   SC_PROXY_AUTHENTICATION_REQUIRED : constant Natural := 407;
   SC_REQUEST_TIMEOUT : constant Natural := 408;
   SC_CONFLICT : constant Natural := 409;
   SC_GONE : constant Natural := 410;
   SC_LENGTH_REQUIRED : constant Natural := 411;
   SC_PRECONDITION_FAILED : constant Natural := 412;
   SC_REQUEST_ENTITY_TOO_LARGE : constant Natural := 413;
   SC_REQUEST_URI_TOO_LONG : constant Natural := 414;
   SC_UNSUPPORTED_MEDIA_TYPE : constant Natural := 415;
   SC_REQUESTED_RANGE_NOT_SATISFIABLE : constant Natural := 416;
   SC_EXPECTATION_FAILED : constant Natural := 417;
   SC_INTERNAL_SERVER_ERROR : constant Natural := 500;
   SC_NOT_IMPLEMENTED : constant Natural := 501;
   SC_BAD_GATEWAY : constant Natural := 502;
   SC_SERVICE_UNAVAILABLE : constant Natural := 503;
   SC_GATEWAY_TIMEOUT : constant Natural := 504;
   SC_HTTP_VERSION_NOT_SUPPORTED : constant Natural := 505;

   type Response is abstract tagged limited private;
   type Response_Access is access all Response'Class;

   --  Returns the name of the character encoding (MIME charset) used for the body
   --  sent in this response. The character encoding may have been specified explicitly
   --  using the setCharacterEncoding(String) or setContentType(String) methods,
   --  or implicitly using the setLocale(java.util.Locale) method. Explicit
   --  specifications take precedence over implicit specifications. Calls made
   --  to these methods after getWriter has been called or after the response has
   --  been committed have no effect on the character encoding. If no character
   --  encoding has been specified, ISO-8859-1 is returned.
   function Get_Character_Encoding (Resp : in Response) return String;

   --  Returns the content type used for the MIME body sent in this response.
   --  The content type proper must have been specified using
   --  setContentType(String)  before the response is committed. If no content type
   --  has been specified, this method returns null. If a content type has been
   --  specified, and a character encoding has been explicitly or implicitly specified
   --  as described in getCharacterEncoding()  or getWriter() has been called,
   --  the charset parameter is included in the string returned. If no character
   --  encoding has been specified, the charset parameter is omitted.
   function Get_Content_Type (Resp : in Response) return String;

   --  Sets the character encoding (MIME charset) of the response being sent to the
   --  client, for example, to UTF-8. If the character encoding has already been
   --  set by setContentType(java.lang.String) or setLocale(java.util.Locale),
   --  this method overrides it. Calling setContentType(java.lang.String) with the
   --  String  of text/html and calling this method with the String of UTF-8  is
   --  equivalent with calling setContentType with the String of text/html; charset=UTF-8.
   --
   --  This method can be called repeatedly to change the character encoding.
   --  This method has no effect if it is called after getWriter has been called or
   --  after the response has been committed.
   --
   --  Containers must communicate the character encoding used for the servlet
   --  response's writer to the client if the protocol provides a way for doing so.
   --  In the case of HTTP, the character encoding is communicated as part of the
   --  Content-Type  header for text media types. Note that the character encoding
   --  cannot be communicated via HTTP headers if the servlet does not specify
   --  a content type; however, it is still used to encode text written via the servlet
   --  response's writer.
   procedure Set_Character_Encoding (Resp     : in out Response;
                                     Encoding : in String);

   --  Sets the length of the content body in the response In HTTP servlets,
   --  this method sets the HTTP Content-Length header.
   procedure Set_Content_Length (Resp   : in out Response;
                                 Length : in Integer);

   --  Sets the content type of the response being sent to the client, if the response
   --  has not been committed yet. The given content type may include a character
   --  encoding specification, for example, text/html;charset=UTF-8. The response's
   --  character encoding is only set from the given content type if this method is
   --  called before getWriter  is called.
   --
   --  This method may be called repeatedly to change content type and character
   --  encoding. This method has no effect if called after the response has been
   --  committed. It does not set the response's character encoding if it is called
   --  after getWriter  has been called or after the response has been committed.
   --
   --  Containers must communicate the content type and the character encoding used
   --  for the servlet response's writer to the client if the protocol provides a way
   --  for doing so. In the case of HTTP, the Content-Type header is used.
   procedure Set_Content_Type (Resp    : in out Response;
                               Content : in String);

   --  Returns a boolean indicating if the response has been committed.
   --  A committed response has already had its status code and headers written.
   function Is_Committed (Resp : in Response) return Boolean;

   --  Sets the locale of the response, if the response has not been committed yet.
   --  It also sets the response's character encoding appropriately for the locale,
   --  if the character encoding has not been explicitly set using
   --  setContentType(java.lang.String) or setCharacterEncoding(java.lang.String),
   --  getWriter hasn't been called yet, and the response hasn't been committed yet.
   --  If the deployment descriptor contains a locale-encoding-mapping-list element,
   --  and that element provides a mapping for the given locale, that mapping is used.
   --  Otherwise, the mapping from locale to character encoding is container dependent.
   --
   --  This method may be called repeatedly to change locale and character encoding.
   --  The method has no effect if called after the response has been committed.
   --  It does not set the response's character encoding if it is called after
   --  setContentType(java.lang.String)  has been called with a charset specification,
   --  after setCharacterEncoding(java.lang.String) has been called,
   --  after getWriter has been called, or after the response has been committed.
   --
   --  Containers must communicate the locale and the character encoding used for
   --  the servlet response's writer to the client if the protocol provides a way
   --  for doing so. In the case of HTTP, the locale is communicated via the
   --  Content-Language header, the character encoding as part of the Content-Type
   --  header for text media types. Note that the character encoding cannot be
   --  communicated via HTTP headers if the servlet does not specify a content type;
   --  however, it is still used to encode text written via the servlet response's writer.
   procedure Set_Locale (Resp : in out Response;
                         Loc  : in Util.Locales.Locale);

   --  Returns the locale specified for this response using the
   --  setLocale(java.util.Locale) method. Calls made to setLocale after the
   --  response is committed have no effect. If no locale has been specified,
   --  the container's default locale is returned.
   function Get_Locale (Resp : in Response) return Util.Locales.Locale;

   --  Adds the specified cookie to the response. This method can be called multiple
   --  times to set more than one cookie.
   procedure Add_Cookie (Resp   : in out Response;
                         Cookie : in ASF.Cookies.Cookie);

   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   function Contains_Header (Resp : in Response;
                             Name : in String) return Boolean is abstract;

   --  Iterate over the response headers and executes the Process procedure.
   procedure Iterate_Headers (Resp    : in Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is abstract;

   --  Encodes the specified URL by including the session ID in it, or, if encoding
   --  is not needed, returns the URL unchanged. The implementation of this method
   --  includes the logic to determine whether the session ID needs to be encoded
   --  in the URL. For example, if the browser supports cookies, or session tracking
   --  is turned off, URL encoding is unnecessary.
   --
   --  For robust session tracking, all URLs emitted by a servlet should be run through
   --  this method. Otherwise, URL rewriting cannot be used with browsers which do not
   --  support cookies.
   function Encode_URL (Resp : in Response;
                        URL  : in String) return String;

   --  Encodes the specified URL for use in the sendRedirect method or, if encoding
   --  is not needed, returns the URL unchanged. The implementation of this method
   --  includes the logic to determine whether the session ID needs to be encoded
   --  in the URL. Because the rules for making this determination can differ from
   --  those used to decide whether to encode a normal link, this method is separated
   --  from the encodeURL method.
   --
   --  All URLs sent to the HttpServletResponse.sendRedirect  method should be run
   --  through this method. Otherwise, URL rewriting cannot be used with browsers
   --  which do not support cookies.
   function Encode_Redirect_URL (Resp : in Response;
                                 URL  : in String) return String;

   --  Sends an error response to the client using the specified status. The server
   --  defaults to creating the response to look like an HTML-formatted server error
   --  page containing the specified message, setting the content type to "text/html",
   --  leaving cookies and other headers unmodified. If an error-page declaration
   --  has been made for the web application corresponding to the status code passed
   --  in, it will be served back in preference to the suggested msg parameter.
   --
   --  If the response has already been committed, this method throws an
   --  IllegalStateException. After using this method, the response should be
   --  considered to be committed and should not be written to.
   procedure Send_Error (Resp    : in out Response;
                         Error   : in Integer;
                         Message : in String);

   --  Sends an error response to the client using the specified status code
   --  and clearing the buffer.
   --
   --  If the response has already been committed, this method throws an
   --  IllegalStateException. After using this method, the response should be
   --  considered to be committed and should not be written to.
   procedure Send_Error (Resp    : in out Response;
                         Error   : in Integer);

   --  Sends a temporary redirect response to the client using the specified redirect
   --  location URL. This method can accept relative URLs; the servlet container must
   --  convert the relative URL to an absolute URL before sending the response to the
   --  client. If the location is relative without a leading '/' the container
   --  interprets it as relative to the current request URI. If the location is relative
   --  with a leading '/' the container interprets it as relative to the servlet
   --  container root.
   --
   --  If the response has already been committed, this method throws an
   --  IllegalStateException. After using this method, the response should be
   --  considered to be committed and should not be written to.
   procedure Send_Redirect (Resp     : in out Response;
                            Location : in String);

   --  Sets a response header with the given name and date-value.
   --  The date is specified in terms of milliseconds since the epoch.
   --  If the header had already been set, the new value overwrites the previous one.
   --  The containsHeader method can be used to test for the presence of a header
   --  before setting its value.
   procedure Set_Date_Header (Resp  : in out Response;
                              Name  : in String;
                              Date  : in Ada.Calendar.Time);

   --  Adds a response header with the given name and date-value. The date is specified
   --  in terms of milliseconds since the epoch. This method allows response headers
   --  to have multiple values.
   procedure Add_Date_Header (Resp : in out Response;
                              Name : in String;
                              Date : in Ada.Calendar.Time);

   --  Sets a response header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   procedure Set_Header (Resp  : in out Response;
                         Name  : in String;
                         Value : in String);

   --  Adds a response header with the given name and value.
   --  This method allows response headers to have multiple values.
   procedure Add_Header (Resp  : in out Response;
                         Name  : in String;
                         Value : in String);

   --  Sets a response header with the given name and integer value.
   --  If the header had already been set, the new value overwrites the previous one.
   --  The containsHeader  method can be used to test for the presence of a header
   --  before setting its value.
   procedure Set_Int_Header (Resp  : in out Response;
                             Name  : in String;
                             Value : in Integer);

   --  Adds a response header with the given name and integer value. This method
   --  allows response headers to have multiple values.
   procedure Add_Int_Header (Resp  : in out Response;
                             Name  : in String;
                             Value : in Integer);

   --  Sets the status code for this response. This method is used to set the
   --  return status code when there is no error (for example, for the status
   --  codes SC_OK or SC_MOVED_TEMPORARILY). If there is an error, and the caller
   --  wishes to invoke an error-page defined in the web application, the sendError
   --  method should be used instead.
   --
   --  The container clears the buffer and sets the Location header,
   --  preserving cookies and other headers.
   procedure Set_Status (Resp   : in out Response;
                         Status : in Natural);

   --  Get the status code that will be returned by this response.
   function Get_Status (Resp : in Response) return Natural;

   --  Get the output stream
   function Get_Output_Stream (Resp : in Response) return ASF.Streams.Print_Stream;

private

   type Response is abstract new Ada.Finalization.Limited_Controlled with record
      Status       : Integer := SC_OK;
      Stream       : Util.Streams.Texts.Print_Stream_Access;
      Content_Type : Ada.Strings.Unbounded.Unbounded_String;
      Locale       : Util.Locales.Locale;
   end record;

end ASF.Responses;

-----------------------------------------------------------------------
--  asf-responses -- ASF Responses
--  Copyright (C) 2010, 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 Servlet.Responses;
package ASF.Responses renames Servlet.Responses;

Package ASF.Responses moved to Servlet.Responses


with Ada.Real_Time;   use Ada.Real_Time;

with STM32.Board;     use STM32.Board;
with STM32.Device;    use STM32.Device;
with STM32.FMC;       use STM32.FMC;
with STM32.GPIO;      use STM32.GPIO;

with STM32_SVD.RCC;   use STM32_SVD.RCC;

package body STM32.SDRAM is

   Initialized : Boolean := False;
   G_Base_Addr : Word;

   procedure SDRAM_GPIOConfig;
   procedure SDRAM_InitSequence;

   ----------------------
   -- SDRAM_GPIOConfig --
   ----------------------

   procedure SDRAM_GPIOConfig
   is
   begin
      Enable_Clock (SDRAM_PINS);

      Configure_IO (SDRAM_PINS,
                    (Speed       => Speed_100MHz,
                     Mode        => Mode_AF,
                     Output_Type => Push_Pull,
                     Resistors   => Pull_Up));
      Configure_Alternate_Function (SDRAM_Pins, GPIO_AF_FMC);
      Lock (SDRAM_PINS);
   end SDRAM_GPIOConfig;

   ------------------------
   -- SDRAM_InitSequence --
   ------------------------

   procedure SDRAM_InitSequence
   is
      CAS : SDRAM_Mode_CAS_Latency;
   begin
      loop
         exit when not FMC_SDRAM_Busy;
      end loop;

      FMC_SDRAM_Cmd
        ((Mode   => FMC_Command_Mode_CLK_Enabled,
          Target => SDRAM_Bank));

      loop
         exit when not FMC_SDRAM_Busy;
      end loop;

      delay until Clock + Milliseconds (1);

      FMC_SDRAM_Cmd
        ((Mode   => FMC_Command_Mode_PALL,
          Target => SDRAM_Bank));

      loop
         exit when not FMC_SDRAM_Busy;
      end loop;

      FMC_SDRAM_Cmd
        ((Mode                => FMC_Command_Mode_AutoRefresh,
          Target              => SDRAM_Bank,
          Auto_Refresh_Number => 8));

      loop
         exit when not FMC_SDRAM_Busy;
      end loop;

      case SDRAM_CAS_Latency is
         when FMC_CAS_Latency_1 | FMC_CAS_Latency_2 =>
            CAS := SDRAM_Mode_CAS_Latency_2;
         when FMC_CAS_Latency_3 =>
            CAS := SDRAM_Mode_CAS_Latency_3;
      end case;

      FMC_SDRAM_Cmd
        ((Mode          => FMC_Command_Mode_LoadMode,
          Target        => SDRAM_Bank,
          Mode_Register =>
           (SDRAM_Mode_Burst_Length_1,
            SDRAM_Mode_Burst_Sequential,
            CAS,
            SDRAM_Mode_Writeburst_Mode_Single)));

      loop
         exit when not FMC_SDRAM_Busy;
      end loop;

      FMC_Set_Refresh_Count (SDRAM_Refresh_Cnt);

      loop
         exit when not FMC_SDRAM_Busy;
      end loop;
   end SDRAM_InitSequence;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize
   is
      Timing_Conf : FMC_SDRAM_TimingInit_Config;
      SDRAM_Conf  : FMC_SDRAM_Init_Config;
   begin
      if Initialized then
         return;
      end if;

      Initialized := True;

      G_Base_Addr := SDRAM_Base;

      ------------------------
      -- GPIO CONFIGURATION --
      ------------------------

      SDRAM_GPIOConfig;

      --------------
      -- FMC_INIT --
      --------------

      RCC_Periph.AHB3ENR.FMCEN := True;
      RCC_Periph.AHB3RSTR.FMCRST := True;
      RCC_Periph.AHB3RSTR.FMCRST := False;

      --  90 MHz of SD clock frequency (180MHz / 2)
      --  1 Clock cycle = 1 / 90MHz = 11.1ns

      Timing_Conf :=
        (
         --  2 Clock cycles for Load to Active delay
         LoadToActiveDelay    => 2,

         --  min = 70ns: 7 * 11.1
         ExitSelfRefreshDelay => 7,

         --  in range [42ns, 120k ns] => using 4 * 11.1 ns
         SelfRefreshTime      => 4,

         --  min = 70ns
         RowCycleDelay        => 7,

         --  min = 20ns
         WriteRecoveryTime    => 2,
         RPDelay              => 2,
         RCDDelay             => 2);

      SDRAM_Conf :=
        (Bank               => SDRAM_Bank,
         ColumnBitsNumber   => FMC_ColumnBits_Number_8b,
         RowBitsNumber      => SDRAM_Row_Bits,
         SDMemoryDataWidth  => SDRAM_Mem_Width,
         InternalBankNumber => FMC_InternalBank_Number_4,
         CASLatency         => SDRAM_CAS_Latency,
         WriteProtection    => FMC_Write_Protection_Disable,
         SDClockPeriod      => SDRAM_CLOCK_Period,
         ReadBurst          => SDRAM_Read_Burst,
         ReadPipeDelay      => SDRAM_Read_Pipe,
         Timing_Conf        => Timing_Conf);

      FMC_SDRAM_Init (SDRAM_Conf);

      if SDRAM_Conf.Bank /= FMC_Bank1_SDRAM then
         SDRAM_Conf.Bank := FMC_Bank1_SDRAM;
         FMC_SDRAM_Init (SDRAM_Conf);
      end if;

      SDRAM_InitSequence;
   end Initialize;

   ------------------
   -- Base_Address --
   ------------------

   function Base_Address return System.Address
   is
   begin
      return System'To_Address (G_Base_Addr);
   end Base_Address;

   -------------
   -- Reserve --
   -------------

   function Reserve
     (Amount : Word;
      Align  : Word := Standard'Maximum_Alignment) return System.Address
   is
      Ret          : constant System.Address :=
                       System'To_Address (G_Base_Addr);
      Rounded_Size : Word;

   begin
      Initialize;
      Rounded_Size := Amount + Align;
      Rounded_Size :=
        Rounded_Size - Rounded_Size rem Align;

      G_Base_Addr := G_Base_Addr + Rounded_Size;

      return Ret;
   end Reserve;

end STM32.SDRAM;

with Ada.Real_Time;   use Ada.Real_Time;

with STM32.Board;     use STM32.Board;
with STM32.Device;    use STM32.Device;
with STM32.FMC;       use STM32.FMC;
with STM32.GPIO;      use STM32.GPIO;

with STM32_SVD.RCC;   use STM32_SVD.RCC;

package body STM32.SDRAM is

   Initialized : Boolean := False;
   G_Base_Addr : Word;

   procedure SDRAM_GPIOConfig;
   procedure SDRAM_InitSequence;

   ----------------------
   -- SDRAM_GPIOConfig --
   ----------------------

   procedure SDRAM_GPIOConfig
   is
   begin
      Enable_Clock (SDRAM_PINS);

      Configure_IO (SDRAM_PINS,
                    (Speed       => Speed_50MHz,
                     Mode        => Mode_AF,
                     Output_Type => Push_Pull,
                     Resistors   => Pull_Up));
      Configure_Alternate_Function (SDRAM_Pins, GPIO_AF_FMC);
      Lock (SDRAM_PINS);
   end SDRAM_GPIOConfig;

   ------------------------
   -- SDRAM_InitSequence --
   ------------------------

   procedure SDRAM_InitSequence
   is
      CAS : SDRAM_Mode_CAS_Latency;
   begin
      loop
         exit when not FMC_SDRAM_Busy;
      end loop;

      FMC_SDRAM_Cmd
        ((Mode   => FMC_Command_Mode_CLK_Enabled,
          Target => SDRAM_Bank));

      loop
         exit when not FMC_SDRAM_Busy;
      end loop;

      delay until Clock + Milliseconds (1);

      FMC_SDRAM_Cmd
        ((Mode   => FMC_Command_Mode_PALL,
          Target => SDRAM_Bank));

      loop
         exit when not FMC_SDRAM_Busy;
      end loop;

      FMC_SDRAM_Cmd
        ((Mode                => FMC_Command_Mode_AutoRefresh,
          Target              => SDRAM_Bank,
          Auto_Refresh_Number => 8));

      loop
         exit when not FMC_SDRAM_Busy;
      end loop;

      case SDRAM_CAS_Latency is
         when FMC_CAS_Latency_1 | FMC_CAS_Latency_2 =>
            CAS := SDRAM_Mode_CAS_Latency_2;
         when FMC_CAS_Latency_3 =>
            CAS := SDRAM_Mode_CAS_Latency_3;
      end case;

      FMC_SDRAM_Cmd
        ((Mode          => FMC_Command_Mode_LoadMode,
          Target        => SDRAM_Bank,
          Mode_Register =>
           (SDRAM_Mode_Burst_Length_1,
            SDRAM_Mode_Burst_Sequential,
            CAS,
            SDRAM_Mode_Writeburst_Mode_Single)));

      loop
         exit when not FMC_SDRAM_Busy;
      end loop;

      FMC_Set_Refresh_Count (SDRAM_Refresh_Cnt);

      loop
         exit when not FMC_SDRAM_Busy;
      end loop;
   end SDRAM_InitSequence;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize
   is
      Timing_Conf : FMC_SDRAM_TimingInit_Config;
      SDRAM_Conf  : FMC_SDRAM_Init_Config;
   begin
      if Initialized then
         return;
      end if;

      Initialized := True;

      G_Base_Addr := SDRAM_Base;

      ------------------------
      -- GPIO CONFIGURATION --
      ------------------------

      SDRAM_GPIOConfig;

      --------------
      -- FMC_INIT --
      --------------

      RCC_Periph.AHB3ENR.FMCEN := True;
      RCC_Periph.AHB3RSTR.FMCRST := True;
      RCC_Periph.AHB3RSTR.FMCRST := False;

      --  90 MHz of SD clock frequency (180MHz / 2)
      --  1 Clock cycle = 1 / 90MHz = 11.1ns

      Timing_Conf :=
        (
         --  2 Clock cycles for Load to Active delay
         LoadToActiveDelay    => 2,

         --  min = 70ns: 7 * 11.1
         ExitSelfRefreshDelay => 7,

         --  in range [42ns, 120k ns] => using 4 * 11.1 ns
         SelfRefreshTime      => 4,

         --  min = 70ns
         RowCycleDelay        => 7,

         --  min = 20ns
         WriteRecoveryTime    => 2,
         RPDelay              => 2,
         RCDDelay             => 2);

      SDRAM_Conf :=
        (Bank               => SDRAM_Bank,
         ColumnBitsNumber   => FMC_ColumnBits_Number_8b,
         RowBitsNumber      => SDRAM_Row_Bits,
         SDMemoryDataWidth  => SDRAM_Mem_Width,
         InternalBankNumber => FMC_InternalBank_Number_4,
         CASLatency         => SDRAM_CAS_Latency,
         WriteProtection    => FMC_Write_Protection_Disable,
         SDClockPeriod      => SDRAM_CLOCK_Period,
         ReadBurst          => SDRAM_Read_Burst,
         ReadPipeDelay      => SDRAM_Read_Pipe,
         Timing_Conf        => Timing_Conf);

      FMC_SDRAM_Init (SDRAM_Conf);

      if SDRAM_Conf.Bank /= FMC_Bank1_SDRAM then
         SDRAM_Conf.Bank := FMC_Bank1_SDRAM;
         FMC_SDRAM_Init (SDRAM_Conf);
      end if;

      SDRAM_InitSequence;
   end Initialize;

   ------------------
   -- Base_Address --
   ------------------

   function Base_Address return System.Address
   is
   begin
      return System'To_Address (G_Base_Addr);
   end Base_Address;

   -------------
   -- Reserve --
   -------------

   function Reserve
     (Amount : Word;
      Align  : Word := Standard'Maximum_Alignment) return System.Address
   is
      Ret          : constant System.Address :=
                       System'To_Address (G_Base_Addr);
      Rounded_Size : Word;

   begin
      Initialize;
      Rounded_Size := Amount + Align;
      Rounded_Size :=
        Rounded_Size - Rounded_Size rem Align;

      G_Base_Addr := G_Base_Addr + Rounded_Size;

      return Ret;
   end Reserve;

end STM32.SDRAM;

Fix SDRAM pin configuration

Fix SDRAM pin configuration