------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--       A S I S . D A T A _ D E C O M P O S I T I O N . S E T _ G E T      --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (c) 1995-2005, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU General Public License  distributed with ASIS-for-GNAT; see file     --
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

--  This package contains access and update routines for abstractions
--  declared in Asis.Data_Decomposition.
--
--  It also contains routines for creating lists of record and array
--  components

with A4G.Asis_Tables; use A4G.Asis_Tables;
with A4G.DDA_Aux;     use A4G.DDA_Aux;

with Table;

private package Asis.Data_Decomposition.Set_Get is

   --  Tables used to create query results which are of list types:

   package Record_Component_Table is new Table.Table (
     Table_Component_Type => Record_Component,
     Table_Index_Type     => Asis.ASIS_Natural,
     Table_Low_Bound      => 1,
     Table_Initial        => 10,
     Table_Increment      => 100,
     Table_Name           => "Record_Componnet_List");

   RC_Table : Record_Component_Table.Table_Ptr renames
      Record_Component_Table.Table;

   Def_N_Table : Asis_Element_Table.Table_Ptr renames
      Asis_Element_Table.Table;

   Nil_Record_Component_List : Record_Component_List (1 .. 0);
   --  Nil constant for Record_Component_List is not provided in the
   --  Asis.Data_Decomposition package.

   Parent_Type_Definition : Element;
   --  Global variable used to store the type definition from which componnets
   --  are extracted

   Record_Type_Entity : Entity_Id;
   --  Global variable used to store the type entity defining the type of
   --  a record. This is a type entity which actually defines the
   --  type, that is, it may be an implicit type as well

   procedure Set_Parent_Type_Definition (E : Element);
   --  Sets Parent_Type_Definition (Currently this is a trivial assignment,
   --  but we would better keep procedural interface in case if something
   --  more smart is really required here.

   procedure Set_Record_Type_Entity (RC : Record_Component);
   --  Sets Record_Type_Entity for RC, if Is_Record (RC)

   procedure Set_Record_Type_Entity (AC : Array_Component);
   --  Sets Record_Type_Entity for AC, if Is_Record (AC)

   procedure Set_Record_Type_Entity;
   --  Sets Record_Type_Entity by using the valuse of Parent_Type_Definition
   --  global variable

   --  Access functions to Record_Component fields:

   subtype RC is Record_Component;

   function Parent_Record_Type (Comp : RC) return Asis.Declaration;
   function Component_Name     (Comp : RC) return Asis.Defining_Name;
   function Is_Record_Comp     (Comp : RC) return Boolean;
   function Is_Array_Comp      (Comp : RC) return Boolean;
   function Parent_Discrims    (Comp : RC) return Discrim_List;

   function Get_Type_Entity    (Comp : RC) return Entity_Id;
   --  Returns type Entity describing the subtype of the component.
   --  It may be implicit type as well

   function Get_Comp_Entity (Comp : RC) return Entity_Id;
   --  Returns the Entity Id of the given record component

   function Get_Record_Entity (Comp : RC) return Entity_Id;
   --  Returns the Entity Id of the enclosing record type declaration
   --  for a given component (it may be a type derived from a record type)

   --  Array Components:

   subtype AC is Array_Component;

   function Parent_Array_Type     (Comp : AC) return Asis.Declaration;
   function Is_Record_Comp        (Comp : AC) return Boolean;
   function Is_Array_Comp         (Comp : AC) return Boolean;
   function Dimension             (Comp : AC) return ASIS_Natural;
   function Parent_Discrims       (Comp : AC) return Discrim_List;

   function Get_Array_Type_Entity (Comp : AC) return  Entity_Id;
   --  Returns the Entity_Id for the array type from which this array
   --  component is extracted. It may be the Id of some implicit array type
   --  as well

   procedure Set_Parent_Discrims (Comp : in out AC; Discs : Discrim_List);
   --  Sets Discs as Parent_Discrims for Comp. In case if Discs is
   --  Null_Discrims sets Parent_Discrims as null.

   type List_Kinds is (New_List, Append);
   --  The way of creating a list in Element or Component Table

   procedure Set_Named_Components (E : Element; List_Kind : List_Kinds);
   --  Stores all the A_Defining_Identifier components contained in E in
   --  Asis_Element_Table. If List_Kind is set to New_List, it resets
   --  Asis_Element_Table before putting any information in it. If List_Kind
   --  is set to Append, the Table is not reset, and the created list
   --  is appended to the list already stored in the table.

   procedure Set_All_Named_Components (E : Element);
   --  Provided that E is a record type definition or a definition of a
   --  derived type derived from some record type, this function
   --  stores all the A_Defining_Identifier Elements defining the
   --  componnets for this type in Asis_Element_Table. Before doing this,
   --  the procedure resets Asis_Element_Table.

   procedure Set_Record_Components_From_Names
     (Parent_First_Bit : ASIS_Natural  := 0;
      Data_Stream      : Portable_Data := Nil_Portable_Data;
      Discriminants    : Boolean       := False);
   --  Supposing that an appropriate list of component defining names is set
   --  in the Asis_Element_Table, this procedure converts them into
   --  the corresponding list of record componnets in Record_Component_Table.
   --
   --  Parent_First_Bit is needed to compute the first bit and position of
   --  the component that is extracted from another (record or array)
   --  component. Usually everything is alligned at least bytewise, but in case
   --  if representation clauses are used to create heavily packed data
   --  structure, we may need to know where to start to compute the component
   --  beginning
   --
   --  If Data_Stream parameter is set, it is used to define which
   --  components from the list set in Asis_Element_Table should be
   --  presented in the result.
   --
   --  Discriminants flag is used to indicate the case when (only)
   --  discriminant components should be constructed, in this case no
   --  discriminant constraint (explicit or default) should be taken into
   --  account (they may be dynamic in case of A_Complex_Dynamic_Model type).

   function Set_Array_Componnet
     (Array_Type_Definition      : Element;
      Enclosing_Record_Component : Record_Component := Nil_Record_Component;
      Parent_Indication          : Element          := Nil_Element;
      Parent_Discriminants       : Discrim_List     := Null_Discrims;
      Parent_First_Bit_Offset    : ASIS_Natural     := 0;
      Dynamic_Array              : Boolean          := False)
      return Array_Component;
   --  Sets and returns an Array_Component value. Array_Type_Definition
   --  parameter should represent a (constrained or unconstrained) array type
   --  definition or a derived type definition for which an ancestor type is
   --  an array type. The returned value represent the component of this array
   --  type. Enclosing_Record_Component is set when the array componnet to be
   --  created is a part of some Record_Component, in this case the
   --  corresponding component definition may contain index constraints.
   --  Parent_Indication is set when the array componnet to be created is a
   --  part of some other array component, in this case the corresponding
   --  component subtype indication may contain an index constraint
   --  ???? Documentation needs revising!!!

end Asis.Data_Decomposition.Set_Get;

Add the ASIS file $i

Add the ASIS file $i


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

with Util.Tests;

package Babel.Streams.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   --  Test the Find function resolving some existing user.
   procedure Test_Stream_Composition (T : in out Test);

end Babel.Streams.Tests;

Add a unit test for the babel stream compositions


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

package Gen.Tests.Packages is

end Gen.Tests.Packages;

Add the package to build the generated Ada packages (UML packages test)


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

   use Interfaces;

   type Byte_Table is array (Interfaces.Unsigned_8 range 0 .. 255) of Interfaces.Unsigned_8;

   type Parity_Table is array (Ada.Streams.Stream_Element) of Interfaces.Unsigned_8;

   Parity : constant Parity_Table
     := (16#FF#, 16#D4#, 16#D2#, 16#F9#, 16#CC#, 16#E7#, 16#E1#, 16#CA#,
         16#CA#, 16#E1#, 16#E7#, 16#CC#, 16#F9#, 16#D2#, 16#D4#, 16#FF#,
         16#B4#, 16#9F#, 16#99#, 16#B2#, 16#87#, 16#AC#, 16#AA#, 16#81#,
         16#81#, 16#AA#, 16#AC#, 16#87#, 16#B2#, 16#99#, 16#9F#, 16#B4#,
         16#B2#, 16#99#, 16#9F#, 16#B4#, 16#81#, 16#AA#, 16#AC#, 16#87#,
         16#87#, 16#AC#, 16#AA#, 16#81#, 16#B4#, 16#9F#, 16#99#, 16#B2#,
         16#F9#, 16#D2#, 16#D4#, 16#FF#, 16#CA#, 16#E1#, 16#E7#, 16#CC#,
         16#CC#, 16#E7#, 16#E1#, 16#CA#, 16#FF#, 16#D4#, 16#D2#, 16#F9#,
         16#AC#, 16#87#, 16#81#, 16#AA#, 16#9F#, 16#B4#, 16#B2#, 16#99#,
         16#99#, 16#B2#, 16#B4#, 16#9F#, 16#AA#, 16#81#, 16#87#, 16#AC#,
         16#E7#, 16#CC#, 16#CA#, 16#E1#, 16#D4#, 16#FF#, 16#F9#, 16#D2#,
         16#D2#, 16#F9#, 16#FF#, 16#D4#, 16#E1#, 16#CA#, 16#CC#, 16#E7#,
         16#E1#, 16#CA#, 16#CC#, 16#E7#, 16#D2#, 16#F9#, 16#FF#, 16#D4#,
         16#D4#, 16#FF#, 16#F9#, 16#D2#, 16#E7#, 16#CC#, 16#CA#, 16#E1#,
         16#AA#, 16#81#, 16#87#, 16#AC#, 16#99#, 16#B2#, 16#B4#, 16#9F#,
         16#9F#, 16#B4#, 16#B2#, 16#99#, 16#AC#, 16#87#, 16#81#, 16#AA#,
         16#AA#, 16#81#, 16#87#, 16#AC#, 16#99#, 16#B2#, 16#B4#, 16#9F#,
         16#9F#, 16#B4#, 16#B2#, 16#99#, 16#AC#, 16#87#, 16#81#, 16#AA#,
         16#E1#, 16#CA#, 16#CC#, 16#E7#, 16#D2#, 16#F9#, 16#FF#, 16#D4#,
         16#D4#, 16#FF#, 16#F9#, 16#D2#, 16#E7#, 16#CC#, 16#CA#, 16#E1#,
         16#E7#, 16#CC#, 16#CA#, 16#E1#, 16#D4#, 16#FF#, 16#F9#, 16#D2#,
         16#D2#, 16#F9#, 16#FF#, 16#D4#, 16#E1#, 16#CA#, 16#CC#, 16#E7#,
         16#AC#, 16#87#, 16#81#, 16#AA#, 16#9F#, 16#B4#, 16#B2#, 16#99#,
         16#99#, 16#B2#, 16#B4#, 16#9F#, 16#AA#, 16#81#, 16#87#, 16#AC#,
         16#F9#, 16#D2#, 16#D4#, 16#FF#, 16#CA#, 16#E1#, 16#E7#, 16#CC#,
         16#CC#, 16#E7#, 16#E1#, 16#CA#, 16#FF#, 16#D4#, 16#D2#, 16#F9#,
         16#B2#, 16#99#, 16#9F#, 16#B4#, 16#81#, 16#AA#, 16#AC#, 16#87#,
         16#87#, 16#AC#, 16#AA#, 16#81#, 16#B4#, 16#9F#, 16#99#, 16#B2#,
         16#B4#, 16#9F#, 16#99#, 16#B2#, 16#87#, 16#AC#, 16#AA#, 16#81#,
         16#81#, 16#AA#, 16#AC#, 16#87#, 16#B2#, 16#99#, 16#9F#, 16#B4#,
         16#FF#, 16#D4#, 16#D2#, 16#F9#, 16#CC#, 16#E7#, 16#E1#, 16#CA#,
         16#CA#, 16#E1#, 16#E7#, 16#CC#, 16#F9#, 16#D2#, 16#D4#, 16#FF#);

   Bit_Count_Table : constant Byte_Table
     := (0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4,
         1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
         1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
         2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
         1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
         2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
         2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
         3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
         1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5,
         2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
         2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
         3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
         2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6,
         3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
         3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7,
         4, 5, 5, 6, 5, 6, 6, 7, 5, 6, 6, 7, 6, 7, 7, 8);

   function Count (Data : Ada.Streams.Stream_Element) return Natural;

   --  Make the 3 bytes ECC code that corresponds to the data array.
   procedure Make (Data : in Ada.Streams.Stream_Element_Array;
                   Code : out ECC_Code) is
      LP0, LP1, LP2, LP3, LP4, LP5, LP6, LP7       : Ada.Streams.Stream_Element := 0;
      LP8, LP9, LP10, LP11, LP12, LP13, LP14, LP15 : Ada.Streams.Stream_Element := 0;
      LP16, LP17 : Ada.Streams.Stream_Element := 0;
      I : Unsigned_16 := 0;
   begin
      for D of Data loop
         if (I and 16#01#) /= 0 then
            LP1 := LP1 xor D;
         else
            LP0 := LP0 xor D;
         end if;
         if (I and 16#02#) /= 0 then
            LP3 := LP3 xor D;
         else
            LP2 := LP2 xor D;
         end if;
         if (I and 16#04#) /= 0 then
            LP5 := LP5 xor D;
         else
            LP4 := LP4 xor D;
         end if;
         if (I and 16#08#) /= 0 then
            LP7 := LP7 xor D;
         else
            LP6 := LP6 xor D;
         end if;
         if (I and 16#10#) /= 0 then
            LP9 := LP9 xor D;
         else
            LP8 := LP8 xor D;
         end if;
         if (I and 16#20#) /= 0 then
            LP11 := LP11 xor D;
         else
            LP10 := LP10 xor D;
         end if;
         if (I and 16#40#) /= 0 then
            LP13 := LP13 xor D;
         else
            LP12 := LP12 xor D;
         end if;
         if (I and 16#80#) /= 0 then
            LP15 := LP15 xor D;
         else
            LP14 := LP14 xor D;
         end if;
         if Data'Length = 512 then
            if (I and 16#100#) /= 0 then
               LP17 := LP17 xor D;
            else
               LP16 := LP16 xor D;
            end if;
         end if;
         I := I + 1;
      end loop;
      Code (0) := Stream_Element ((Parity (LP0) and 16#01#)
                                  or Shift_Left (Parity (LP1) and 16#01#, 1)
                                  or Shift_Left (Parity (LP2) and 16#01#, 2)
                                  or Shift_Left (Parity (LP3) and 16#01#, 3)
                                  or Shift_Left (Parity (LP4) and 16#01#, 4)
                                  or Shift_Left (Parity (LP5) and 16#01#, 5)
                                  or Shift_Left (Parity (LP6) and 16#01#, 6)
                                  or Shift_Left (Parity (LP7) and 16#01#, 7));
      Code (1) := Stream_Element ((Parity (LP8) and 16#01#)
                                  or Shift_Left (Parity (LP9) and 16#01#, 1)
                                  or Shift_Left (Parity (LP10) and 16#01#, 2)
                                  or Shift_Left (Parity (LP11) and 16#01#, 3)
                                  or Shift_Left (Parity (LP12) and 16#01#, 4)
                                  or Shift_Left (Parity (LP13) and 16#01#, 5)
                                  or Shift_Left (Parity (LP14) and 16#01#, 6)
                                  or Shift_Left (Parity (LP15) and 16#01#, 7));

      Code (2) := Stream_Element (Shift_Left (Parity (LP15 xor LP14) and 16#fe#, 1)
                                  or Shift_Left (Parity (LP17) and 16#01#, 1)
                                  or (Parity (LP16) and 16#01#));
   end Make;

   function Count (Data : Ada.Streams.Stream_Element) return Natural is
   begin
      return Natural (Bit_Count_Table (Interfaces.Unsigned_8 (Data)));
   end Count;

   --  ------------------------------
   --  Check and correct the data array according to the expected ECC codes and current codes.
   --  At most one bit can be fixed and two error bits can be detected.
   --  ------------------------------
   function Correct (Data         : in out Ada.Streams.Stream_Element_Array;
                     Expect_Code  : in ECC_Code;
                     Current_Code : in ECC_Code) return ECC_Result is

      Check   : ECC_Code;
      Bits    : Natural;
      Bit_Pos : Natural;
      Pos     : Unsigned_16;
   begin
      Check (0) := Expect_Code (0) xor Current_Code (0);
      Check (1) := Expect_Code (1) xor Current_Code (1);
      Check (2) := Expect_Code (2) xor Current_Code (2);
      if (Check (0) or Check (1) or Check (2)) = 0 then
         return NO_ERROR;
      end if;
      Bits := Count (Check (0)) + Count (Check (1)) + Count (Check (2));
      if (Bits = 11 and Data'Length = 256) or (Bits = 12 and Data'Length = 512) then
         Bit_Pos := Natural ((Shift_Right (Unsigned_8 (Check (2)), 3) and 16#01#)
                             or (Shift_Right (Unsigned_8 (Check (2)), 4) and 16#02#)
                             or (Shift_Right (Unsigned_8 (Check (2)), 5) and 16#04#));
         Pos := ((Shift_Right (Unsigned_16 (Check (0)), 1) and 16#01#)
                 or (Shift_Right (Unsigned_16 (Check (0)), 2) and 16#02#)
                 or (Shift_Right (Unsigned_16 (Check (0)), 3) and 16#04#)
                 or (Shift_Right (Unsigned_16 (Check (0)), 4) and 16#08#)
                 or (Shift_Left (Unsigned_16 (Check (1)), 3) and 16#10#)
                 or (Shift_Left (Unsigned_16 (Check (1)), 2) and 16#20#)
                 or (Shift_Left (Unsigned_16 (Check (1)), 1) and 16#40#)
                 or (Unsigned_16 (Check (1)) and 16#80#));
         if Data'Length = 512 then
            Pos := Pos + (Shift_Left (Unsigned_16 (Check (2)), 7) and 16#100#);
         end if;
         Data (Stream_Element_Offset (Pos))
           := Data (Stream_Element_Offset (Pos))
           xor Stream_Element (Shift_Left (Unsigned_8 (1), Bit_Pos));
         return CORRECTABLE_ERROR;
      elsif Bits = 1 then
         return ECC_ERROR;
      else
         return UNCORRECTABLE_ERROR;
      end if;
   end Correct;

   --  ------------------------------
   --  Check and correct the data array according to the expected ECC codes and current codes.
   --  At most one bit can be fixed and two error bits can be detected.
   --  ------------------------------
   function Correct (Data        : in out Ada.Streams.Stream_Element_Array;
                     Expect_Code : in ECC_Code) return ECC_Result is
      Current_Code : ECC_Code;
   begin
      Make (Data, Current_Code);
      return Correct (Data, Expect_Code, Current_Code);
   end Correct;

end Util.Encoders.ECC;

Implement the Make, Correct operations for ECC


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

with Ada.Containers.Vectors;
package Util.Beans.Objects.Vectors is new
Ada.Containers.Vectors (Index_Type       => Natural,
                            Element_Type => Object);

Define a vectors of objects

Define a vectors of objects


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

   type Monitor_Array is array (1 .. MAX_MONITOR) of Monitor_Data;

   Monitors : Monitor_Array;

   --  Get values of the monitor.
   procedure Get_Values (D : in out Mon;
                         Req    : in out ASF.Rest.Request'Class;
                         Reply  : in out ASF.Rest.Response'Class;
                         Stream : in out ASF.Rest.Output_Stream'Class) is
      Id  : constant String := Req.Get_Path_Parameter (1);
      Pos : Positive;
   begin
      Pos := Positive'Value (Id);
      Monitors (Pos).Put (0);
      declare
         Values : constant Value_Array := Monitors (Pos).Get_Values;
      begin
         Stream.Start_Document;
         Stream.Start_Array ("values");
         for V of Values loop
            Stream.Write_Long_Entity ("value", Long_Long_Integer (V));
         end loop;
         Stream.End_Array ("values");
         Stream.End_Document;
      end;

   exception
      when others =>
         Reply.Set_Status (ASF.Responses.SC_NOT_FOUND);
   end Get_Values;

   --  PUT /mon/:id
   procedure Put_Value (D : in out Mon;
                        Req    : in out ASF.Rest.Request'Class;
                        Reply  : in out ASF.Rest.Response'Class;
                        Stream : in out ASF.Rest.Output_Stream'Class) is
      Id  : constant String := Req.Get_Path_Parameter (1);
      Pos : Positive;
      Val : Natural;
   begin
      Pos := Positive'Value (Id);
      begin
         Val := Natural'Value (Req.Get_Parameter ("value"));
         Monitors (Pos).Put (Val);

      exception
         when others =>
            Reply.Set_Status (ASF.Responses.SC_BAD_REQUEST);
      end;

   exception
      when others =>
         Reply.Set_Status (ASF.Responses.SC_NOT_FOUND);
   end Put_Value;

   protected body Monitor_Data is

      procedure Put (Value : in Natural) is
         use type Ada.Calendar.Time;

         Now : constant Ada.Calendar.Time := Ada.Calendar.Clock;
         Dt  : constant Duration := Now - Slot_Start;
         Cnt : Natural := Natural (Dt / Slot_Size);
      begin
         while Cnt > 0 loop
            Cnt := Cnt - 1;
            Pos := Pos + 1;
            if Pos > Values'Last then
               Pos := Values'First;
               Value_Count := Values'Length;
            elsif Value_Count < Values'Length then
               Value_Count := Value_Count + 1;
            end if;
         end loop;
         Values (Pos) := Value;
      end Put;

      procedure Put (Value : in Natural; Slot : in Natural) is
      begin
         null;
      end Put;

      function Get_Values return Value_Array is
         Result : Value_Array (1 .. Value_Count);
         Cnt    : Natural;
         N      : Natural;
      begin
         if Value_Count = Values'Length then
            Cnt := Values'Length - Pos + 1;
         else
            Cnt := 0;
         end if;
         if Cnt > 0 then
            Result (1 .. Cnt) := Values (Pos + 1 .. Pos + 1 + Cnt - 1);
            N := Cnt + 1;
         else
            N := 1;
         end if;
         if Value_Count = Values'Length then
            Cnt := Pos;
         else
            Cnt := Pos - 1;
         end if;
         if Cnt > 0 then
            Result (N .. N + Cnt - 1) := Values (1 .. Cnt);
         end if;
         return Result;
      end Get_Values;

   end Monitor_Data;

end Monitor;

Implement the monitor REST API

Implement the monitor REST API


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                           A 4 G . A _ D E B U G                          --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (c) 1995-2005, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU General Public License  distributed with ASIS-for-GNAT; see file     --
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

package body A4G.A_Debug is

   ---------------------------------
   -- Summary of Debug Flag Usage --
   ---------------------------------

   --  da   Generate messages when working with normalized associations
   --  db
   --  dc   Generate messages from Context Table during finalization
   --  dd   Dynamic allocation of tables messages generated
   --  de
   --  df
   --  dg
   --  dh
   --  di   Turns off including the Element location into its Debug_Image
   --  dj
   --  dk
   --  dl   Generate debug output when converting node lists into element lists
   --  dm
   --  dn   Generate messages for list allocation
   --  do   Generate messages when opening a Context
   --  dp
   --  dq
   --  dr
   --  ds   All the debug output related to the semantic queries
   --  dt   Generate messages when a tree file is read in
   --  du
   --  dv   Generate messages when checking the validity of ASIS abstractions
   --  dw
   --  dx   Generate debug messages from inside Asis.Text routines
   --  dy
   --  dz

   --  d1   Generate the debug output for tree fragments being traversed
   --  d2
   --  d3
   --  d4
   --  d5
   --  d6
   --  d7
   --  d8
   --  d9

   ----------------------------------------
   -- Documentation for ASIS Debug Flags --
   ----------------------------------------

   --  da   When a list of normalized ASIS association elements is created
   --       or a normalized association is further decomposed, messages
   --       representing some "control points" of this process are generated.
   --
   --  db
   --  dc   When ASIS implementation is finalized (by calling to
   --       A4G.Finalize), the content of the main
   --       Context Table and its subtables is outputted

   --  dd   Dynamic allocation of tables messages generated. Each time a
   --       table is reallocated, a line is output indicating the expansion.

   --  de
   --  df
   --  dg
   --  dh   In GNAT this flag generates a table at the end of a compilation
   --       showing how the hash table chains built by the Namet package are
   --       loaded. This is useful in ensuring that the hashing algorithm
   --       (in Namet.Hash) is working effectively with typical sets of
   --       program identifiers. In ASIS the corresponding feature is not
   --       implemented yet. The idea is to see if the hashing algorithm
   --       is working effectively with the typical set of normalized
   --       unit names

   --  di   Turns off including the Element location into its Debug_Image,
   --       this is helpful when Asis.Text queries do not work properly
   --       because of structural queries misfunction.

   --  dj
   --  dk
   --  dl   Generate debug output when converting node lists into element
   --       lists. For every tree node traversing during the list conversion
   --       some information about the node is outputted
   --  dm
   --  dn   Generate messages for list allocation. Each time a list header is
   --       allocated, a line of output is generated.

   --  do   Generate messages when opening a Context in
   --       "use pre-created trees" mode
   --  dp
   --  dq
   --  dr
   --  ds   Various debug messages related to the semantic queries
   --       implemented for now are generated

   --  dt   Generate messages when a tree file is read in during processing
   --       ASIS queries
   --  du
   --  dv   Generate messages when checking the validity of ASIS Elements,
   --       Compilation_Units, Contexts. The idea is to show, why a given
   --       ASIS abstraction is considered as being invalid

   --  dw
   --  dx   Generate debug messages from inside the routines involved in the
   --       implementation of Asis.Text
   --  dy
   --  dz

   --  d1   Generate the debug output for tree fragments being traversed
   --       when processing ASIS queries (usially - the subtrees rooted by
   --       argument's pr result's node
   --
   --  d2
   --  d3
   --  d4
   --  d5
   --  d6
   --  d7
   --  d8
   --  d9

   --------------------
   -- Set_Debug_Flag --
   --------------------

   procedure Set_Debug_Flag (C : Character; Val : Boolean := True) is
      subtype Dig is Character range '1' .. '9';
      subtype Let is Character range 'a' .. 'z';

   begin
      if C in Dig then
         case Dig (C) is
            when '1' => Debug_Flag_1 := Val;
            when '2' => Debug_Flag_2 := Val;
            when '3' => Debug_Flag_3 := Val;
            when '4' => Debug_Flag_4 := Val;
            when '5' => Debug_Flag_5 := Val;
            when '6' => Debug_Flag_6 := Val;
            when '7' => Debug_Flag_7 := Val;
            when '8' => Debug_Flag_8 := Val;
            when '9' => Debug_Flag_9 := Val;
         end case;

      else
         case Let (C) is
            when 'a' => Debug_Flag_A := Val;
            when 'b' => Debug_Flag_B := Val;
            when 'c' => Debug_Flag_C := Val;
            when 'd' => Debug_Flag_D := Val;
            when 'e' => Debug_Flag_E := Val;
            when 'f' => Debug_Flag_F := Val;
            when 'g' => Debug_Flag_G := Val;
            when 'h' => Debug_Flag_H := Val;
            when 'i' => Debug_Flag_I := Val;
            when 'j' => Debug_Flag_J := Val;
            when 'k' => Debug_Flag_K := Val;
            when 'l' => Debug_Flag_L := Val;
            when 'm' => Debug_Flag_M := Val;
            when 'n' => Debug_Flag_N := Val;
            when 'o' => Debug_Flag_O := Val;
            when 'p' => Debug_Flag_P := Val;
            when 'q' => Debug_Flag_Q := Val;
            when 'r' => Debug_Flag_R := Val;
            when 's' => Debug_Flag_S := Val;
            when 't' => Debug_Flag_T := Val;
            when 'u' => Debug_Flag_U := Val;
            when 'v' => Debug_Flag_V := Val;
            when 'w' => Debug_Flag_W := Val;
            when 'x' => Debug_Flag_X := Val;
            when 'y' => Debug_Flag_Y := Val;
            when 'z' => Debug_Flag_Z := Val;
         end case;
      end if;
   end Set_Debug_Flag;

   -------------
   -- Set_Off --
   -------------

   procedure Set_Off is
   begin
      Debug_Flag_1 := False;
      Debug_Flag_2 := False;
      Debug_Flag_3 := False;
      Debug_Flag_4 := False;
      Debug_Flag_5 := False;
      Debug_Flag_6 := False;
      Debug_Flag_7 := False;
      Debug_Flag_8 := False;
      Debug_Flag_9 := False;

      Debug_Flag_A := False;
      Debug_Flag_B := False;
      Debug_Flag_C := False;
      Debug_Flag_D := False;
      Debug_Flag_E := False;
      Debug_Flag_F := False;
      Debug_Flag_G := False;
      Debug_Flag_H := False;
      Debug_Flag_I := False;
      Debug_Flag_J := False;
      Debug_Flag_K := False;
      Debug_Flag_L := False;
      Debug_Flag_M := False;
      Debug_Flag_N := False;
      Debug_Flag_O := False;
      Debug_Flag_P := False;
      Debug_Flag_Q := False;
      Debug_Flag_R := False;
      Debug_Flag_S := False;
      Debug_Flag_T := False;
      Debug_Flag_U := False;
      Debug_Flag_V := False;
      Debug_Flag_W := False;
      Debug_Flag_X := False;
      Debug_Flag_Y := False;
      Debug_Flag_Z := False;

      Debug_Mode   := False;
      Debug_Lib_Model := False; -- TEMPORARY SOLUTION, SHOULD BE DROPPED!!!
   end Set_Off;

   ------------
   -- Set_On --
   ------------

   procedure Set_On is
   begin
      Debug_Flag_1 := True;
      Debug_Flag_2 := True;
      Debug_Flag_3 := True;
      Debug_Flag_4 := True;
      Debug_Flag_5 := True;
      Debug_Flag_6 := True;
      Debug_Flag_7 := True;
      Debug_Flag_8 := True;
      Debug_Flag_9 := True;

      Debug_Flag_A := True;
      Debug_Flag_B := True;
      Debug_Flag_C := True;
      Debug_Flag_D := True;
      Debug_Flag_E := True;
      Debug_Flag_F := True;
      Debug_Flag_G := True;
      Debug_Flag_H := True;
      Debug_Flag_I := True;
      Debug_Flag_J := True;
      Debug_Flag_K := True;
      Debug_Flag_L := True;
      Debug_Flag_M := True;
      Debug_Flag_N := True;
      Debug_Flag_O := True;
      Debug_Flag_P := True;
      Debug_Flag_Q := True;
      Debug_Flag_R := True;
      Debug_Flag_S := True;
      Debug_Flag_T := True;
      Debug_Flag_U := True;
      Debug_Flag_V := True;
      Debug_Flag_W := True;
      Debug_Flag_X := True;
      Debug_Flag_Y := True;
      Debug_Flag_Z := True;

      Debug_Mode      := True; -- TEMPORARY SOLUTION, SHOULD BE DROPPED!!!
      Debug_Lib_Model := True; -- TEMPORARY SOLUTION, SHOULD BE DROPPED!!!
   end Set_On;

end A4G.A_Debug;

Add the ASIS file $i

Add the ASIS file $i


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . A _ S T A N D                           --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--                            $Revision: 15117 $
--                                                                          --
--           Copyright (c) 2002, Free Software Foundation, Inc.             --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU General Public License  distributed with ASIS-for-GNAT; see file     --
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

--  We need this renaming because the GNAT Stand package and the ASIS A4G.Stand
--  package conflict if mentioned in the same context clause. This renaming
--  seems to be the cheapest way to correct the old bad choice of the name
--  of the ASIS package (A4G.Stand)

with A4G.Stand;

package A4G.A_Stand renames A4G.Stand;

Add the ASIS file $i

Add the ASIS file $i


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                        A 4 G . D E C L _ S E M                           --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (C) 1995-2012, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU General Public License  distributed with ASIS-for-GNAT; see file     --
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

--  This package contains routines needed for semantic queries from
--  the Asis.Declarations package

with Asis;  use Asis;
with Types; use Types;

package A4G.Decl_Sem is

   --  All the routines defined in this package do not check their
   --  arguments - a caller is responcible for the proper use of these
   --  routines

   -------------------------------------------------
   --  Routines for Corresponding_Type_Definition --
   -------------------------------------------------

   function Serach_First_View (Type_Entity : Entity_Id) return Entity_Id;
   --  taking the node representing the type entity, this function looks
   --  for the first occurence of this name in the corresponding declarative
   --  region. The idea is to find the declaration of the private or incomplete
   --  type for which this type defines the full view. If there is no private
   --  or incomplete view, the function returns its argument as a result.
   --
   --  Note, that Type_Entity should not represent an implicit type created
   --  by the compiler.
   --
   --  The reason why we need this function is that some functions from Sinfo
   --  and Einfo needed for semantic queries from Asis.Declarations do not
   --  correspond to their documentation or/and have irregular behaviour. If
   --  and when the corresponding problems in Einfo and Sinfo are fixed, it
   --  would be very nice to get rid of this function, which in fact is no
   --  more than ad hoc solution.

   ---------------------------------------------
   --  Routines for Corresponding_Declaration --
   ---------------------------------------------

   function Get_Expanded_Spec (Instance_Node : Node_Id) return Node_Id;
   --  For Instance_Node, which should represent a generic instantiation,
   --  this function returns the node representing the expanded generic
   --  specification. This function never returns an Empty node.
   --
   --  Note, that in case of subprogram instantiation GNAT creates an
   --  artificial package enclosing the resulted subprogram declaration
   --
   --  This is an error to call this function for argument which does not
   --  represent an instantiation, or for a node representing a library
   --  unit declaration

   function Corresponding_Decl_Node (Body_Node : Node_Id) return Node_Id;
   --  For Body_Node representing a body, renaming-as-body or a body stub, this
   --  function returns the node representing the corresponding declaration.
   --
   --  It is an error to call this function in case when no explicit separate
   --  declaration exists (that is, in case of renaming-as-declaration or
   --  a subprogram body (stub) for which no explicit separate declaration is
   --  presented.
   --
   --  It is also an error to call this function for a node representing a
   --  library unit declaration or for a node representing generic
   --  instantiation.

   --------------------------------------
   --  Routines for Corresponding_Body --
   --------------------------------------

   function Corresponding_Body_Node (Decl_Node : Node_Id) return Node_Id;
   --  For Decl_Node representing a declaration of a program unit,
   --  this function returns the node representing the corresponding
   --  body or renaming-as-body. In is an error to call this function,
   --  if a completion of the declaration represented by the argument is
   --  located in another compilation unit, and the tree being accessed
   --  does not contain this unit (this is the case for subprograms declared
   --  immediately within a library package/library generic package).

   function Get_Renaming_As_Body
     (Node      : Node_Id;
      Spec_Only : Boolean := False)
      return Node_Id;
   --  This function tries to find for Node (which should be of
   --  N_Subprogram_Declaration kind, otherwise this is an error to call
   --  this function) the node representing renaming-as-body which is
   --  the completion of this subprogram declaration. The Spec_Only
   --  flag should be set to limit the search by a package spec only

   -------------------------------------------------
   --  Routines for Corresponding_Generic_Element --
   -------------------------------------------------

   function Get_Corresponding_Generic_Element
     (Gen_Unit : Asis.Declaration;
      Def_Name : Asis.Element)
      return Asis.Element;
   --  This function traverses the declaration of a generic package
   --  Gen_Unit (by applying an instance of Traverce_Element) in order
   --  to find A_Defining_Name Element which represents the corresponding
   --  generic element for Def_Name; Def_Name should represent
   --  A_Defining_Name element which Is_Part_Of_Instance

end A4G.Decl_Sem;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  security-openid -- OpenID 2.0 Support
--  Copyright (C) 2009, 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.Fixed;
with Ada.Text_IO;

with Util.Http.Clients;
with Util.Strings;
with Util.Encoders;
with Util.Log.Loggers;
with Util.Encoders.SHA1;
with Util.Encoders.HMAC.SHA1;
package body Security.Auth.OpenID is

   use Ada.Strings.Fixed;
   use Util.Log;

   Log : constant Util.Log.Loggers.Logger := Loggers.Create ("Security.Auth.OpenID");

   procedure Extract_Profile (Prefix  : in String;
                              Request : in Parameters'Class;
                              Result  : in out Authentication);

   function Extract (From      : String;
                     Start_Tag : String;
                     End_Tag   : String) return String;

   procedure Extract_Value (Into    : in out Unbounded_String;
                            Request : in Parameters'Class;
                            Name    : in String);

   procedure Set_Result (Result  : in out Authentication;
                         Status  : in Auth_Result;
                         Message : in String);

   function Get_Association_Query return String;

   --  ------------------------------
   --  Initialize the OpenID realm.
   --  ------------------------------
   --  Initialize the authentication realm.
   overriding
   procedure Initialize (Realm     : in out Manager;
                         Params    : in Parameters'Class;
                         Provider  : in String := PROVIDER_OPENID) is
   begin
      Realm.Realm     := To_Unbounded_String (Params.Get_Parameter (Provider & ".realm"));
      Realm.Return_To := To_Unbounded_String (Params.Get_Parameter (Provider & ".callback_url"));
   end Initialize;

   --  ------------------------------
   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   --  (See OpenID Section 7.3 Discovery)
   --  ------------------------------
   overriding
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point) is
      Client : Util.Http.Clients.Client;
      Reply  : Util.Http.Clients.Response;
   begin
      Log.Info ("Discover XRDS on {0}", Name);

      Client.Add_Header ("Accept", "application/xrds+xml");
      Client.Get (URL   => Name,
                  Reply => Reply);
      if Reply.Get_Status /= Util.Http.SC_OK then
         Log.Error ("Received error {0} when discovering XRDS on {1}",
                    Util.Strings.Image (Reply.Get_Status), Name);
         raise Service_Error with "Discovering XRDS of OpenID provider failed.";
      end if;

      Manager'Class (Realm).Extract_XRDS (Content => Reply.Get_Body,
                                          Result  => Result);
   end Discover;

   function Extract (From      : String;
                     Start_Tag : String;
                     End_Tag   : String) return String is
      Pos  : Natural := Index (From, Start_Tag);
      Last : Natural;
      Url_Pos : Natural;
   begin
      if Pos = 0 then
         Pos := Index (From, Start_Tag (Start_Tag'First .. Start_Tag'Last - 1));
         if Pos = 0 then
            return "";
         end if;
         Pos := Index (From, ">", Pos + 1);
         if Pos = 0 then
            return "";
         end if;
         Url_Pos := Pos + 1;
      else
         Url_Pos := Pos + Start_Tag'Length;
      end if;
      Last := Index (From, End_Tag, Pos);
      if Last <= Pos then
         return "";
      end if;
      return From (Url_Pos .. Last - 1);
   end Extract;

   --  ------------------------------
   --  Extract from the XRDS content the OpenID provider URI.
   --  The default implementation is very basic as it returns the first <URI>
   --  available in the stream without validating the XRDS document.
   --  Raises the Invalid_End_Point exception if the URI cannot be found.
   --  ------------------------------
   procedure Extract_XRDS (Realm   : in out Manager;
                           Content : in String;
                           Result  : out End_Point) is
      pragma Unreferenced (Realm);

      URI : constant String := Extract (Content, "<URI>", "</URI>");
   begin
      if URI'Length = 0 then
         raise Invalid_End_Point with "Cannot extract the <URI> from the XRDS document";
      end if;
      Result.URL := To_Unbounded_String (URI);
   end Extract_XRDS;

   function Get_Association_Query return String is
   begin
      return "openid.ns=http://specs.openid.net/auth/2.0&"
        & "openid.mode=associate&"
        & "openid.session_type=no-encryption&"
        & "openid.assoc_type=HMAC-SHA1";
   end Get_Association_Query;

   --  ------------------------------
   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   --  ------------------------------
   overriding
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association) is
      pragma Unreferenced (Realm);

      Output : Unbounded_String;
      URI    : constant String := To_String (OP.URL);
      Params : constant String := Get_Association_Query;
      Client : Util.Http.Clients.Client;
      Reply  : Util.Http.Clients.Response;
      Pos, Last, N : Natural;
   begin
      Client.Post (URL   => URI,
                   Data  => Params,
                   Reply => Reply);
      if Reply.Get_Status /= Util.Http.SC_OK then
         Log.Error ("Received error {0} when creating assoication with {1}",
                    Util.Strings.Image (Reply.Get_Status), URI);
         raise Service_Error with "Cannot create association with OpenID provider.";
      end if;
      Output := To_Unbounded_String (Reply.Get_Body);
      Pos := 1;
      while Pos < Length (Output) loop
         N := Index (Output, ":", Pos);
         exit when N = 0;
         Last := Index (Output, "" & ASCII.LF, N);
         if Last = 0 then
            Last := Length (Output);
         else
            Last := Last - 1;
         end if;
         declare
            Key : constant String := Slice (Output, Pos, N - 1);
         begin
            if Key = "session_type" then
               Result.Session_Type := Unbounded_Slice (Output, N + 1, Last);
            elsif Key = "assoc_type" then
               Result.Assoc_Type := Unbounded_Slice (Output, N + 1, Last);
            elsif Key = "assoc_handle" then
               Result.Assoc_Handle := Unbounded_Slice (Output, N + 1, Last);
            elsif Key = "mac_key" then
               Result.Mac_Key := Unbounded_Slice (Output, N + 1, Last);
            elsif Key = "expires_in" then
               declare
                  Val : constant String := Slice (Output, N + 1, Last);
                  --                    Expires : Integer := Integer'Value (Val);
               begin
                  Ada.Text_IO.Put_Line ("Expires: |" & Val & "|");
                  Result.Expired := Ada.Calendar.Clock;
               end;
            elsif Key /= "ns" then
               Ada.Text_IO.Put_Line ("Key not recognized: " & Key);
            end if;
         end;
         Pos := Last + 2;
      end loop;
      Log.Debug ("Received end point {0}", To_String (Output));
   end Associate;

   overriding
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String is
      Result : Unbounded_String := OP.URL;
      Axa : constant String := "ax";
   begin
      if Index (Result, "?") > 0 then
         Append (Result, "&");
      else
         Append (Result, "?");
      end if;
      Append (Result, "openid.ns=http://specs.openid.net/auth/2.0");
      Append (Result, "&openid.claimed_id=http://specs.openid.net/auth/2.0/identifier_select");
      Append (Result, "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select");
      Append (Result, "&openid.mode=checkid_setup");
      Append (Result, "&openid.ns." & Axa & "=http://openid.net/srv/ax/1.0");
      Append (Result, "&openid." & Axa & ".mode=fetch_request");
      Append (Result, "&openid." & Axa & ".type.email=http://axschema.org/contact/email");
      Append (Result, "&openid." & Axa & ".type.fullname=http://axschema.org/namePerson");
      Append (Result, "&openid." & Axa & ".type.language=http://axschema.org/pref/language");
      Append (Result, "&openid." & Axa & ".type.firstname=http://axschema.org/namePerson/first");
      Append (Result, "&openid." & Axa & ".type.lastname=http://axschema.org/namePerson/last");
      Append (Result, "&openid." & Axa & ".type.gender=http://axschema.org/person/gender");
      Append (Result, "&openid." & Axa & ".required=email,fullname,language,firstname,"
              & "lastname,gender");
      Append (Result, "&openid.ns.sreg=http://openid.net/extensions/sreg/1.1");
      Append (Result, "&openid.sreg.required=email,fullname,gender,country,nickname");
      Append (Result, "&openid.return_to=");
      Append (Result, Realm.Return_To);
      Append (Result, "&openid.assoc_handle=");
      Append (Result, Assoc.Assoc_Handle);
      Append (Result, "&openid.realm=");
      Append (Result, Realm.Realm);
      return To_String (Result);
   end Get_Authentication_URL;

   procedure Set_Result (Result  : in out Authentication;
                         Status  : in Auth_Result;
                         Message : in String) is
   begin
      if Status /= AUTHENTICATED then
         Log.Error ("OpenID verification failed: {0}", Message);
      else
         Log.Info ("OpenID verification: {0}", Message);
      end if;
      Result.Status := Status;
   end Set_Result;

   procedure Extract_Value (Into    : in out Unbounded_String;
                            Request : in Parameters'Class;
                            Name    : in String) is
   begin
      if Length (Into) = 0 then
         Into := To_Unbounded_String (Request.Get_Parameter (Name));
      end if;
   end Extract_Value;

   procedure Extract_Profile (Prefix  : in String;
                              Request : in Parameters'Class;
                              Result  : in out Authentication) is
   begin
      Extract_Value (Result.Email, Request, Prefix & ".email");
      Extract_Value (Result.Nickname, Request, Prefix & ".nickname");
      Extract_Value (Result.Gender, Request, Prefix & ".gender");
      Extract_Value (Result.Country, Request, Prefix & ".country");
      Extract_Value (Result.Language, Request, Prefix & ".language");
      Extract_Value (Result.Full_Name, Request, Prefix & ".fullname");
      Extract_Value (Result.Timezone, Request, Prefix & ".timezone");
      Extract_Value (Result.First_Name, Request, Prefix & ".firstname");
      Extract_Value (Result.Last_Name, Request, Prefix & ".lastname");

      --  If the fullname is not specified, try to build one from the first_name and last_name.
      if Length (Result.Full_Name) = 0 then
         Append (Result.Full_Name, Result.First_Name);
         if Length (Result.First_Name) > 0 and Length (Result.Last_Name) > 0 then
            Append (Result.Full_Name, " ");
            Append (Result.Full_Name, Result.Last_Name);
         end if;
      end if;
   end Extract_Profile;

   --  ------------------------------
   --  Verify the authentication result
   --  ------------------------------
   overriding
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication) is
      Mode : constant String := Request.Get_Parameter ("openid.mode");
   begin
      --  Step 1: verify the response status
      if Mode = "cancel" then
         Set_Result (Result, CANCEL, "Authentication refused");
         return;
      end if;

      if Mode = "setup_needed" then
         Set_Result (Result, SETUP_NEEDED, "Setup is needed");
         return;
      end if;

      if Mode /= "id_res" then
         Set_Result (Result, UNKNOWN, "Setup is needed");
         return;
      end if;

      --  OpenID Section: 11.1.  Verifying the Return URL
      declare
         Value : constant String := Request.Get_Parameter ("openid.return_to");
      begin
         if Value /= Realm.Return_To then
            Set_Result (Result, UNKNOWN, "openid.return_to URL does not match");
            return;
         end if;
      end;

      --  OpenID Section: 11.2.  Verifying Discovered Information
      Manager'Class (Realm).Verify_Discovered (Assoc, Request, Result);

      --  OpenID Section: 11.3.  Checking the Nonce
      declare
         Value : constant String := Request.Get_Parameter ("openid.response_nonce");
      begin
         if Value = "" then
            Set_Result (Result, UNKNOWN, "openid.response_nonce is empty");
            return;
         end if;
      end;

      --  OpenID Section: 11.4.  Verifying Signatures
      Manager'Class (Realm).Verify_Signature (Assoc, Request, Result);

      declare
         Value : constant String := Request.Get_Parameter ("openid.ns.sreg");
      begin
         --  Extract profile information
         if Value = "http://openid.net/extensions/sreg/1.1" then
            Extract_Profile ("openid.sreg", Request, Result);
         end if;
      end;

      declare
         Value : constant String := Request.Get_Parameter ("openid.ns.ax");
      begin
         if Value = "http://openid.net/srv/ax/1.0" then
            Extract_Profile ("openid.ax.value", Request, Result);
         end if;
      end;

      declare
         Value : constant String := Request.Get_Parameter ("openid.ns.ext1");
      begin
         if Value = "http://openid.net/srv/ax/1.0" then
            Extract_Profile ("openid.ext1.value", Request, Result);
         end if;
      end;
   end Verify;

   --  ------------------------------
   --  Verify the signature part of the result
   --  ------------------------------
   procedure Verify_Signature (Realm   : in Manager;
                               Assoc   : in Association;
                               Request : in Parameters'Class;
                               Result  : in out Authentication) is
      pragma Unreferenced (Realm);

      use type Util.Encoders.SHA1.Digest;

      Signed : constant String := Request.Get_Parameter ("openid.signed");
      Len    : constant Natural := Signed'Length;
      Sign   : Unbounded_String;
      Param  : Unbounded_String;
      Pos    : Natural := 1;
      Last   : Natural;
   begin
      while Pos < Len loop
         Last := Index (Signed, ",", Pos);
         if Last > 0 then
            Param := To_Unbounded_String (Signed (Pos .. Last - 1));
            Pos  := Last + 1;
         else
            Param := To_Unbounded_String (Signed (Pos .. Len));
            Pos  := Len + 1;
         end if;
         declare
            Name  : constant String := "openid." & To_String (Param);
            Value : constant String := Request.Get_Parameter (Name);
         begin
            Append (Sign, Param);
            Append (Sign, ':');
            Append (Sign, Value);
            Append (Sign, ASCII.LF);
         end;
      end loop;
      Log.Info ("Signing: '{0}'", To_String (Sign));

      declare
         Decoder : constant Util.Encoders.Encoder := Util.Encoders.Create (Util.Encoders.BASE_64);
         S       : constant String := Request.Get_Parameter ("openid.sig");
         Key     : constant String := Decoder.Decode (To_String (Assoc.Mac_Key));

         R : constant Util.Encoders.SHA1.Base64_Digest
           := Util.Encoders.HMAC.SHA1.Sign_Base64 (Key, To_String (Sign));
      begin
         Log.Info ("Signature: {0} - {1}", S, R);
         if R /= S then
            Set_Result (Result, INVALID_SIGNATURE, "openid.response_nonce is empty");
         else
            Set_Result (Result, AUTHENTICATED, "authenticated");
         end if;
      end;
   end Verify_Signature;

   --  ------------------------------
   --  Verify the authentication result
   --  ------------------------------
   procedure Verify_Discovered (Realm   : in out Manager;
                                Assoc   : in Association;
                                Request : in Parameters'Class;
                                Result  : out Authentication) is
      pragma Unreferenced (Realm, Assoc);
   begin
      Result.Claimed_Id := To_Unbounded_String (Request.Get_Parameter ("openid.claimed_id"));
      Result.Identity   := To_Unbounded_String (Request.Get_Parameter ("openid.identity"));
   end Verify_Discovered;

   function To_String (Assoc : Association) return String is
   begin
      return "session_type=" & To_String (Assoc.Session_Type)
        & "&assoc_type=" & To_String (Assoc.Assoc_Type)
        & "&assoc_handle=" & To_String (Assoc.Assoc_Handle)
        & "&mac_key=" & To_String (Assoc.Mac_Key);
   end To_String;

end Security.Auth.OpenID;

Refactor the OpenID authentication to be based on the generic authentication framework


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

package ASF.Servlets.Files renames Servlet.Core.Files;
pragma Obsolescent ("use the 'Servlet.Core.Files' package");

Package ASF.Servlets.Files renames Servlet.Core.Files but make it obscolesent (provided as backward compatibility)


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

   use type AWA.Modules.Module_Access;

   --  ------------------------------
   --  Print the configuration identified by the given name.
   --  ------------------------------
   procedure Print (Command     : in out Command_Type;
                    Name        : in String;
                    Value       : in String;
                    Default     : in String;
                    Context     : in out Context_Type) is
      pragma Unreferenced (Default);

      Pos   : Natural;
   begin
      Context.Console.Start_Row;
      Context.Console.Print_Field (1, Name);
      Pos := Value'First;
      while Pos <= Value'Last loop
         if Value'Last - Pos > Command.Value_Length then
            Context.Console.Print_Field (2, Value (Pos .. Pos + Command.Value_Length - 1));
            Pos := Pos + Command.Value_Length;
            Context.Console.End_Row;
            Context.Console.Start_Row;
            Context.Console.Print_Field (1, "");
         else
            Context.Console.Print_Field (2, Value (Pos .. Value'Last));
            Pos := Pos + Value'Length;
         end if;
      end loop;
      Context.Console.End_Row;
   end Print;

   procedure Print (Command     : in out Command_Type;
                    Application : in out AWA.Applications.Application'Class;
                    Name        : in String;
                    Default     : in String;
                    Context     : in out Context_Type) is
      Value : constant String := Application.Get_Init_Parameter (Name, Default);
   begin
      Command.Print (Name, Value, Default, Context);
   end Print;

   procedure Print (Command     : in out Command_Type;
                    Module      : in AWA.Modules.Module'Class;
                    Name        : in String;
                    Default     : in String;
                    Context     : in out Context_Type) is
      Value : constant String := Module.Get_Config (Name, Default);
   begin
      Command.Print (Module.Get_Name & "." & Name, Value, Default, Context);
   end Print;

   --  ------------------------------
   --  Print the configuration about the application.
   --  ------------------------------
   overriding
   procedure Execute (Command     : in out Command_Type;
                      Application : in out AWA.Applications.Application'Class;
                      Args        : in Argument_List'Class;
                      Context     : in out Context_Type) is
      pragma Unreferenced (Args);

      Module : AWA.Modules.Module_Access;
   begin
      if Command.Long_List then
         Command.Value_Length := Natural'Last;
      end if;
      Application.Load_Bundle (Name   => "commands",
                               Locale => "en",
                               Bundle => Command.Bundle);

      Context.Console.Start_Title;
      Context.Console.Print_Title (1, "", 30);
      Context.Console.Print_Title (2, "", Command.Value_Length);
      Context.Console.End_Title;
      Context.Console.Notice (N_INFO, "Database configuration");
      Context.Console.Notice (N_INFO, "----------------------");

      Command.Print (Application, "database", "", Context);
      Command.Print (Application, "ado.queries.paths", "", Context);
      Command.Print (Application, "ado.queries.load", "", Context);
      Command.Print (Application, "ado.drivers.load", "", Context);

      Context.Console.Start_Title;
      Context.Console.Print_Title (1, "", 30);
      Context.Console.Print_Title (2, "", Command.Value_Length);
      Context.Console.End_Title;
      Context.Console.Notice (N_INFO, "Server faces configuration");
      Context.Console.Notice (N_INFO, "--------------------------");

      Command.Print (Application, "view.dir",
                     ASF.Applications.DEF_VIEW_DIR, Context);
      Command.Print (Application, "view.escape_unknown_tags",
                     ASF.Applications.DEF_ESCAPE_UNKNOWN_TAGS, Context);
      Command.Print (Application, "view.ext",
                     ASF.Applications.DEF_VIEW_EXT, Context);
      Command.Print (Application, "view.file_ext",
                     ASF.Applications.DEF_VIEW_FILE_EXT, Context);
      Command.Print (Application, "view.ignore_spaces",
                     ASF.Applications.DEF_IGNORE_WHITE_SPACES, Context);
      Command.Print (Application, "view.ignore_empty_lines",
                     ASF.Applications.DEF_IGNORE_EMPTY_LINES, Context);
      Command.Print (Application, "view.static.dir",
                     ASF.Applications.DEF_STATIC_DIR, Context);
      Command.Print (Application, "bundle.dir", "bundles", Context);

      Context.Console.Start_Title;
      Context.Console.Print_Title (1, "", 30);
      Context.Console.Print_Title (2, "", Command.Value_Length);
      Context.Console.End_Title;
      Context.Console.Notice (N_INFO, "AWA Application");
      Context.Console.Notice (N_INFO, "--------------------------");
      Command.Print (Application, "app_name", "", Context);
      Command.Print (Application, "app_search_dirs", ".", Context);
      Command.Print (Application, "app.modules.dir", "", Context);
      Command.Print (Application, "app_url_base", "", Context);
      Command.Print (Application, "awa_url_base", "", Context);
      Command.Print (Application, "awa_url_host", "", Context);
      Command.Print (Application, "awa_url_port", "", Context);
      Command.Print (Application, "awa_url_scheme", "", Context);
      Command.Print (Application, "app.config", "awa.xml", Context);
      Command.Print (Application, "app.config.plugins", "", Context);
      Command.Print (Application, "contextPath", "", Context);
      Command.Print (Application, "awa_dispatcher_count", "", Context);
      Command.Print (Application, "awa_dispatcher_priority", "", Context);

      Context.Console.Start_Title;
      Context.Console.Print_Title (1, "", 30);
      Context.Console.Print_Title (2, "", Command.Value_Length);
      Context.Console.End_Title;
      Context.Console.Notice (N_INFO, "Users Module");
      Context.Console.Notice (N_INFO, "------------");
      Command.Print (Application, "openid.realm", "", Context);
      Command.Print (Application, "openid.callback_url", "", Context);
      Command.Print (Application, "openid.success_url", "", Context);
      Command.Print (Application, "auth.url.orange", "", Context);
      Command.Print (Application, "auth.provider.oranger", "", Context);
      Command.Print (Application, "auth.url.yahoo", "", Context);
      Command.Print (Application, "auth.provider.yahoo", "", Context);
      Command.Print (Application, "auth.url.google", "", Context);
      Command.Print (Application, "auth.provider.google", "", Context);
      Command.Print (Application, "auth.url.facebook", "", Context);
      Command.Print (Application, "auth.provider.facebook", "", Context);
      Command.Print (Application, "auth.url.google-plus", "", Context);
      Command.Print (Application, "auth.provider.google-plus", "", Context);
      Command.Print (Application, "facebook.callback_url", "", Context);
      Command.Print (Application, "facebook.request_url", "", Context);
      Command.Print (Application, "facebook.scope", "", Context);
      Command.Print (Application, "facebook.client_id", "", Context);
      Command.Print (Application, "facebook.secret", "", Context);
      Command.Print (Application, "google-plus.issuer", "", Context);
      Command.Print (Application, "google-plus.callback_url", "", Context);
      Command.Print (Application, "google-plus.request_url", "", Context);
      Command.Print (Application, "google-plus.scope", "", Context);
      Command.Print (Application, "google-plus.client_id", "", Context);
      Command.Print (Application, "google-plus.secret", "", Context);
      Command.Print (Application, "auth-filter.redirect", "", Context);
      Command.Print (Application, "verify-filter.redirect", "", Context);

      Context.Console.Start_Title;
      Context.Console.Print_Title (1, "", 30);
      Context.Console.Print_Title (2, "", Command.Value_Length);
      Context.Console.End_Title;
      Context.Console.Notice (N_INFO, "Mail Module");
      Context.Console.Notice (N_INFO, "-----------");
      Command.Print (Application, "mail.smtp.host", "", Context);
      Command.Print (Application, "mail.smtp.port", "", Context);
      Command.Print (Application, "mail.smtp.enable", "true", Context);
      Command.Print (Application, "mail.mailer", "smtp", Context);
      Command.Print (Application, "mail.file.maildir", "mail", Context);
      Command.Print (Application, "app_mail_name", "", Context);
      Command.Print (Application, "app_mail_from", "", Context);

      Module := Application.Find_Module ("workspaces");
      if Module /= null then
         Context.Console.Start_Title;
         Context.Console.Print_Title (1, "", 30);
         Context.Console.Print_Title (2, "", Command.Value_Length);
         Context.Console.End_Title;
         Context.Console.Notice (N_INFO, "Workspace Module");
         Context.Console.Notice (N_INFO, "----------------");
         Command.Print (Module.all, "permissions_list", "", Context);
         Command.Print (Module.all, "allow_workspace_create", "", Context);
      end if;

      Module := Application.Find_Module ("storages");
      if Module /= null then
         Context.Console.Start_Title;
         Context.Console.Print_Title (1, "", 30);
         Context.Console.Print_Title (2, "", Command.Value_Length);
         Context.Console.End_Title;
         Context.Console.Notice (N_INFO, "Storage Module");
         Context.Console.Notice (N_INFO, "--------------------------");
         Command.Print (Module.all, "database_max_size", "100000", Context);
         Command.Print (Module.all, "storage_root", "storage", Context);
         Command.Print (Module.all, "tmp_storage_root", "tmp", Context);
         Module := Application.Find_Module ("images");
         if Module /= null then
            Command.Print (Module.all, "thumbnail_command", "", Context);
         end if;
      end if;

      Module := Application.Find_Module ("wikis");
      if Module /= null then
         Context.Console.Start_Title;
         Context.Console.Print_Title (1, "", 30);
         Context.Console.Print_Title (2, "", Command.Value_Length);
         Context.Console.End_Title;
         Context.Console.Notice (N_INFO, "Wiki Module");
         Context.Console.Notice (N_INFO, "-----------");
         Command.Print (Module.all, "image_prefix", "", Context);
         Command.Print (Module.all, "page_prefix", "", Context);
         Command.Print (Module.all, "wiki_copy_list", "", Context);
         Module := Application.Find_Module ("wiki_previews");
         if Module /= null then
            Command.Print (Module.all, "wiki_preview_tmp", "tmp", Context);
            Command.Print (Module.all, "wiki_preview_dir", "web/preview", Context);
            Command.Print (Module.all, "wiki_preview_template", "", Context);
            Command.Print (Module.all, "wiki_preview_html", "", Context);
            Command.Print (Module.all, "wiki_preview_command", "", Context);
         end if;
      end if;

      Module := Application.Find_Module ("counters");
      if Module /= null then
         Context.Console.Start_Title;
         Context.Console.Print_Title (1, "", 30);
         Context.Console.Print_Title (2, "", Command.Value_Length);
         Context.Console.End_Title;
         Context.Console.Notice (N_INFO, "Counter Module");
         Context.Console.Notice (N_INFO, "--------------");
         Command.Print (Module.all, "counter_age_limit", "300", Context);
         Command.Print (Module.all, "counter_limit", "1000", Context);
      end if;
   end Execute;

   --  ------------------------------
   --  Setup the command before parsing the arguments and executing it.
   --  ------------------------------
   overriding
   procedure Setup (Command : in out Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration;
                    Context : in out Context_Type) is
   begin
      GC.Set_Usage (Config => Config,
                    Usage  => Command.Get_Name & " [arguments]",
                    Help   => Command.Get_Description);
      Command_Drivers.Application_Command_Type (Command).Setup (Config, Context);
      GC.Define_Switch (Config => Config,
                        Output => Command.Long_List'Access,
                        Switch => "-l",
                        Long_Switch => "--long-lines",
                        Help   => -("Use long lines to print configuration values"));
   end Setup;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in out Command_Type;
                   Name      : in String;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command, Context);
   begin
      null;
   end Help;

begin
   Command_Drivers.Driver.Add_Command ("info",
                                       -("report configuration information"),
                                       Command'Access);
end AWA.Commands.Info;

Add AWA.Commands.Info package with command to list the configuration


-----------------------------------------------------------------------
--  Util-texts-formats -- Text Format ala Java MessageFormat
--  Copyright (C) 2001, 2002, 2003, 2009, 2010 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
generic
   type Stream is limited private;
   type Char is (<>);
   type Input is array (Positive range <>) of Char;
   type Value is limited private;
   type Value_List is array (Positive range <>) of Value;
   with procedure Put (Buffer : in out Stream; C : in Character);
   with function To_Input (Arg : in Value) return Input;
package Util.Texts.Formats is

   --  Format the message and replace occurrences of argument patterns by
   --  their associated value.
   --  Returns the formatted message in the stream
   procedure Format (Message   : in Input;
                     Arguments : in Value_List;
                     Into      : in out Stream);

private
   procedure Format (Argument : in Value;
                     Into     : in out Stream);

end Util.Texts.Formats;

-----------------------------------------------------------------------
--  Util-texts-formats -- Text Format ala Java MessageFormat
--  Copyright (C) 2001, 2002, 2003, 2009, 2010, 2011, 2012, 2013 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
generic
   type Stream is limited private;
   type Char is (<>);
   type Input is array (Positive range <>) of Char;
   type Value is limited private;
   type Value_List is array (Positive range <>) of Value;
   with procedure Put (Buffer : in out Stream; C : in Character);
   with function To_Input (Arg : in Value) return Input;
package Util.Texts.Formats is
   pragma Preelaborate;

   --  Format the message and replace occurrences of argument patterns by
   --  their associated value.
   --  Returns the formatted message in the stream
   procedure Format (Message   : in Input;
                     Arguments : in Value_List;
                     Into      : in out Stream);

private
   procedure Format (Argument : in Value;
                     Into     : in out Stream);

end Util.Texts.Formats;

Add Preelaborate pragma

Add Preelaborate pragma