with STM32_SVD.Interrupts;

separate (STM32.LTDC)
package body Init is

   pragma Warnings (Off, "* is not referenced");
   type LCD_Polarity is
     (Polarity_Active_Low,
      Polarity_Active_High) with Size => 1;
   type LCD_PC_Polarity is
     (Input_Pixel_Clock,
      Inverted_Input_Pixel_Clock) with Size => 1;
   pragma Warnings (On, "* is not referenced");

   function To_Bit is new Ada.Unchecked_Conversion (LCD_Polarity, Bit);
   function To_Bit is new Ada.Unchecked_Conversion (LCD_PC_Polarity, Bit);

   --  Extracted from STM32F429x.LTDC
   type Layer_Type is record
      LCR        : L1CR_Register; --  Layerx Control Register
      LWHPCR     : L1WHPCR_Register; --  Layerx Window Horizontal Position Configuration Register
      LWVPCR     : L1WVPCR_Register; --  Layerx Window Vertical Position Configuration Register
      LCKCR      : L1CKCR_Register; --  Layerx Color Keying Configuration Register
      LPFCR      : L1PFCR_Register; --  Layerx Pixel Format Configuration Register
      LCACR      : L1CACR_Register; --  Layerx Constant Alpha Configuration Register
      LDCCR      : L1DCCR_Register; --  Layerx Default Color Configuration Register
      LBFCR      : L1BFCR_Register; --  Layerx Blending Factors Configuration Register
      Reserved_0 : Word;
      Reserved_1 : Word;
      LCFBAR     : Word; --  Layerx Color Frame Buffer Address Register
      LCFBLR     : L1CFBLR_Register; --  Layerx Color Frame Buffer Length Register
      LCFBLNR    : L1CFBLNR_Register; --  Layerx ColorFrame Buffer Line Number Register
      Reserved_2 : Word;
      Reserved_3 : Word;
      Reserved_4 : Word;
      LCLUTWR    : L1CLUTWR_Register; --  Layerx CLUT Write Register
   end record with Volatile;

   for Layer_Type use record
      LCR        at  0 range 0 .. 31;
      LWHPCR     at  4 range 0 .. 31;
      LWVPCR     at  8 range 0 .. 31;
      LCKCR      at 12 range 0 .. 31;
      LPFCR      at 16 range 0 .. 31;
      LCACR      at 20 range 0 .. 31;
      LDCCR      at 24 range 0 .. 31;
      LBFCR      at 28 range 0 .. 31;
      Reserved_0 at 32 range 0 .. 31;
      Reserved_1 at 36 range 0 .. 31;
      LCFBAR     at 40 range 0 .. 31;
      LCFBLR     at 44 range 0 .. 31;
      LCFBLNR    at 48 range 0 .. 31;
      Reserved_2 at 52 range 0 .. 31;
      Reserved_3 at 56 range 0 .. 31;
      Reserved_4 at 60 range 0 .. 31;
      LCLUTWR    at 64 range 0 .. 31;
   end record;
   type Layer_Access is access all Layer_Type;

   G_Layer1_Reg : aliased Layer_Type
     with Import, Address => LTDC_Periph.L1CR'Address;
   G_Layer2_Reg : aliased Layer_Type
     with Import, Address => LTDC_Periph.L2CR'Address;

   type Pending_Buffers is array (LCD_Layer) of Word;

   protected Sync is
      --  Sets the next buffer to setup
      procedure Set_Pending (Layer  : LCD_Layer;
                             Buffer : Word);

      --  Apply pending buffers without waiting for the interrupt
      procedure Apply_Immediate;

      --  Wait for an interrupt.
      entry Wait;

      procedure Interrupt;
      pragma Attach_Handler
        (Interrupt, STM32_SVD.Interrupts.LCD_TFT_Interrupt);
   private
      Pending : Boolean := False;
      Buffers : Pending_Buffers := (others => 0);
   end Sync;

   protected body Sync is
      -----------------
      -- Set_Pending --
      -----------------

      procedure Set_Pending
        (Layer  : LCD_Layer;
         Buffer : Word)
      is
      begin
         Pending := True;
         LTDC_Periph.IER.LIE := 1;
         LTDC_Periph.LIPCR.LIPOS := 0;
         Buffers (Layer) := Buffer;
      end Set_Pending;

      ----------
      -- Wait --
      ----------

      entry Wait when not Pending is
      begin
         null;
      end Wait;

      ---------------------
      -- Apply_Immediate --
      ---------------------

      procedure Apply_Immediate is
      begin
         LTDC_Periph.IER.LIE := 0;

         if Buffers (Layer1) /= 0 then
            LTDC_Periph.L1CFBAR := Buffers (Layer1);
            Buffers (Layer1) := 0;
         end if;

         if Buffers (Layer2) /= 0 then
            LTDC_Periph.L2CFBAR := Buffers (Layer2);
            Buffers (Layer2) := 0;
         end if;

         LTDC_Periph.SRCR.IMR := 1;
         loop
            exit when LTDC_Periph.SRCR.IMR = 0;
         end loop;

         Pending := False;
         LTDC_Periph.IER.LIE := 1;
      end Apply_Immediate;

      ---------------
      -- Interrupt --
      ---------------

      procedure Interrupt
      is
      begin
         LTDC_Periph.IER.LIE := 0;
         LTDC_Periph.ICR.CLIF  := 1;

         Apply_Immediate;
      end Interrupt;
   end Sync;

   ---------------
   -- Get_Layer --
   ---------------

   function Get_Layer (Layer : LCD_Layer) return Layer_Access is
   begin
      if Layer = Layer1 then
         return G_Layer1_Reg'Access;
      else
         return G_Layer2_Reg'Access;
      end if;
   end Get_Layer;

   --------------------
   -- Set_Layer_CFBA --
   --------------------

   procedure Set_Layer_CFBA (Layer : LCD_Layer;
                             FBA   : Frame_Buffer_Access)
   is
--        L : constant Layer_Access := Get_Layer (Layer);
      function To_Word is new Ada.Unchecked_Conversion
        (Frame_Buffer_Access, Word);
   begin
      Sync.Set_Pending (Layer, To_Word (FBA));
--           L.LCFBAR := To_Word (FBA);
   end Set_Layer_CFBA;

   --------------------
   -- Get_Layer_CFBA --
   --------------------

   function Get_Layer_CFBA
     (Layer : LCD_Layer) return Frame_Buffer_Access
   is
      L : constant Layer_Access := Get_Layer (Layer);
      function To_FBA is new Ada.Unchecked_Conversion
        (Word, Frame_Buffer_Access);
   begin
      return To_FBA (L.LCFBAR);
   end Get_Layer_CFBA;

   ---------------------
   -- Set_Layer_State --
   ---------------------

   procedure Set_Layer_State
     (Layer : LCD_Layer;
      State : Boolean)
   is
      L   : constant Layer_Access := Get_Layer (Layer);
      Val : constant Bit := (if State then 1 else 0);
   begin
      if State and then Frame_Buffer_Array (Layer) = Null_Address then
         Frame_Buffer_Array (Layer) := STM32.SDRAM.Reserve
           (Word (LCD_Width * LCD_Height * Pixel_Size (Current_Pixel_Fmt)));
         Set_Layer_CFBA (Layer, Frame_Buffer_Array (Layer));
      end if;

      if L.LCR.LEN /= Val then
         L.LCR.LEN := Val;
         Reload_Config (Immediate => True);
      else

         L.LCR.LEN := (if state then 1 else 0);
      end if;
   end Set_Layer_State;

   -------------------
   -- Reload_Config --
   -------------------

   procedure Reload_Config (Immediate : Boolean) is
   begin
      if Immediate then
         Sync.Apply_Immediate;
      else
         Sync.Wait;
      end if;
   end Reload_Config;

   ---------------
   -- LTDC_Init --
   ---------------

   procedure LTDC_Init
   is
      DivR_Val : PLLSAI_DivR;

   begin
      RCC_Periph.APB2ENR.LTDCEN := 1;

      LTDC_Periph.GCR.VSPOL := To_Bit (Polarity_Active_Low);
      LTDC_Periph.GCR.HSPOL := To_Bit (Polarity_Active_Low);
      LTDC_Periph.GCR.DEPOL := To_Bit (Polarity_Active_Low);
      LTDC_Periph.GCR.PCPOL := To_Bit (Input_Pixel_Clock);

      if DivR = 2 then
         DivR_Val := PLLSAI_DIV2;
      elsif DivR = 4 then
         DivR_Val := PLLSAI_DIV4;
      elsif DivR = 8 then
         DivR_Val := PLLSAI_DIV8;
      elsif DivR = 16 then
         DivR_Val := PLLSAI_DIV16;
      else
         raise Constraint_Error with "Invalid DivR value: 2, 4, 8, 16 allowed";
      end if;

      Disable_PLLSAI;
      Set_PLLSAI_Factors
        (LCD  => PLLSAI_R,
         VCO  => PLLSAI_N,
         DivR => DivR_Val);
      Enable_PLLSAI;

      --  Synchronization size
      LTDC_Periph.SSCR :=
        (HSW => SSCR_HSW_Field (LCD_HSync - 1),
         VSH => SSCR_VSH_Field (LCD_VSync - 1),
         others => <>);

      --  Accumulated Back Porch
      LTDC_Periph.BPCR :=
        (AHBP => BPCR_AHBP_Field (LCD_HSync + LCD_HBP - 1),
         AVBP => BPCR_AVBP_Field (LCD_VSync + LCD_VBP - 1),
         others => <>);

      --  Accumulated Active Width/Height
      LTDC_Periph.AWCR :=
        (AAW => AWCR_AAW_Field (LCD_HSync + LCD_HBP + LCD_Width - 1),
         AAH => AWCR_AAH_FIeld (LCD_VSync + LCD_VBP + LCD_Height - 1),
         others => <>);

      --  VTotal Width/Height
      LTDC_Periph.TWCR :=
        (TOTALW =>
           TWCR_TOTALW_Field (LCD_HSync + LCD_HBP + LCD_Width + LCD_HFP - 1),
         TOTALH =>
           TWCR_TOTALH_Field (LCD_VSync + LCD_VBP + LCD_Height + LCD_VFP - 1),
         others => <>);

      --  Background color to black
      LTDC_Periph.BCCR.BC := 0;

      Reload_Config (True);

      LTDC_Periph.GCR.LTDCEN := 1;
   end LTDC_Init;

   -----------------
   -- Layers_Init --
   -----------------

   procedure Layer_Init
     (Layer    : LCD_Layer;
      Config   : Pixel_Format;
      BF1, BF2 : UInt3)
   is
      L    : constant Layer_Access := Get_Layer (Layer);
      CFBL : L1CFBLR_Register := L.LCFBLR;
   begin
      --  Horizontal start and stop = sync + Back Porch
      L.LWHPCR :=
        (WHSTPOS => UInt12 (LCD_HSync + LCD_HBP),
         WHSPPOS => UInt12 (LCD_HSync + LCD_HBP + LCD_Width - 1),
         others  => <>);

      --  Vertical start and stop
      L.LWVPCR :=
        (WVSTPOS => UInt11 (LCD_VSync + LCD_VBP),
         WVSPPOS => UInt11 (LCD_VSync + LCD_VBP + LCD_Height - 1),
         others  => <>);

      L.LPFCR.PF := Pixel_Format'Enum_Rep (Config);

      L.LCACR.CONSTA := 255;

      L.LDCCR := (others => 0);

      L.LBFCR.BF1 := BF1;
      L.LBFCR.BF2 := BF2;

      CFBL.CFBLL := UInt13 (LCD_Width * Pixel_Size (Config)) + 3;
      CFBL.CFBP := UInt13 (LCD_Width * Pixel_Size (Config));
      L.LCFBLR := CFBL;

      L.LCFBLNR.CFBLNBR := UInt11 (LCD_Height);

      Set_Layer_CFBA (Layer, Frame_Buffer_Array (Layer));

      Reload_Config (True);
   end Layer_Init;

end Init;

with STM32_SVD.Interrupts;

separate (STM32.LTDC)
package body Init is

   pragma Warnings (Off, "* is not referenced");
   type LCD_Polarity is
     (Polarity_Active_Low,
      Polarity_Active_High) with Size => 1;
   type LCD_PC_Polarity is
     (Input_Pixel_Clock,
      Inverted_Input_Pixel_Clock) with Size => 1;
   pragma Warnings (On, "* is not referenced");

   function To_Bit is new Ada.Unchecked_Conversion (LCD_Polarity, Bit);
   function To_Bit is new Ada.Unchecked_Conversion (LCD_PC_Polarity, Bit);

   --  Extracted from STM32F429x.LTDC
   type Layer_Type is record
      LCR        : L1CR_Register; --  Layerx Control Register
      LWHPCR     : L1WHPCR_Register; --  Layerx Window Horizontal Position Configuration Register
      LWVPCR     : L1WVPCR_Register; --  Layerx Window Vertical Position Configuration Register
      LCKCR      : L1CKCR_Register; --  Layerx Color Keying Configuration Register
      LPFCR      : L1PFCR_Register; --  Layerx Pixel Format Configuration Register
      LCACR      : L1CACR_Register; --  Layerx Constant Alpha Configuration Register
      LDCCR      : L1DCCR_Register; --  Layerx Default Color Configuration Register
      LBFCR      : L1BFCR_Register; --  Layerx Blending Factors Configuration Register
      Reserved_0 : Word;
      Reserved_1 : Word;
      LCFBAR     : Word; --  Layerx Color Frame Buffer Address Register
      LCFBLR     : L1CFBLR_Register; --  Layerx Color Frame Buffer Length Register
      LCFBLNR    : L1CFBLNR_Register; --  Layerx ColorFrame Buffer Line Number Register
      Reserved_2 : Word;
      Reserved_3 : Word;
      Reserved_4 : Word;
      LCLUTWR    : L1CLUTWR_Register; --  Layerx CLUT Write Register
   end record with Volatile;

   for Layer_Type use record
      LCR        at  0 range 0 .. 31;
      LWHPCR     at  4 range 0 .. 31;
      LWVPCR     at  8 range 0 .. 31;
      LCKCR      at 12 range 0 .. 31;
      LPFCR      at 16 range 0 .. 31;
      LCACR      at 20 range 0 .. 31;
      LDCCR      at 24 range 0 .. 31;
      LBFCR      at 28 range 0 .. 31;
      Reserved_0 at 32 range 0 .. 31;
      Reserved_1 at 36 range 0 .. 31;
      LCFBAR     at 40 range 0 .. 31;
      LCFBLR     at 44 range 0 .. 31;
      LCFBLNR    at 48 range 0 .. 31;
      Reserved_2 at 52 range 0 .. 31;
      Reserved_3 at 56 range 0 .. 31;
      Reserved_4 at 60 range 0 .. 31;
      LCLUTWR    at 64 range 0 .. 31;
   end record;
   type Layer_Access is access all Layer_Type;

   G_Layer1_Reg : aliased Layer_Type
     with Import, Address => LTDC_Periph.L1CR'Address;
   G_Layer2_Reg : aliased Layer_Type
     with Import, Address => LTDC_Periph.L2CR'Address;

   type Pending_Buffers is array (LCD_Layer) of Word;

   protected Sync is
      --  Sets the next buffer to setup
      procedure Set_Pending (Layer  : LCD_Layer;
                             Buffer : Word);

      --  Apply pending buffers without waiting for the interrupt
      procedure Apply_Immediate;

      --  Wait for an interrupt.
      entry Wait;

      procedure Interrupt;
      pragma Attach_Handler
        (Interrupt, STM32_SVD.Interrupts.LCD_TFT_Interrupt);
   private
      Not_Pending : Boolean := True;
      Buffers     : Pending_Buffers := (others => 0);
   end Sync;

   protected body Sync is
      -----------------
      -- Set_Pending --
      -----------------

      procedure Set_Pending
        (Layer  : LCD_Layer;
         Buffer : Word)
      is
      begin
         Not_Pending := False;
         LTDC_Periph.IER.LIE := 1;
         LTDC_Periph.LIPCR.LIPOS := 0;
         Buffers (Layer) := Buffer;
      end Set_Pending;

      ----------
      -- Wait --
      ----------

      entry Wait when Not_Pending is
      begin
         null;
      end Wait;

      ---------------------
      -- Apply_Immediate --
      ---------------------

      procedure Apply_Immediate is
      begin
         LTDC_Periph.IER.LIE := 0;

         if Buffers (Layer1) /= 0 then
            LTDC_Periph.L1CFBAR := Buffers (Layer1);
            Buffers (Layer1) := 0;
         end if;

         if Buffers (Layer2) /= 0 then
            LTDC_Periph.L2CFBAR := Buffers (Layer2);
            Buffers (Layer2) := 0;
         end if;

         LTDC_Periph.SRCR.IMR := 1;
         loop
            exit when LTDC_Periph.SRCR.IMR = 0;
         end loop;

         Not_Pending := True;
         LTDC_Periph.IER.LIE := 1;
      end Apply_Immediate;

      ---------------
      -- Interrupt --
      ---------------

      procedure Interrupt
      is
      begin
         LTDC_Periph.IER.LIE := 0;
         LTDC_Periph.ICR.CLIF  := 1;

         Apply_Immediate;
      end Interrupt;
   end Sync;

   ---------------
   -- Get_Layer --
   ---------------

   function Get_Layer (Layer : LCD_Layer) return Layer_Access is
   begin
      if Layer = Layer1 then
         return G_Layer1_Reg'Access;
      else
         return G_Layer2_Reg'Access;
      end if;
   end Get_Layer;

   --------------------
   -- Set_Layer_CFBA --
   --------------------

   procedure Set_Layer_CFBA (Layer : LCD_Layer;
                             FBA   : Frame_Buffer_Access)
   is
--        L : constant Layer_Access := Get_Layer (Layer);
      function To_Word is new Ada.Unchecked_Conversion
        (Frame_Buffer_Access, Word);
   begin
      Sync.Set_Pending (Layer, To_Word (FBA));
--           L.LCFBAR := To_Word (FBA);
   end Set_Layer_CFBA;

   --------------------
   -- Get_Layer_CFBA --
   --------------------

   function Get_Layer_CFBA
     (Layer : LCD_Layer) return Frame_Buffer_Access
   is
      L : constant Layer_Access := Get_Layer (Layer);
      function To_FBA is new Ada.Unchecked_Conversion
        (Word, Frame_Buffer_Access);
   begin
      return To_FBA (L.LCFBAR);
   end Get_Layer_CFBA;

   ---------------------
   -- Set_Layer_State --
   ---------------------

   procedure Set_Layer_State
     (Layer : LCD_Layer;
      State : Boolean)
   is
      L   : constant Layer_Access := Get_Layer (Layer);
      Val : constant Bit := (if State then 1 else 0);
   begin
      if State and then Frame_Buffer_Array (Layer) = Null_Address then
         Frame_Buffer_Array (Layer) := STM32.SDRAM.Reserve
           (Word (LCD_Width * LCD_Height * Pixel_Size (Current_Pixel_Fmt)));
         Set_Layer_CFBA (Layer, Frame_Buffer_Array (Layer));
      end if;

      if L.LCR.LEN /= Val then
         L.LCR.LEN := Val;
         Reload_Config (Immediate => True);
      else

         L.LCR.LEN := (if state then 1 else 0);
      end if;
   end Set_Layer_State;

   -------------------
   -- Reload_Config --
   -------------------

   procedure Reload_Config (Immediate : Boolean) is
   begin
      if Immediate then
         Sync.Apply_Immediate;
      else
         Sync.Wait;
      end if;
   end Reload_Config;

   ---------------
   -- LTDC_Init --
   ---------------

   procedure LTDC_Init
   is
      DivR_Val : PLLSAI_DivR;

   begin
      RCC_Periph.APB2ENR.LTDCEN := 1;

      LTDC_Periph.GCR.VSPOL := To_Bit (Polarity_Active_Low);
      LTDC_Periph.GCR.HSPOL := To_Bit (Polarity_Active_Low);
      LTDC_Periph.GCR.DEPOL := To_Bit (Polarity_Active_Low);
      LTDC_Periph.GCR.PCPOL := To_Bit (Input_Pixel_Clock);

      if DivR = 2 then
         DivR_Val := PLLSAI_DIV2;
      elsif DivR = 4 then
         DivR_Val := PLLSAI_DIV4;
      elsif DivR = 8 then
         DivR_Val := PLLSAI_DIV8;
      elsif DivR = 16 then
         DivR_Val := PLLSAI_DIV16;
      else
         raise Constraint_Error with "Invalid DivR value: 2, 4, 8, 16 allowed";
      end if;

      Disable_PLLSAI;
      Set_PLLSAI_Factors
        (LCD  => PLLSAI_R,
         VCO  => PLLSAI_N,
         DivR => DivR_Val);
      Enable_PLLSAI;

      --  Synchronization size
      LTDC_Periph.SSCR :=
        (HSW => SSCR_HSW_Field (LCD_HSync - 1),
         VSH => SSCR_VSH_Field (LCD_VSync - 1),
         others => <>);

      --  Accumulated Back Porch
      LTDC_Periph.BPCR :=
        (AHBP => BPCR_AHBP_Field (LCD_HSync + LCD_HBP - 1),
         AVBP => BPCR_AVBP_Field (LCD_VSync + LCD_VBP - 1),
         others => <>);

      --  Accumulated Active Width/Height
      LTDC_Periph.AWCR :=
        (AAW => AWCR_AAW_Field (LCD_HSync + LCD_HBP + LCD_Width - 1),
         AAH => AWCR_AAH_FIeld (LCD_VSync + LCD_VBP + LCD_Height - 1),
         others => <>);

      --  VTotal Width/Height
      LTDC_Periph.TWCR :=
        (TOTALW =>
           TWCR_TOTALW_Field (LCD_HSync + LCD_HBP + LCD_Width + LCD_HFP - 1),
         TOTALH =>
           TWCR_TOTALH_Field (LCD_VSync + LCD_VBP + LCD_Height + LCD_VFP - 1),
         others => <>);

      --  Background color to black
      LTDC_Periph.BCCR.BC := 0;

      Reload_Config (True);

      LTDC_Periph.GCR.LTDCEN := 1;
   end LTDC_Init;

   -----------------
   -- Layers_Init --
   -----------------

   procedure Layer_Init
     (Layer    : LCD_Layer;
      Config   : Pixel_Format;
      BF1, BF2 : UInt3)
   is
      L    : constant Layer_Access := Get_Layer (Layer);
      CFBL : L1CFBLR_Register := L.LCFBLR;
   begin
      --  Horizontal start and stop = sync + Back Porch
      L.LWHPCR :=
        (WHSTPOS => UInt12 (LCD_HSync + LCD_HBP),
         WHSPPOS => UInt12 (LCD_HSync + LCD_HBP + LCD_Width - 1),
         others  => <>);

      --  Vertical start and stop
      L.LWVPCR :=
        (WVSTPOS => UInt11 (LCD_VSync + LCD_VBP),
         WVSPPOS => UInt11 (LCD_VSync + LCD_VBP + LCD_Height - 1),
         others  => <>);

      L.LPFCR.PF := Pixel_Format'Enum_Rep (Config);

      L.LCACR.CONSTA := 255;

      L.LDCCR := (others => 0);

      L.LBFCR.BF1 := BF1;
      L.LBFCR.BF2 := BF2;

      CFBL.CFBLL := UInt13 (LCD_Width * Pixel_Size (Config)) + 3;
      CFBL.CFBP := UInt13 (LCD_Width * Pixel_Size (Config));
      L.LCFBLR := CFBL;

      L.LCFBLNR.CFBLNBR := UInt11 (LCD_Height);

      Set_Layer_CFBA (Layer, Frame_Buffer_Array (Layer));

      Reload_Config (True);
   end Layer_Init;

end Init;

Fix simple barier in LTDC driver (ravenscar-sfp limitation).


-----------------------------------------------------------------------
--  ADO Sqlite Database -- SQLite Database connections
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 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 Interfaces.C.Strings;

with Util.Log;
with Util.Log.Loggers;
with Util.Processes.Tools;
with ADO.Sessions;
with ADO.Statements.Sqlite;
with ADO.Schemas.Sqlite;

package body ADO.Drivers.Connections.Sqlite is

   use ADO.Statements.Sqlite;
   use Interfaces.C;

   pragma Linker_Options ("-lsqlite3");

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Databases.Sqlite");

   Driver_Name : aliased constant String := "sqlite";
   Driver      : aliased Sqlite_Driver;

   --  ------------------------------
   --  Get the database driver which manages this connection.
   --  ------------------------------
   overriding
   function Get_Driver (Database : in Database_Connection)
                        return Driver_Access is
      pragma Unreferenced (Database);
   begin
      return Driver'Access;
   end Get_Driver;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Query    : in String)
                              return Query_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Query => Query);
   end Create_Statement;

   --  ------------------------------
   --  Create a delete statement.
   --  ------------------------------
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   --  ------------------------------
   --  Create an insert statement.
   --  ------------------------------
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   --  ------------------------------
   --  Create an update statement.
   --  ------------------------------
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   --  ------------------------------
   --  Start a transaction.
   --  ------------------------------
   procedure Begin_Transaction (Database : in out Database_Connection) is
   begin
      if Database.Server = null then
         raise ADO.Sessions.Session_Error with "Database connection is closed";
      end if;
   end Begin_Transaction;

   --  ------------------------------
   --  Commit the current transaction.
   --  ------------------------------
   procedure Commit (Database : in out Database_Connection) is
   begin
      if Database.Server = null then
         raise ADO.Sessions.Session_Error with "Database connection is closed";
      end if;
   end Commit;

   --  ------------------------------
   --  Rollback the current transaction.
   --  ------------------------------
   procedure Rollback (Database : in out Database_Connection) is
   begin
      if Database.Server = null then
         raise ADO.Sessions.Session_Error with "Database connection is closed";
      end if;
   end Rollback;

   --  ------------------------------
   --  Closes the database connection
   --  ------------------------------
   overriding
   procedure Close (Database : in out Database_Connection) is
      Result : int;
   begin
      Log.Info ("Close connection {0}", Database.Name);

      if Database.Server /= null then
         Result := Sqlite3_H.sqlite3_close_v2 (Database.Server);
         if Result /= Sqlite3_H.SQLITE_OK then
            declare
               Error : constant Strings.chars_ptr := Sqlite3_H.sqlite3_errstr (Result);
               Msg   : constant String := Strings.Value (Error);
            begin
               Log.Error ("Cannot close database {0}: {1}", To_String (Database.Name), Msg);
            end;
         end if;
         Database.Server := null;
      end if;
   end Close;

   --  ------------------------------
   --  Releases the sqlite connection if it is open
   --  ------------------------------
   overriding
   procedure Finalize (Database : in out Database_Connection) is
   begin
      Log.Debug ("Release database connection");

      if Database.Server /= null then
         Database.Close;
      end if;
   end Finalize;

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

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

      Status        : Integer;
      Database_Path : constant String := Config.Get_Database;
      Command       : constant String :=
        "sqlite3 --batch --init " & Schema_Path & " " & Database_Path;
   begin
      Log.Info ("Creating SQLite database {0}", Database_Path);
      Messages.Clear;
      Util.Processes.Tools.Execute (Command, Messages, Status);

      if Status = 0 then
         Log.Info ("Database schema created successfully.");
      elsif Status = 255 then
         Messages.Append ("Command not found: " & Command);
         Log.Error ("Command not found: {0}", Command);
      else
         Log.Error ("Command {0} failed with exit code {1}", Command,
                    Util.Strings.Image (Status));
      end if;
   end Create_Database;

   --  ------------------------------
   --  Initialize the database connection manager.
   --  ------------------------------
   procedure Create_Connection (D      : in out Sqlite_Driver;
                                Config : in Configuration'Class;
                                Result : in out Ref.Ref'Class) is
      pragma Unreferenced (D);
      use Strings;

      Name     : constant String := Config.Get_Database;
      Filename : Strings.chars_ptr;
      Status   : int;
      Handle   : aliased access Sqlite3;
      Flags    : constant int := Sqlite3_H.SQLITE_OPEN_FULLMUTEX + Sqlite3_H.SQLITE_OPEN_READWRITE;
   begin
      Log.Info ("Opening database {0}", Name);

      Filename := Strings.New_String (Name);
      Status := Sqlite3_H.sqlite3_open_v2 (Filename, Handle'Address,
                                           Flags,
                                           Strings.Null_Ptr);

      Strings.Free (Filename);
      if Status /= Sqlite3_H.SQLITE_OK then
         declare
            Error : constant Strings.chars_ptr := Sqlite3_H.sqlite3_errstr (Status);
            Msg   : constant String := Strings.Value (Error);
         begin
            Log.Error ("Cannot open SQLite database: {0}", Msg);
            raise ADO.Configs.Connection_Error with "Cannot open database: " & Msg;
         end;
      end if;

      declare
         Database : constant Database_Connection_Access := new Database_Connection;

         procedure Configure (Name : in String;
                              Item : in Util.Properties.Value);
         function Escape (Value : in Util.Properties.Value) return String;

         function Escape (Value : in Util.Properties.Value) return String is
            S : constant String := Util.Properties.To_String (Value);
         begin
            if S'Length > 0 and then S (S'First) >= '0' and then S (S'First) <= '9' then
               return S;
            elsif S'Length > 0 and then S (S'First) = ''' then
               return S;
            else
               return "'" & S & "'";
            end if;
         end Escape;

         procedure Configure (Name : in String;
                              Item : in Util.Properties.Value) is
            SQL : constant String := "PRAGMA " & Name & "=" & Escape (Item);
         begin
            if Util.Strings.Index (Name, '.') = 0 then
               Log.Info ("Configure database with {0}", SQL);
               ADO.Statements.Sqlite.Execute (Database.Server, SQL);
            end if;

         exception
            when SQL_Error =>
               null;
         end Configure;

      begin
         Database.Server := Handle;
         Database.Name   := To_Unbounded_String (Config.Get_Database);
         Result := Ref.Create (Database.all'Access);

         --  Configure the connection by setting up the SQLite 'pragma X=Y' SQL commands.
         --  Typical configuration includes:
         --    synchronous=OFF
         --    temp_store=MEMORY
         --    encoding='UTF-8'
         Config.Iterate (Process => Configure'Access);
      end;
   end Create_Connection;

   --  ------------------------------
   --  Initialize the SQLite driver.
   --  ------------------------------
   procedure Initialize is
      use type Util.Strings.Name_Access;
   begin
      Log.Debug ("Initializing sqlite driver");

      if Driver.Name = null then
         Driver.Name := Driver_Name'Access;
         Register (Driver'Access);
      end if;
   end Initialize;

end ADO.Drivers.Connections.Sqlite;

-----------------------------------------------------------------------
--  ADO Sqlite Database -- SQLite Database connections
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 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 Interfaces.C.Strings;

with Util.Log;
with Util.Log.Loggers;
with Util.Processes.Tools;
with ADO.Sessions;
with ADO.Statements.Sqlite;
with ADO.Schemas.Sqlite;

package body ADO.Drivers.Connections.Sqlite is

   use ADO.Statements.Sqlite;
   use Interfaces.C;

   pragma Linker_Options ("-lsqlite3");

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Databases.Sqlite");

   Driver_Name : aliased constant String := "sqlite";
   Driver      : aliased Sqlite_Driver;

   --  ------------------------------
   --  Get the database driver which manages this connection.
   --  ------------------------------
   overriding
   function Get_Driver (Database : in Database_Connection)
                        return Driver_Access is
      pragma Unreferenced (Database);
   begin
      return Driver'Access;
   end Get_Driver;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Query    : in String)
                              return Query_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Query => Query);
   end Create_Statement;

   --  ------------------------------
   --  Create a delete statement.
   --  ------------------------------
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   --  ------------------------------
   --  Create an insert statement.
   --  ------------------------------
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   --  ------------------------------
   --  Create an update statement.
   --  ------------------------------
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   --  ------------------------------
   --  Start a transaction.
   --  ------------------------------
   procedure Begin_Transaction (Database : in out Database_Connection) is
   begin
      if Database.Server = null then
         raise ADO.Sessions.Session_Error with "Database connection is closed";
      end if;
   end Begin_Transaction;

   --  ------------------------------
   --  Commit the current transaction.
   --  ------------------------------
   procedure Commit (Database : in out Database_Connection) is
   begin
      if Database.Server = null then
         raise ADO.Sessions.Session_Error with "Database connection is closed";
      end if;
   end Commit;

   --  ------------------------------
   --  Rollback the current transaction.
   --  ------------------------------
   procedure Rollback (Database : in out Database_Connection) is
   begin
      if Database.Server = null then
         raise ADO.Sessions.Session_Error with "Database connection is closed";
      end if;
   end Rollback;

   --  ------------------------------
   --  Closes the database connection
   --  ------------------------------
   overriding
   procedure Close (Database : in out Database_Connection) is
      Result : int;
   begin
      Log.Info ("Close connection {0}", Database.Name);

      if Database.Server /= null then
         Result := Sqlite3_H.sqlite3_close_v2 (Database.Server);
         if Result /= Sqlite3_H.SQLITE_OK then
            declare
               Error : constant Strings.chars_ptr := Sqlite3_H.sqlite3_errstr (Result);
               Msg   : constant String := Strings.Value (Error);
            begin
               Log.Error ("Cannot close database {0}: {1}", To_String (Database.Name), Msg);
            end;
         end if;
         Database.Server := null;
      end if;
   end Close;

   --  ------------------------------
   --  Releases the sqlite connection if it is open
   --  ------------------------------
   overriding
   procedure Finalize (Database : in out Database_Connection) is
   begin
      Log.Debug ("Release database connection");

      if Database.Server /= null then
         Database.Close;
      end if;
   end Finalize;

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

   --  ------------------------------
   --  Initialize the database connection manager.
   --  ------------------------------
   procedure Create_Connection (D      : in out Sqlite_Driver;
                                Config : in Configuration'Class;
                                Result : in out Ref.Ref'Class) is
      pragma Unreferenced (D);
      use Strings;

      Name     : constant String := Config.Get_Database;
      Filename : Strings.chars_ptr;
      Status   : int;
      Handle   : aliased access Sqlite3;
      Flags    : constant int := Sqlite3_H.SQLITE_OPEN_FULLMUTEX + Sqlite3_H.SQLITE_OPEN_READWRITE;
   begin
      Log.Info ("Opening database {0}", Name);

      Filename := Strings.New_String (Name);
      Status := Sqlite3_H.sqlite3_open_v2 (Filename, Handle'Address,
                                           Flags,
                                           Strings.Null_Ptr);

      Strings.Free (Filename);
      if Status /= Sqlite3_H.SQLITE_OK then
         declare
            Error : constant Strings.chars_ptr := Sqlite3_H.sqlite3_errstr (Status);
            Msg   : constant String := Strings.Value (Error);
         begin
            Log.Error ("Cannot open SQLite database: {0}", Msg);
            raise ADO.Configs.Connection_Error with "Cannot open database: " & Msg;
         end;
      end if;

      declare
         Database : constant Database_Connection_Access := new Database_Connection;

         procedure Configure (Name : in String;
                              Item : in Util.Properties.Value);
         function Escape (Value : in Util.Properties.Value) return String;

         function Escape (Value : in Util.Properties.Value) return String is
            S : constant String := Util.Properties.To_String (Value);
         begin
            if S'Length > 0 and then S (S'First) >= '0' and then S (S'First) <= '9' then
               return S;
            elsif S'Length > 0 and then S (S'First) = ''' then
               return S;
            else
               return "'" & S & "'";
            end if;
         end Escape;

         procedure Configure (Name : in String;
                              Item : in Util.Properties.Value) is
            SQL : constant String := "PRAGMA " & Name & "=" & Escape (Item);
         begin
            if Util.Strings.Index (Name, '.') = 0 then
               Log.Info ("Configure database with {0}", SQL);
               ADO.Statements.Sqlite.Execute (Database.Server, SQL);
            end if;

         exception
            when SQL_Error =>
               null;
         end Configure;

      begin
         Database.Server := Handle;
         Database.Name   := To_Unbounded_String (Config.Get_Database);
         Result := Ref.Create (Database.all'Access);

         --  Configure the connection by setting up the SQLite 'pragma X=Y' SQL commands.
         --  Typical configuration includes:
         --    synchronous=OFF
         --    temp_store=MEMORY
         --    encoding='UTF-8'
         Config.Iterate (Process => Configure'Access);
      end;
   end Create_Connection;

   --  ------------------------------
   --  Create the database and initialize it with the schema SQL file.
   --  The `Admin` parameter describes the database connection with administrator access.
   --  The `Config` parameter describes the target database connection.
   --  ------------------------------
   overriding
   procedure Create_Database (D           : in out Sqlite_Driver;
                              Admin       : in Configs.Configuration'Class;
                              Config      : in Configs.Configuration'Class;
                              Schema_Path : in String;
                              Messages    : out Util.Strings.Vectors.Vector) is
      pragma Unreferenced (D, Admin);

      Status        : Integer;
      Database_Path : constant String := Config.Get_Database;
      Command       : constant String :=
        "sqlite3 --batch --init " & Schema_Path & " " & Database_Path;
   begin
      Log.Info ("Creating SQLite database {0}", Database_Path);
      Util.Processes.Tools.Execute (Command, Messages, Status);

      if Status = 0 then
         Log.Info ("Database schema created successfully.");
      elsif Status = 255 then
         Messages.Append ("Command not found: " & Command);
         Log.Error ("Command not found: {0}", Command);
      else
         Messages.Append ("Command " & Command & " failed with exit code "
                            & Util.Strings.Image (Status));
         Log.Error ("Command {0} failed with exit code {1}", Command,
                    Util.Strings.Image (Status));
      end if;
   end Create_Database;

   --  ------------------------------
   --  Initialize the SQLite driver.
   --  ------------------------------
   procedure Initialize is
      use type Util.Strings.Name_Access;
   begin
      Log.Debug ("Initializing sqlite driver");

      if Driver.Name = null then
         Driver.Name := Driver_Name'Access;
         Register (Driver'Access);
      end if;
   end Initialize;

end ADO.Drivers.Connections.Sqlite;

Move the Create_Database operation on the Driver instead of the database connection


-----------------------------------------------------------------------
--  ADO Sqlite Database -- SQLite Database connections
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 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 Interfaces.C.Strings;

with Util.Log;
with Util.Log.Loggers;
with Util.Processes.Tools;
with ADO.Sessions;
with ADO.Statements.Sqlite;
with ADO.Schemas.Sqlite;

package body ADO.Drivers.Connections.Sqlite is

   use ADO.Statements.Sqlite;
   use Interfaces.C;

   pragma Linker_Options ("-lsqlite3");

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Databases.Sqlite");

   Driver_Name : aliased constant String := "sqlite";
   Driver      : aliased Sqlite_Driver;

   --  ------------------------------
   --  Get the database driver which manages this connection.
   --  ------------------------------
   overriding
   function Get_Driver (Database : in Database_Connection)
                        return Driver_Access is
      pragma Unreferenced (Database);
   begin
      return Driver'Access;
   end Get_Driver;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Query    : in String)
                              return Query_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Query => Query);
   end Create_Statement;

   --  ------------------------------
   --  Create a delete statement.
   --  ------------------------------
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   --  ------------------------------
   --  Create an insert statement.
   --  ------------------------------
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   --  ------------------------------
   --  Create an update statement.
   --  ------------------------------
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   --  ------------------------------
   --  Start a transaction.
   --  ------------------------------
   procedure Begin_Transaction (Database : in out Database_Connection) is
   begin
      if Database.Server = null then
         raise ADO.Sessions.Session_Error with "Database connection is closed";
      end if;
   end Begin_Transaction;

   --  ------------------------------
   --  Commit the current transaction.
   --  ------------------------------
   procedure Commit (Database : in out Database_Connection) is
   begin
      if Database.Server = null then
         raise ADO.Sessions.Session_Error with "Database connection is closed";
      end if;
   end Commit;

   --  ------------------------------
   --  Rollback the current transaction.
   --  ------------------------------
   procedure Rollback (Database : in out Database_Connection) is
   begin
      if Database.Server = null then
         raise ADO.Sessions.Session_Error with "Database connection is closed";
      end if;
   end Rollback;

   --  ------------------------------
   --  Closes the database connection
   --  ------------------------------
   overriding
   procedure Close (Database : in out Database_Connection) is
   begin
      Log.Info ("Close connection {0}", Database.Name);
   end Close;

   --  ------------------------------
   --  Releases the sqlite connection if it is open
   --  ------------------------------
   overriding
   procedure Finalize (Database : in out Database_Connection) is
      Result : int;
   begin
      Log.Debug ("Release database connection");

      if Database.Server /= null then
         Result := Sqlite3_H.sqlite3_close_v2 (Database.Server);
         if Result /= Sqlite3_H.SQLITE_OK then
            declare
               Error : constant Strings.chars_ptr := Sqlite3_H.sqlite3_errstr (Result);
               Msg   : constant String := Strings.Value (Error);
            begin
               Log.Error ("Cannot close database {0}: {1}", To_String (Database.Name), Msg);
            end;
         end if;
         Database.Server := null;
      end if;
   end Finalize;

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

   protected body Sqlite_Connections is

      procedure Open (Config : in Configuration'Class;
                      Result : in out Ref.Ref'Class) is
         use Strings;

         URI : constant String := Config.Get_URI;
         Pos : Database_List.Cursor := Database_List.First (List);
         C   : Database_Connection_Access;
      begin
         --  Look first in the database list.
         while Database_List.Has_Element (Pos) loop
            C := Database_Connection'Class (Database_List.Element (Pos).Value.all)'Access;
            if C.URI = URI then
               Result := Ref.Ref'Class (Database_List.Element (Pos));
               return;
            end if;
            Database_List.Next (Pos);
         end loop;

         --  Now we can open a new database connection.
         declare
            Name     : constant String := Config.Get_Database;
            Filename : Strings.chars_ptr;
            Status   : int;
            Handle   : aliased access Sqlite3;
            Flags    : constant int
              := Sqlite3_H.SQLITE_OPEN_FULLMUTEX + Sqlite3_H.SQLITE_OPEN_READWRITE;
         begin
            Filename := Strings.New_String (Name);
            Status := Sqlite3_H.sqlite3_open_v2 (Filename, Handle'Address,
                                                 Flags,
                                                 Strings.Null_Ptr);

            Strings.Free (Filename);
            if Status /= Sqlite3_H.SQLITE_OK then
               declare
                  Error : constant Strings.chars_ptr := Sqlite3_H.sqlite3_errstr (Status);
                  Msg   : constant String := Strings.Value (Error);
               begin
                  Log.Error ("Cannot open SQLite database: {0}", Msg);
                  raise ADO.Configs.Connection_Error with "Cannot open database: " & Msg;
               end;
            end if;

            declare
               Database : constant Database_Connection_Access := new Database_Connection;

               procedure Configure (Name : in String;
                                    Item : in Util.Properties.Value);
               function Escape (Value : in Util.Properties.Value) return String;

               function Escape (Value : in Util.Properties.Value) return String is
                  S : constant String := Util.Properties.To_String (Value);
               begin
                  if S'Length > 0 and then S (S'First) >= '0' and then S (S'First) <= '9' then
                     return S;
                  elsif S'Length > 0 and then S (S'First) = ''' then
                     return S;
                  else
                     return "'" & S & "'";
                  end if;
               end Escape;

               procedure Configure (Name : in String;
                                    Item : in Util.Properties.Value) is
                  SQL : constant String := "PRAGMA " & Name & "=" & Escape (Item);
               begin
                  if Util.Strings.Index (Name, '.') = 0 then
                     Log.Info ("Configure database with {0}", SQL);
                     ADO.Statements.Sqlite.Execute (Database.Server, SQL);
                  end if;

               exception
                  when SQL_Error =>
                     null;
               end Configure;

            begin
               Database.Server := Handle;
               Database.Name   := To_Unbounded_String (Config.Get_Database);
               Database.URI    := To_Unbounded_String (URI);
               Result := Ref.Create (Database.all'Access);

               Database_List.Prepend (Container => List, New_Item => Ref.Ref (Result));

               --  Configure the connection by setting up the SQLite 'pragma X=Y' SQL commands.
               --  Typical configuration includes:
               --    synchronous=OFF
               --    temp_store=MEMORY
               --    encoding='UTF-8'
               Config.Iterate (Process => Configure'Access);
            end;
         end;
      end Open;

   end Sqlite_Connections;

   --  ------------------------------
   --  Initialize the database connection manager.
   --  ------------------------------
   procedure Create_Connection (D      : in out Sqlite_Driver;
                                Config : in Configuration'Class;
                                Result : in out Ref.Ref'Class) is
   begin
      D.Map.Open (Config, Result);
   end Create_Connection;

   --  ------------------------------
   --  Create the database and initialize it with the schema SQL file.
   --  The `Admin` parameter describes the database connection with administrator access.
   --  The `Config` parameter describes the target database connection.
   --  ------------------------------
   overriding
   procedure Create_Database (D           : in out Sqlite_Driver;
                              Admin       : in Configs.Configuration'Class;
                              Config      : in Configs.Configuration'Class;
                              Schema_Path : in String;
                              Messages    : out Util.Strings.Vectors.Vector) is
      pragma Unreferenced (D, Admin);

      Status        : Integer;
      Database_Path : constant String := Config.Get_Database;
      Command       : constant String :=
        "sqlite3 --batch --init " & Schema_Path & " " & Database_Path;
   begin
      Log.Info ("Creating SQLite database {0}", Database_Path);
      Util.Processes.Tools.Execute (Command, Messages, Status);

      if Status = 0 then
         Log.Info ("Database schema created successfully.");
      elsif Status = 255 then
         Messages.Append ("Command not found: " & Command);
         Log.Error ("Command not found: {0}", Command);
      else
         Messages.Append ("Command " & Command & " failed with exit code "
                            & Util.Strings.Image (Status));
         Log.Error ("Command {0} failed with exit code {1}", Command,
                    Util.Strings.Image (Status));
      end if;
   end Create_Database;

   --  ------------------------------
   --  Initialize the SQLite driver.
   --  ------------------------------
   procedure Initialize is
      use type Util.Strings.Name_Access;
   begin
      Log.Debug ("Initializing sqlite driver");

      if Driver.Name = null then
         Driver.Name := Driver_Name'Access;
         Register (Driver'Access);
      end if;
   end Initialize;

   --  ------------------------------
   --  Deletes the SQLite driver.
   --  ------------------------------
   overriding
   procedure Finalize (D : in out Sqlite_Driver) is
      pragma Unreferenced (D);
   begin
      Log.Debug ("Deleting the sqlite driver");
   end Finalize;

end ADO.Drivers.Connections.Sqlite;

-----------------------------------------------------------------------
--  ADO Sqlite Database -- SQLite Database connections
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 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 Interfaces.C.Strings;

with Util.Log;
with Util.Log.Loggers;
with Util.Processes.Tools;
with ADO.Sessions;
with ADO.Statements.Sqlite;
with ADO.Schemas.Sqlite;

package body ADO.Drivers.Connections.Sqlite is

   use ADO.Statements.Sqlite;
   use Interfaces.C;

   pragma Linker_Options ("-lsqlite3");

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Databases.Sqlite");

   Driver_Name : aliased constant String := "sqlite";
   Driver      : aliased Sqlite_Driver;

   --  ------------------------------
   --  Get the database driver which manages this connection.
   --  ------------------------------
   overriding
   function Get_Driver (Database : in Database_Connection)
                        return Driver_Access is
      pragma Unreferenced (Database);
   begin
      return Driver'Access;
   end Get_Driver;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Query    : in String)
                              return Query_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Query => Query);
   end Create_Statement;

   --  ------------------------------
   --  Create a delete statement.
   --  ------------------------------
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   --  ------------------------------
   --  Create an insert statement.
   --  ------------------------------
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   --  ------------------------------
   --  Create an update statement.
   --  ------------------------------
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement_Access is
   begin
      return Create_Statement (Database => Database.Server, Table => Table);
   end Create_Statement;

   --  ------------------------------
   --  Start a transaction.
   --  ------------------------------
   procedure Begin_Transaction (Database : in out Database_Connection) is
   begin
      if Database.Server = null then
         raise ADO.Sessions.Session_Error with "Database connection is closed";
      end if;
   end Begin_Transaction;

   --  ------------------------------
   --  Commit the current transaction.
   --  ------------------------------
   procedure Commit (Database : in out Database_Connection) is
   begin
      if Database.Server = null then
         raise ADO.Sessions.Session_Error with "Database connection is closed";
      end if;
   end Commit;

   --  ------------------------------
   --  Rollback the current transaction.
   --  ------------------------------
   procedure Rollback (Database : in out Database_Connection) is
   begin
      if Database.Server = null then
         raise ADO.Sessions.Session_Error with "Database connection is closed";
      end if;
   end Rollback;

   --  ------------------------------
   --  Closes the database connection
   --  ------------------------------
   overriding
   procedure Close (Database : in out Database_Connection) is
   begin
      Log.Info ("Close connection {0}", Database.Name);
      Database.Server := null;
   end Close;

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

   protected body Sqlite_Connections is

      procedure Open (Config : in Configuration'Class;
                      Result : in out Ref.Ref'Class) is
         use Strings;

         URI      : constant String := Config.Get_URI;
         Database : Database_Connection_Access;
         Pos      : Database_List.Cursor := Database_List.First (List);
         DB       : SQLite_Database;
      begin
         --  Look first in the database list.
         while Database_List.Has_Element (Pos) loop
            DB := Database_List.Element (Pos);
            if DB.URI = URI then
               Database := new Database_Connection;
               Database.URI := DB.URI;
               Database.Name := DB.Name;
               Database.Server := DB.Server;
               Result := Ref.Create (Database.all'Access);
               return;
            end if;
            Database_List.Next (Pos);
         end loop;

         --  Now we can open a new database connection.
         declare
            Name     : constant String := Config.Get_Database;
            Filename : Strings.chars_ptr;
            Status   : int;
            Handle   : aliased access Sqlite3;
            Flags    : constant int
              := Sqlite3_H.SQLITE_OPEN_FULLMUTEX + Sqlite3_H.SQLITE_OPEN_READWRITE;
         begin
            Filename := Strings.New_String (Name);
            Status := Sqlite3_H.sqlite3_open_v2 (Filename, Handle'Address,
                                                 Flags,
                                                 Strings.Null_Ptr);

            Strings.Free (Filename);
            if Status /= Sqlite3_H.SQLITE_OK then
               declare
                  Error : constant Strings.chars_ptr := Sqlite3_H.sqlite3_errstr (Status);
                  Msg   : constant String := Strings.Value (Error);
               begin
                  Log.Error ("Cannot open SQLite database: {0}", Msg);
                  raise ADO.Configs.Connection_Error with "Cannot open database: " & Msg;
               end;
            end if;

            Database := new Database_Connection;
            declare

               procedure Configure (Name : in String;
                                    Item : in Util.Properties.Value);
               function Escape (Value : in Util.Properties.Value) return String;

               function Escape (Value : in Util.Properties.Value) return String is
                  S : constant String := Util.Properties.To_String (Value);
               begin
                  if S'Length > 0 and then S (S'First) >= '0' and then S (S'First) <= '9' then
                     return S;
                  elsif S'Length > 0 and then S (S'First) = ''' then
                     return S;
                  else
                     return "'" & S & "'";
                  end if;
               end Escape;

               procedure Configure (Name : in String;
                                    Item : in Util.Properties.Value) is
                  SQL : constant String := "PRAGMA " & Name & "=" & Escape (Item);
               begin
                  if Util.Strings.Index (Name, '.') = 0 then
                     Log.Info ("Configure database with {0}", SQL);
                     ADO.Statements.Sqlite.Execute (Database.Server, SQL);
                  end if;

               exception
                  when SQL_Error =>
                     null;
               end Configure;

            begin
               Database.Server := Handle;
               Database.Name   := To_Unbounded_String (Config.Get_Database);
               Database.URI    := To_Unbounded_String (URI);
               Result := Ref.Create (Database.all'Access);

               DB.Server := Handle;
               DB.Name := Database.Name;
               DB.URI := Database.URI;
               Database_List.Prepend (Container => List, New_Item => DB);

               --  Configure the connection by setting up the SQLite 'pragma X=Y' SQL commands.
               --  Typical configuration includes:
               --    synchronous=OFF
               --    temp_store=MEMORY
               --    encoding='UTF-8'
               Config.Iterate (Process => Configure'Access);
            end;
         end;
      end Open;

      procedure Clear is
         DB     : SQLite_Database;
         Result : int;
      begin
         while not Database_List.Is_Empty (List) loop
            DB := Database_List.First_Element (List);
            Database_List.Delete_First (List);
            if DB.Server /= null then
               Result := Sqlite3_H.sqlite3_close_v2 (DB.Server);
               if Result /= Sqlite3_H.SQLITE_OK then
                  declare
                     Error : constant Strings.chars_ptr := Sqlite3_H.sqlite3_errstr (Result);
                     Msg   : constant String := Strings.Value (Error);
                  begin
                     Log.Error ("Cannot close database {0}: {1}", To_String (DB.Name), Msg);
                  end;
               end if;
            end if;
         end loop;
      end Clear;

   end Sqlite_Connections;

   --  ------------------------------
   --  Initialize the database connection manager.
   --  ------------------------------
   procedure Create_Connection (D      : in out Sqlite_Driver;
                                Config : in Configuration'Class;
                                Result : in out Ref.Ref'Class) is
   begin
      D.Map.Open (Config, Result);
   end Create_Connection;

   --  ------------------------------
   --  Create the database and initialize it with the schema SQL file.
   --  The `Admin` parameter describes the database connection with administrator access.
   --  The `Config` parameter describes the target database connection.
   --  ------------------------------
   overriding
   procedure Create_Database (D           : in out Sqlite_Driver;
                              Admin       : in Configs.Configuration'Class;
                              Config      : in Configs.Configuration'Class;
                              Schema_Path : in String;
                              Messages    : out Util.Strings.Vectors.Vector) is
      pragma Unreferenced (D, Admin);

      Status        : Integer;
      Database_Path : constant String := Config.Get_Database;
      Command       : constant String :=
        "sqlite3 --batch --init " & Schema_Path & " " & Database_Path;
   begin
      Log.Info ("Creating SQLite database {0}", Database_Path);
      Util.Processes.Tools.Execute (Command, Messages, Status);

      if Status = 0 then
         Log.Info ("Database schema created successfully.");
      elsif Status = 255 then
         Messages.Append ("Command not found: " & Command);
         Log.Error ("Command not found: {0}", Command);
      else
         Messages.Append ("Command " & Command & " failed with exit code "
                            & Util.Strings.Image (Status));
         Log.Error ("Command {0} failed with exit code {1}", Command,
                    Util.Strings.Image (Status));
      end if;
   end Create_Database;

   --  ------------------------------
   --  Initialize the SQLite driver.
   --  ------------------------------
   procedure Initialize is
      use type Util.Strings.Name_Access;
   begin
      Log.Debug ("Initializing sqlite driver");

      if Driver.Name = null then
         Driver.Name := Driver_Name'Access;
         Register (Driver'Access);
      end if;
   end Initialize;

   --  ------------------------------
   --  Deletes the SQLite driver.
   --  ------------------------------
   overriding
   procedure Finalize (D : in out Sqlite_Driver) is
   begin
      Log.Debug ("Deleting the sqlite driver");
      D.Map.Clear;
   end Finalize;

end ADO.Drivers.Connections.Sqlite;

Change the database management better follow previous version behaviors - Remove the Finalize on the Database_Connection - Move the database close in protected Clear operation - Update protected Open operation to use the SQLite_Database record


------------------------------------------------------------------------------
-- Copyright (c) 2014, 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.Caches;
with Natools.S_Expressions.Lockable;
with Natools.S_Expressions.Interpreter_Loop;
with Natools.Static_Maps.Web.Error_Pages;

package body Natools.Web.Error_Pages is

   procedure Append
     (Exchange : in out Sites.Exchange;
      Context : in Error_Context;
      Data : in S_Expressions.Atom);

   procedure Default_Page
     (Exchange : in out Sites.Exchange;
      Context : in Error_Context);

   procedure Execute
     (Exchange : in out Sites.Exchange;
      Context : in Error_Context;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   -------------------------
   -- Error Page Renderer --
   -------------------------

   procedure Append
     (Exchange : in out Sites.Exchange;
      Context : in Error_Context;
      Data : in S_Expressions.Atom)
   is
      pragma Unreferenced (Context);
   begin
      Exchange.Append (Data);
   end Append;

   procedure Default_Page
     (Exchange : in out Sites.Exchange;
      Context : in Error_Context)
   is
   begin
      Exchange.Append (S_Expressions.To_Atom ("<title>Error "));
      Exchange.Append (Context.Code);
      Exchange.Append
        (S_Expressions.To_Atom ("</title>
Error "));
      Exchange.Append (Context.Code);
      Exchange.Append (S_Expressions.To_Atom ("

"));
      Exchange.Append
        (S_Expressions.To_Atom
           (Natools.Static_Maps.Web.Error_Pages.To_Message
              (S_Expressions.To_String (Context.Code))));
      Exchange.Append (S_Expressions.To_Atom ("
"));
   end Default_Page;

   procedure Execute
     (Exchange : in out Sites.Exchange;
      Context : in Error_Context;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Arguments);
      use Natools.Static_Maps.Web.Error_Pages;
   begin
      case To_Command (S_Expressions.To_String (Name)) is
         when Unknown_Command =>
            null;

         when Location =>
            if not Context.Location.Is_Empty then
               Exchange.Append (Context.Location.Query);
            end if;

         when Message =>
            Exchange.Append
              (S_Expressions.To_Atom (To_Message
                 (S_Expressions.To_String (Context.Code))));

         when Path =>
            Exchange.Append
              (S_Expressions.To_Atom (Exchanges.Path (Exchange)));

         when Status_Code =>
            Exchange.Append (Context.Code);
      end case;
   end Execute;

   procedure Render is new S_Expressions.Interpreter_Loop
     (Sites.Exchange, Error_Context, Execute, Append);

   -----------------------
   -- Private Interface --
   -----------------------

   procedure Main_Render
     (Exchange : in out Sites.Exchange;
      Context : in Error_Context)
   is
      use type S_Expressions.Atom;
      Template : S_Expressions.Caches.Cursor;
      Found : Boolean;
   begin
      Exchange.Site.Get_Template
        (S_Expressions.To_Atom ("error-page-") & Context.Code,
         Template,
         Found);

      if not Found then
         Exchange.Site.Get_Template
           (S_Expressions.To_Atom ("error-page"),
            Template,
            Found);

         if not Found then
            Default_Page (Exchange, Context);
            return;
         end if;
      end if;

      Render (Template, Exchange, Context);
   end Main_Render;

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

   procedure Check_Method
     (Exchange : in out Sites.Exchange;
      Allowed_Set : in Exchanges.Method_Set;
      Allowed : out Boolean) is
   begin
      Allowed := Exchanges.Is_In (Exchanges.Method (Exchange), Allowed_Set);

      if not Allowed then
         Method_Not_Allowed (Exchange, Allowed_Set);
      end if;
   end Check_Method;

   procedure Check_Method
     (Exchange : in out Sites.Exchange;
      Allowed_Methods : in Exchanges.Method_Array;
      Allowed : out Boolean) is
   begin
      Check_Method (Exchange, Exchanges.To_Set (Allowed_Methods), Allowed);
   end Check_Method;

   procedure Check_Method
     (Exchange : in out Sites.Exchange;
      Allowed_Method : in Exchanges.Known_Method;
      Allowed : out Boolean) is
   begin
      Check_Method (Exchange, (1 => Allowed_Method), Allowed);
   end Check_Method;

   procedure Method_Not_Allowed
     (Exchange : in out Sites.Exchange;
      Allow : in Exchanges.Method_Set)
   is
      Context : constant Error_Context
        := (Code => S_Expressions.To_Atom ("405"),
            Location => <>);
   begin
      Exchanges.Method_Not_Allowed (Exchange, Allow);
      Main_Render (Exchange, Context);
   end Method_Not_Allowed;

   procedure Not_Found (Exchange : in out Sites.Exchange) is
      Context : constant Error_Context
        := (Code => S_Expressions.To_Atom ("404"),
            Location => <>);
   begin
      Exchanges.Not_Found (Exchange);
      Main_Render (Exchange, Context);
   end Not_Found;

   procedure Permanent_Redirect
     (Exchange : in out Sites.Exchange;
      Location : in S_Expressions.Atom)
   is
      Context : constant Error_Context
        := (Code => S_Expressions.To_Atom ("301"),
            Location => S_Expressions.Atom_Ref_Constructors.Create (Location));
   begin
      Exchange.Permanent_Redirect (Context.Location);
      Main_Render (Exchange, Context);
   end Permanent_Redirect;

   procedure See_Other
     (Exchange : in out Sites.Exchange;
      Location : in S_Expressions.Atom)
   is
      Context : constant Error_Context
        := (Code => S_Expressions.To_Atom ("303"),
            Location => S_Expressions.Atom_Ref_Constructors.Create (Location));
   begin
      Exchange.See_Other (Context.Location);
      Main_Render (Exchange, Context);
   end See_Other;

end Natools.Web.Error_Pages;

------------------------------------------------------------------------------
-- Copyright (c) 2014-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 Natools.S_Expressions.Atom_Ref_Constructors;
with Natools.S_Expressions.Caches;
with Natools.S_Expressions.Lockable;
with Natools.S_Expressions.Interpreter_Loop;
with Natools.Static_Maps.Web.Error_Pages;
with Natools.Web.Fallback_Render;

package body Natools.Web.Error_Pages is

   procedure Append
     (Exchange : in out Sites.Exchange;
      Context : in Error_Context;
      Data : in S_Expressions.Atom);

   procedure Default_Page
     (Exchange : in out Sites.Exchange;
      Context : in Error_Context);

   procedure Execute
     (Exchange : in out Sites.Exchange;
      Context : in Error_Context;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   procedure Render is new S_Expressions.Interpreter_Loop
     (Sites.Exchange, Error_Context, Execute, Append);

   -------------------------
   -- Error Page Renderer --
   -------------------------

   procedure Append
     (Exchange : in out Sites.Exchange;
      Context : in Error_Context;
      Data : in S_Expressions.Atom)
   is
      pragma Unreferenced (Context);
   begin
      Exchange.Append (Data);
   end Append;

   procedure Default_Page
     (Exchange : in out Sites.Exchange;
      Context : in Error_Context)
   is
   begin
      Exchange.Append (S_Expressions.To_Atom ("<title>Error "));
      Exchange.Append (Context.Code);
      Exchange.Append
        (S_Expressions.To_Atom ("</title>
Error "));
      Exchange.Append (Context.Code);
      Exchange.Append (S_Expressions.To_Atom ("

"));
      Exchange.Append
        (S_Expressions.To_Atom
           (Natools.Static_Maps.Web.Error_Pages.To_Message
              (S_Expressions.To_String (Context.Code))));
      Exchange.Append (S_Expressions.To_Atom ("
"));
   end Default_Page;

   procedure Execute
     (Exchange : in out Sites.Exchange;
      Context : in Error_Context;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      procedure Re_Enter
        (Exchange : in out Sites.Exchange;
         Expression : in out S_Expressions.Lockable.Descriptor'Class);

      procedure Re_Enter
        (Exchange : in out Sites.Exchange;
         Expression : in out S_Expressions.Lockable.Descriptor'Class) is
      begin
         Render (Expression, Exchange, Context);
      end Re_Enter;

      use Natools.Static_Maps.Web.Error_Pages;
   begin
      case To_Command (S_Expressions.To_String (Name)) is
         when Unknown_Command =>
            Fallback_Render
              (Exchange, Name, Arguments,
               "error page", Re_Enter'Access);

         when Location =>
            if not Context.Location.Is_Empty then
               Exchange.Append (Context.Location.Query);
            end if;

         when Message =>
            Exchange.Append
              (S_Expressions.To_Atom (To_Message
                 (S_Expressions.To_String (Context.Code))));

         when Path =>
            Exchange.Append
              (S_Expressions.To_Atom (Exchanges.Path (Exchange)));

         when Status_Code =>
            Exchange.Append (Context.Code);
      end case;
   end Execute;

   -----------------------
   -- Private Interface --
   -----------------------

   procedure Main_Render
     (Exchange : in out Sites.Exchange;
      Context : in Error_Context)
   is
      use type S_Expressions.Atom;
      Template : S_Expressions.Caches.Cursor;
      Found : Boolean;
   begin
      Exchange.Site.Get_Template
        (S_Expressions.To_Atom ("error-page-") & Context.Code,
         Template,
         Found);

      if not Found then
         Exchange.Site.Get_Template
           (S_Expressions.To_Atom ("error-page"),
            Template,
            Found);

         if not Found then
            Default_Page (Exchange, Context);
            return;
         end if;
      end if;

      Render (Template, Exchange, Context);
   end Main_Render;

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

   procedure Check_Method
     (Exchange : in out Sites.Exchange;
      Allowed_Set : in Exchanges.Method_Set;
      Allowed : out Boolean) is
   begin
      Allowed := Exchanges.Is_In (Exchanges.Method (Exchange), Allowed_Set);

      if not Allowed then
         Method_Not_Allowed (Exchange, Allowed_Set);
      end if;
   end Check_Method;

   procedure Check_Method
     (Exchange : in out Sites.Exchange;
      Allowed_Methods : in Exchanges.Method_Array;
      Allowed : out Boolean) is
   begin
      Check_Method (Exchange, Exchanges.To_Set (Allowed_Methods), Allowed);
   end Check_Method;

   procedure Check_Method
     (Exchange : in out Sites.Exchange;
      Allowed_Method : in Exchanges.Known_Method;
      Allowed : out Boolean) is
   begin
      Check_Method (Exchange, (1 => Allowed_Method), Allowed);
   end Check_Method;

   procedure Method_Not_Allowed
     (Exchange : in out Sites.Exchange;
      Allow : in Exchanges.Method_Set)
   is
      Context : constant Error_Context
        := (Code => S_Expressions.To_Atom ("405"),
            Location => <>);
   begin
      Exchanges.Method_Not_Allowed (Exchange, Allow);
      Main_Render (Exchange, Context);
   end Method_Not_Allowed;

   procedure Not_Found (Exchange : in out Sites.Exchange) is
      Context : constant Error_Context
        := (Code => S_Expressions.To_Atom ("404"),
            Location => <>);
   begin
      Exchanges.Not_Found (Exchange);
      Main_Render (Exchange, Context);
   end Not_Found;

   procedure Permanent_Redirect
     (Exchange : in out Sites.Exchange;
      Location : in S_Expressions.Atom)
   is
      Context : constant Error_Context
        := (Code => S_Expressions.To_Atom ("301"),
            Location => S_Expressions.Atom_Ref_Constructors.Create (Location));
   begin
      Exchange.Permanent_Redirect (Context.Location);
      Main_Render (Exchange, Context);
   end Permanent_Redirect;

   procedure See_Other
     (Exchange : in out Sites.Exchange;
      Location : in S_Expressions.Atom)
   is
      Context : constant Error_Context
        := (Code => S_Expressions.To_Atom ("303"),
            Location => S_Expressions.Atom_Ref_Constructors.Create (Location));
   begin
      Exchange.See_Other (Context.Location);
      Main_Render (Exchange, Context);
   end See_Other;

end Natools.Web.Error_Pages;

error_pages: use the new fallback render procedure to provide common commands


-----------------------------------------------------------------------
--  security-policies-roles -- Role based policies
--  Copyright (C) 2010, 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.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--  In this policy, users are assigned one or several roles and permissions are
--  associated with roles.  A permission is granted if the user has one of the roles required
--  by the permission.
--
--  === Policy creation ===
--  An instance of the <tt>Role_Policy</tt> must be created and registered in the policy manager.
--  Get or declare the following variables:
--
--    Manager : Security.Policies.Policy_Manager;
--    Policy  : Security.Policies.Roles.Role_Policy_Access;
--
--  Create the role policy and register it in the policy manager as follows:
--
--    Policy := new Role_Policy;
--    Manager.Add_Policy (Policy.all'Access);
--
--  === Policy Configuration ===
--  A role is represented by a name in security configuration files.  A role based permission
--  is associated with a list of roles.  The permission is granted if the user has one of these
--  roles.  When the role based policy is registered in the policy manager, the following
--  XML configuration is used:
--
--    <security-role>
--      <role-name>admin</role-name>
--    </security-role>
--    <security-role>
--      <role-name>manager</role-name>
--    </security-role>
--    <role-permission>
--      <name>create-workspace</name>
--      <role>admin</role>
--      <role>manager</role>
--    </role-permission>
--
--  This definition declares two roles: <tt>admin</tt> and <tt>manager</tt>
--  It defines a permission create-workspace that will be granted if the
--  user has either the admin or the manager role.
--
--  Each role is identified by a name in the configuration file.  It is represented by
--  a <tt>Role_Type</tt>.  To provide an efficient implementation, the <tt>Role_Type</tt>
--  is represented as an integer with a limit of 64 different roles.
--
--  === Assigning roles to users ===
--  A <tt>Security_Context</tt> must be associated with a set of roles before checking the
--  permission.  This is done by using the <tt>Set_Role_Context</tt> operation:
--
--     Security.Policies.Roles.Set_Role_Context (Security.Contexts.Current, "admin");
--
package Security.Policies.Roles is

   NAME : constant String := "Role-Policy";

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  ------------------------------
   --  Role principal context
   --  ------------------------------
   --  The <tt>Role_Principal_Context</tt> interface must be implemented by the user
   --  <tt>Principal</tt> to be able to use the role based policy.   The role based policy
   --  controller will first check that the <tt>Principal</tt> implements that interface.
   --  It uses the <tt>Get_Roles</tt> function to get the current roles assigned to the user.
   type Role_Principal_Context is limited interface;
   function Get_Roles (User : in Role_Principal_Context) return Role_Map is abstract;

   --  ------------------------------
   --  Policy context
   --  ------------------------------
   --  The Role_Policy_Context gives security context information that the role
   --  based policy can use to verify the permission.
   type Role_Policy_Context is new Policy_Context with record
      Roles : Role_Map;
   end record;
   type Role_Policy_Context_Access is access all Role_Policy_Context'Class;

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map);

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

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

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Set the roles specified in the <tt>Roles</tt> parameter.  Each role is represented by
   --  its name and multiple roles are separated by ','.
   --  Raises Invalid_Name if a role was not found.
   procedure Set_Roles (Manager : in Role_Policy;
                        Roles   : in String;
                        Into    : out Role_Map);

   --  Setup the XML parser to read the role-permission description.
   overriding
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser);

   --  Finalize the policy manager.
   overriding
   procedure Finalize (Policy : in out Role_Policy);

   --  Get the role policy associated with the given policy manager.
   --  Returns the role policy instance or null if it was not registered in the policy manager.
   function Get_Role_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                             return Role_Policy_Access;

private

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names        : Role_Name_Array;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Role_Type_Array (1 .. Integer (Role_Type'Last));
      Count   : Natural := 0;
      Manager : Role_Policy_Access;
   end record;

end Security.Policies.Roles;

-----------------------------------------------------------------------
--  security-policies-roles -- Role based policies
--  Copyright (C) 2010, 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.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--  In this policy, users are assigned one or several roles and permissions are
--  associated with roles.  A permission is granted if the user has one of the roles required
--  by the permission.
--
--  === Policy creation ===
--  An instance of the <tt>Role_Policy</tt> must be created and registered in the policy manager.
--  Get or declare the following variables:
--
--    Manager : Security.Policies.Policy_Manager;
--    Policy  : Security.Policies.Roles.Role_Policy_Access;
--
--  Create the role policy and register it in the policy manager as follows:
--
--    Policy := new Role_Policy;
--    Manager.Add_Policy (Policy.all'Access);
--
--  === Policy Configuration ===
--  A role is represented by a name in security configuration files.  A role based permission
--  is associated with a list of roles.  The permission is granted if the user has one of these
--  roles.  When the role based policy is registered in the policy manager, the following
--  XML configuration is used:
--
--    <policy-rules>
--      <security-role>
--        <role-name>admin</role-name>
--      </security-role>
--      <security-role>
--        <role-name>manager</role-name>
--      </security-role>
--      <role-permission>
--        <name>create-workspace</name>
--        <role>admin</role>
--        <role>manager</role>
--      </role-permission>
--      ...
--    </policy-rules>
--
--  This definition declares two roles: <tt>admin</tt> and <tt>manager</tt>
--  It defines a permission create-workspace that will be granted if the
--  user has either the admin or the manager role.
--
--  Each role is identified by a name in the configuration file.  It is represented by
--  a <tt>Role_Type</tt>.  To provide an efficient implementation, the <tt>Role_Type</tt>
--  is represented as an integer with a limit of 64 different roles.
--
--  === Assigning roles to users ===
--  A <tt>Security_Context</tt> must be associated with a set of roles before checking the
--  permission.  This is done by using the <tt>Set_Role_Context</tt> operation:
--
--     Security.Policies.Roles.Set_Role_Context (Security.Contexts.Current, "admin");
--
package Security.Policies.Roles is

   NAME : constant String := "Role-Policy";

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  ------------------------------
   --  Role principal context
   --  ------------------------------
   --  The <tt>Role_Principal_Context</tt> interface must be implemented by the user
   --  <tt>Principal</tt> to be able to use the role based policy.   The role based policy
   --  controller will first check that the <tt>Principal</tt> implements that interface.
   --  It uses the <tt>Get_Roles</tt> function to get the current roles assigned to the user.
   type Role_Principal_Context is limited interface;
   function Get_Roles (User : in Role_Principal_Context) return Role_Map is abstract;

   --  ------------------------------
   --  Policy context
   --  ------------------------------
   --  The Role_Policy_Context gives security context information that the role
   --  based policy can use to verify the permission.
   type Role_Policy_Context is new Policy_Context with record
      Roles : Role_Map;
   end record;
   type Role_Policy_Context_Access is access all Role_Policy_Context'Class;

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map);

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

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

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Set the roles specified in the <tt>Roles</tt> parameter.  Each role is represented by
   --  its name and multiple roles are separated by ','.
   --  Raises Invalid_Name if a role was not found.
   procedure Set_Roles (Manager : in Role_Policy;
                        Roles   : in String;
                        Into    : out Role_Map);

   --  Setup the XML parser to read the role-permission description.
   overriding
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser);

   --  Finalize the policy manager.
   overriding
   procedure Finalize (Policy : in out Role_Policy);

   --  Get the role policy associated with the given policy manager.
   --  Returns the role policy instance or null if it was not registered in the policy manager.
   function Get_Role_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                             return Role_Policy_Access;

private

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names        : Role_Name_Array;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Role_Type_Array (1 .. Integer (Role_Type'Last));
      Count   : Natural := 0;
      Manager : Role_Policy_Access;
   end record;

end Security.Policies.Roles;

Fix the XML documentation

Fix the XML documentation