-----------------------------------------------------------------------
--  babel-Streams-xz -- XZ/LZMA stream management
--  Copyright (C) 2014, 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 Ada.Streams;

with Interfaces.C;

with Lzma.Container;
with Lzma.Check;
package body Babel.Streams.XZ is

   use type Interfaces.C.size_t;
   use type Ada.Streams.Stream_Element_Offset;
   use type Lzma.Base.lzma_action;
   use type Lzma.Base.lzma_ret;

   --  ------------------------------
   --  Set the input stream to decompress.
   --  ------------------------------
   procedure Set_Input (Stream : in out Stream_Type;
                        Input  : in Babel.Streams.Stream_Access) is
      Result : Lzma.Base.lzma_ret;
   begin
      Stream.Input := Input;
      Stream.Action := Lzma.Base.LZMA_RUN;
      Result := Lzma.Container.lzma_stream_decoder (Stream.Context'Unchecked_Access,
                                                    Long_Long_Integer'Last,
                                                    Lzma.Container.LZMA_CONCATENATED);
   end Set_Input;

   --  ------------------------------
   --  Set the output stream to write the compressed stream.
   --  ------------------------------
   procedure Set_Output (Stream : in out Stream_Type;
                         Output : in Babel.Streams.Stream_Access) is
      Result : Lzma.Base.lzma_ret;
   begin
      Stream.Output := Output;
      Stream.Action := Lzma.Base.LZMA_RUN;
      Result := Lzma.Container.lzma_easy_encoder (Stream.Context'Unchecked_Access, 6,
                                                  Lzma.Check.LZMA_CHECK_CRC64);
      Stream.Context.next_out  := Stream.Buffer.Data (Stream.Buffer.Data'First)'Unchecked_Access;
      Stream.Context.avail_out := Stream.Buffer.Data'Length;
   end Set_Output;

   --  ------------------------------
   --  Read the data stream as much as possible and return the result in a buffer.
   --  The buffer is owned by the stream and need not be released.  The same buffer may
   --  or may not be returned by the next <tt>Read</tt> operation.
   --  A null buffer is returned when the end of the data stream is reached.
   --  ------------------------------
   overriding
   procedure Read (Stream : in out Stream_Type;
                   Buffer : out Babel.Files.Buffers.Buffer_Access) is
      use type Babel.Files.Buffers.Buffer_Access;

      Inbuf  : Babel.Files.Buffers.Buffer_Access;
      Result : Lzma.Base.lzma_ret;
   begin
      Buffer := Stream.Buffer;
      Stream.Context.next_out  := Buffer.Data (Buffer.Data'First)'Unchecked_Access;
      Stream.Context.avail_out := Buffer.Data'Length;
      loop
         --  Read a block of data from the source file.
         if Stream.Context.avail_in = 0 and Stream.Action = Lzma.Base.LZMA_RUN then
            Stream.Input.Read (Inbuf);
            if Inbuf = null then
               Stream.Action := Lzma.Base.LZMA_FINISH;
            else
               Stream.Context.next_in := Inbuf.Data (Inbuf.Data'First)'Unchecked_Access;
               Stream.Context.avail_in := Interfaces.C.size_t (Inbuf.Last - Inbuf.Data'First + 1);
            end if;
         end if;
         Result := Lzma.Base.lzma_code (Stream.Context'Unchecked_Access, Stream.Action);

         --  Write the output data when the buffer is full or we reached the end of stream.
         exit when Stream.Context.avail_out = 0 or Result = Lzma.Base.LZMA_STREAM_END;
         if Result /= Lzma.Base.LZMA_OK then
            Buffer := null;
            return;
         end if;
      end loop;
      if Buffer.Data'Length = Stream.Context.avail_out then
         Buffer := null;
      else
         Buffer.Last :=
           Buffer.Data'Last - Ada.Streams.Stream_Element_Offset (Stream.Context.avail_out);
      end if;
   end Read;

   --  ------------------------------
   --  Write the buffer in the data stream.
   --  ------------------------------
   overriding
   procedure Write (Stream : in out Stream_Type;
                    Buffer : in Babel.Files.Buffers.Buffer_Access) is
      Result : Lzma.Base.lzma_ret;
   begin
      Stream.Context.next_in   := Buffer.Data (Buffer.Data'First)'Unchecked_Access;
      Stream.Context.avail_in  := Interfaces.C.size_t (Buffer.Last - Buffer.Data'First + 1);
      loop
         --  Read a block of data from the source file.
         exit when Stream.Context.avail_in = 0;
         Result := Lzma.Base.lzma_code (Stream.Context'Unchecked_Access, Stream.Action);

         --  Write the output data when the buffer is full or we reached the end of stream.
         if Stream.Context.avail_out = 0 or Result = Lzma.Base.LZMA_STREAM_END then
            Stream.Buffer.Last := Stream.Buffer.Data'Last
              - Ada.Streams.Stream_Element_Offset (Stream.Context.avail_out);
            Stream.Output.Write (Stream.Buffer);
            Stream.Context.avail_out := Stream.Buffer.Data'Length;
            Stream.Context.next_out  :=
              Stream.Buffer.Data (Stream.Buffer.Data'First)'Unchecked_Access;
         end if;
         exit when Result /= Lzma.Base.LZMA_OK;
      end loop;
   end Write;

   --  ------------------------------
   --  Flush the data stream.
   --  ------------------------------
   overriding
   procedure Flush (Stream : in out Stream_Type) is
      Result : Lzma.Base.lzma_ret;
   begin
      Stream.Action := Lzma.Base.LZMA_FINISH;
      Stream.Context.avail_in  := 0;
      loop
         --  Read a block of data from the source file.
         Result := Lzma.Base.lzma_code (Stream.Context'Unchecked_Access, Stream.Action);

         --  Write the output data when the buffer is full or we reached the end of stream.
         if Stream.Context.avail_out = 0 or Result = Lzma.Base.LZMA_STREAM_END then
            Stream.Buffer.Last := Stream.Buffer.Data'Last
              - Ada.Streams.Stream_Element_Offset (Stream.Context.avail_out);
            Stream.Output.Write (Stream.Buffer);
            Stream.Context.avail_out := Stream.Buffer.Data'Length;
            Stream.Context.next_out  :=
              Stream.Buffer.Data (Stream.Buffer.Data'First)'Unchecked_Access;
         end if;
         exit when Result /= Lzma.Base.LZMA_OK;
      end loop;
      Stream.Output.Flush;
   end Flush;

   --  ------------------------------
   --  Close the data stream.
   --  ------------------------------
   overriding
   procedure Close (Stream : in out Stream_Type) is
   begin
      if Stream.Output /= null then
         Stream.Flush;
         Stream.Output.Close;
      end if;

   end Close;

   --  ------------------------------
   --  Prepare to read again the data stream from the beginning.
   --  ------------------------------
   overriding
   procedure Rewind (Stream : in out Stream_Type) is
   begin
      Stream.Action := Lzma.Base.LZMA_RUN;
      Stream.Input.Rewind;
   end Rewind;

   --  ------------------------------
   --  Release the stream buffer and the LZMA stream.
   --  ------------------------------
   overriding
   procedure Finalize (Stream : in out Stream_Type) is
   begin
      Lzma.Base.lzma_end (Stream.Context'Unchecked_Access);
      Babel.Streams.Stream_Type (Stream).Finalize;
   end Finalize;

end Babel.Streams.XZ;

Implement the stream compression/decompress with LZMA library


-----------------------------------------------------------------------
--  babel-files-sets -- Sets of files
--  Copyright (C) 2014 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.Ordered_Sets;
with Util.Strings;

package body Babel.Files.Sets is

   --  Insert the file in the file set.
   procedure Insert (Into : in out File_Set;
                     File : in File_Type) is
   begin
      File_Sets.Insert (Into, File);
   end Insert;

end Babel.Files.Sets;

Implement the Insert procedure

Implement the Insert procedure


-----------------------------------------------------------------------
--  security-permissions -- Definition of permissions
--  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.Containers.Hashed_Maps;
with Ada.Containers.Vectors;
with Ada.Unchecked_Deallocation;
with Ada.Strings.Unbounded;

with Util.Refs;
with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;
with Util.Serialize.Mappers;
with Util.Serialize.Mappers.Record_Mapper;

with GNAT.Regexp;
with Security.Controllers;

package body Security.Policies.Urls is

   --  ------------------------------
   --  URL policy
   --  ------------------------------

   --  Get the policy name.
   overriding
   function Get_Name (From : in URL_Policy) return String is
   begin
      return NAME;
   end Get_Name;

   --  Returns True if the user has the permission to access the given URI permission.
   function Has_Permission (Manager    : in URL_Policy;
                            Context    : in Security_Context_Access;
                            Permission : in URI_Permission'Class) return Boolean is
      Name  : constant String_Ref := To_String_Ref (Permission.URI);
      Ref   : constant Rules_Ref.Ref := Manager.Cache.Get;
      Rules : constant Rules_Access := Ref.Value;
      Pos   : constant Rules_Maps.Cursor := Rules.Map.Find (Name);
      Rule  : Access_Rule_Ref;
   begin
      --  If the rule is not in the cache, search for the access rule that
      --  matches our URI.  Update the cache.  This cache update is thread-safe
      --  as the cache map is never modified: a new cache map is installed.
      if not Rules_Maps.Has_Element (Pos) then
         declare
            New_Ref : constant Rules_Ref.Ref := Rules_Ref.Create;
         begin
            Rule := Manager.Find_Access_Rule (Permission.URI);
            New_Ref.Value.all.Map := Rules.Map;
            New_Ref.Value.all.Map.Insert (Name, Rule);
            Manager.Cache.Set (New_Ref);
         end;
      else
         Rule := Rules_Maps.Element (Pos);
      end if;

      --  Check if the user has one of the required permission.
      declare
         P       : constant Access_Rule_Access := Rule.Value;
         Granted : Boolean;
      begin
         if P /= null then
            for I in P.Permissions'Range loop
--                 Context.Has_Permission (P.Permissions (I), Granted);
               if Granted then
                  return True;
               end if;
            end loop;
         end if;
      end;
      return False;
   end Has_Permission;

   --  Grant the permission to access to the given URI to users having the To
   --  permissions.
   procedure Grant_URI_Permission (Manager : in out URL_Policy;
                                   URI     : in String;
                                   To      : in String) is
   begin
      null;
   end Grant_URI_Permission;

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------
   type Policy_Config is record
      Id          : Natural := 0;
      Permissions : Util.Beans.Objects.Vectors.Vector;
      Patterns    : Util.Beans.Objects.Vectors.Vector;
      Manager     : URL_Policy_Access;
   end record;
   type Policy_Config_Access is access all Policy_Config;

   --  Setup the XML parser to read the policy description.  For example:

   --  Find the access rule of the policy that matches the given URI.
   --  Returns the No_Rule value (disable access) if no rule is found.
   function Find_Access_Rule (Manager : in URL_Policy;
                              URI     : in String) return Access_Rule_Ref is

      Matched : Boolean := False;
      Result  : Access_Rule_Ref;

      procedure Match (P : in Policy);

      procedure Match (P : in Policy) is
      begin
         if GNAT.Regexp.Match (URI, P.Pattern) then
            Matched := True;
            Result  := P.Rule;
         end if;
      end Match;

      Last : constant Natural := Manager.Policies.Last_Index;
   begin
      for I in 1 .. Last loop
         Manager.Policies.Query_Element (I, Match'Access);
         if Matched then
            return Result;
         end if;
      end loop;
      return Result;
   end Find_Access_Rule;

   --  ------------------------------
   --  Initialize the permission manager.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out URL_Policy) is
   begin
      Manager.Cache := new Rules_Ref.Atomic_Ref;
      Manager.Cache.Set (Rules_Ref.Create);
   end Initialize;

   --  ------------------------------
   --  Finalize the permission manager.
   --  ------------------------------
   overriding
   procedure Finalize (Manager : in out URL_Policy) is
      use Ada.Strings.Unbounded;
      use Security.Controllers;

      procedure Free is
        new Ada.Unchecked_Deallocation (Rules_Ref.Atomic_Ref,
                                        Rules_Ref_Access);
      procedure Free is
        new Ada.Unchecked_Deallocation (Security.Controllers.Controller'Class,
                                        Security.Controllers.Controller_Access);
      procedure Free is
        new Ada.Unchecked_Deallocation (Controller_Access_Array,
                                        Controller_Access_Array_Access);

   begin
      Free (Manager.Cache);
--        for I in Manager.Names'Range loop
--           exit when Manager.Names (I) = null;
--           Ada.Strings.Unbounded.Free (Manager.Names (I));
--        end loop;

   end Finalize;

   type Policy_Fields is (FIELD_ID, FIELD_PERMISSION, FIELD_URL_PATTERN, FIELD_POLICY);

   procedure Set_Member (P     : in out Policy_Config;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object);

   procedure Process (Policy : in Policy_Config);

   procedure Set_Member (P     : in out Policy_Config;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_ID =>
            P.Id := Util.Beans.Objects.To_Integer (Value);

         when FIELD_PERMISSION =>
            P.Permissions.Append (Value);

         when FIELD_URL_PATTERN =>
            P.Patterns.Append (Value);

         when FIELD_POLICY =>
            Process (P);
            P.Id := 0;
            P.Permissions.Clear;
            P.Patterns.Clear;

      end case;
   end Set_Member;

   procedure Process (Policy : in Policy_Config) is
      Pol    : Security.Policies.URLs.Policy;
      Count  : constant Natural := Natural (Policy.Permissions.Length);
      Rule   : constant Access_Rule_Ref := Access_Rule_Refs.Create (new Access_Rule (Count));
      Iter   : Util.Beans.Objects.Vectors.Cursor := Policy.Permissions.First;
      Pos    : Positive := 1;
   begin
      Pol.Rule := Rule;

      --  Step 1: Initialize the list of permission index in Access_Rule from the permission names.
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Perm : constant Util.Beans.Objects.Object := Util.Beans.Objects.Vectors.Element (Iter);
            Name : constant String := Util.Beans.Objects.To_String (Perm);
         begin
            Rule.Value.all.Permissions (Pos) := Permissions.Get_Permission_Index (Name);
            Pos := Pos + 1;

         exception
            when Invalid_Name =>
               raise Util.Serialize.Mappers.Field_Error with "Invalid permission: " & Name;
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;

      --  Step 2: Create one policy for each URL pattern
      Iter := Policy.Patterns.First;
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Pattern : constant Util.Beans.Objects.Object
              := Util.Beans.Objects.Vectors.Element (Iter);
         begin
            Pol.Id   := Policy.Id;
            Pol.Pattern := GNAT.Regexp.Compile (Util.Beans.Objects.To_String (Pattern));
            Policy.Manager.Policies.Append (Pol);
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;
   end Process;

   package Policy_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Policy_Config,
                                               Element_Type_Access => Policy_Config_Access,
                                               Fields              => Policy_Fields,
                                               Set_Member          => Set_Member);

   Policy_Mapping        : aliased Policy_Mapper.Mapper;

   --  Setup the XML parser to read the policy description.
   overriding
   procedure Set_Reader_Config (Policy : in out URL_Policy;
                                Reader : in out Util.Serialize.IO.XML.Parser) is

--        Policy_Mapping        : aliased Policy_Mapper.Mapper;
      Config : Policy_Config_Access := new Policy_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Policy_Mapping'Access);
      Reader.Add_Mapping ("module", Policy_Mapping'Access);
      Config.Manager := Policy'Unchecked_Access;
      Policy_Mapper.Set_Context (Reader, Config);
   end Set_Reader_Config;

begin
   Policy_Mapping.Add_Mapping ("policy", FIELD_POLICY);
   Policy_Mapping.Add_Mapping ("policy/@id", FIELD_ID);
   Policy_Mapping.Add_Mapping ("policy/permission", FIELD_PERMISSION);
   Policy_Mapping.Add_Mapping ("policy/url-pattern", FIELD_URL_PATTERN);
end Security.Policies.Urls;

Implement the URL security policy from the old Security.Permissions package


-----------------------------------------------------------------------
--  security-openid -- OpenID 2.0 Support
--  Copyright (C) 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.
-----------------------------------------------------------------------

with Util.Log.Loggers;

with Security.Auth.OpenID;
with Security.Auth.OAuth.Facebook;
package body Security.Auth is

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

   --  ------------------------------
   --  Get the provider.
   --  ------------------------------
   function Get_Provider (Assoc : in Association) return String is
   begin
      return To_String (Assoc.Provider);
   end Get_Provider;

   --  ------------------------------
   --  Get the email address
   --  ------------------------------
   function Get_Email (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Email);
   end Get_Email;

   --  ------------------------------
   --  Get the user first name.
   --  ------------------------------
   function Get_First_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.First_Name);
   end Get_First_Name;

   --  ------------------------------
   --  Get the user last name.
   --  ------------------------------
   function Get_Last_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Last_Name);
   end Get_Last_Name;

   --  ------------------------------
   --  Get the user full name.
   --  ------------------------------
   function Get_Full_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Full_Name);
   end Get_Full_Name;

   --  ------------------------------
   --  Get the user identity.
   --  ------------------------------
   function Get_Identity (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Identity);
   end Get_Identity;

   --  ------------------------------
   --  Get the user claimed identity.
   --  ------------------------------
   function Get_Claimed_Id (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Claimed_Id);
   end Get_Claimed_Id;

   --  ------------------------------
   --  Get the user language.
   --  ------------------------------
   function Get_Language (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Language);
   end Get_Language;

   --  ------------------------------
   --  Get the user country.
   --  ------------------------------
   function Get_Country (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Country);
   end Get_Country;

   --  ------------------------------
   --  Get the result of the authentication.
   --  ------------------------------
   function Get_Status (Auth : in Authentication) return Auth_Result is
   begin
      return Auth.Status;
   end Get_Status;

   --  ------------------------------
   --  Default principal
   --  ------------------------------

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   function Get_Name (From : in Principal) return String is
   begin
      return Get_First_Name (From.Auth) & " " & Get_Last_Name (From.Auth);
   end Get_Name;

   --  ------------------------------
   --  Get the user email address.
   --  ------------------------------
   function Get_Email (From : in Principal) return String is
   begin
      return Get_Email (From.Auth);
   end Get_Email;

   --  ------------------------------
   --  Get the authentication data.
   --  ------------------------------
   function Get_Authentication (From : in Principal) return Authentication is
   begin
      return From.Auth;
   end Get_Authentication;

   --  ------------------------------
   --  Create a principal with the given authentication results.
   --  ------------------------------
   function Create_Principal (Auth : in Authentication) return Principal_Access is
      P : constant Principal_Access := new Principal;
   begin
      P.Auth := Auth;
      return P;
   end Create_Principal;

   --  ------------------------------
   --  Initialize the OpenID realm.
   --  ------------------------------
   procedure Initialize (Realm     : in out Manager;
                         Params    : in Parameters'Class;
                         Provider  : in String := PROVIDER_OPENID) is
      Impl : Manager_Access;
   begin
      if Provider = PROVIDER_OPENID then
         Impl := new Security.Auth.OpenID.Manager;

      elsif Provider = PROVIDER_FACEBOOK then
         Impl := new Security.Auth.OAuth.Facebook.Manager;

      else
         Log.Error ("Authentication provider {0} not recognized", Provider);
         raise Service_Error with "Authentication provider not supported";
      end if;
      Impl.Initialize (Params, Provider);
      Realm.Delegate := Impl;
      Realm.Provider := To_Unbounded_String (Provider);
   end Initialize;

   --  ------------------------------
   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The <b>Name</b> can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  (See OpenID Section 7.3 Discovery)
   --  ------------------------------
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point) is
   begin
      if Realm.Delegate /= null then
         Realm.Delegate.Discover (Name, Result);
      else
--           Result.URL := Realm.Realm;
         Result.Alias := To_Unbounded_String ("");
      end if;
   end Discover;

   --  ------------------------------
   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   --  ------------------------------
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association) is
   begin
      Result.Provider := Realm.Provider;
      if Realm.Delegate /= null then
         Realm.Delegate.Associate (OP, Result);
      end if;
   end Associate;

   --  ------------------------------
   --  Get the authentication URL to which the user must be redirected for authentication
   --  by the authentication server.
   --  ------------------------------
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String is
   begin
      if Realm.Delegate /= null then
         return Realm.Delegate.Get_Authentication_URL (OP, Assoc);
      else
         return To_String (OP.URL);
      end if;
   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;

   --  ------------------------------
   --  Verify the authentication result
   --  ------------------------------
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication) is
   begin
      if Realm.Delegate /= null then
         Realm.Delegate.Verify (Assoc, Request, Result);
      else
         Set_Result (Result, SETUP_NEEDED, "Setup is needed");
      end if;
   end Verify;

   function To_String (OP : End_Point) return String is
   begin
      return "openid://" & To_String (OP.URL);
   end To_String;

   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;

Implement the new authentication framework based on the OpenID implementation


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

with ASF.Requests;
with AWA.Storages.Servlets;

with ADO;
package AWA.Images.Servlets is

   --  The <b>Image_Servlet</b> represents the component that will handle
   --  an HTTP request received by the server.
   type Image_Servlet is new AWA.Storages.Servlets.Storage_Servlet with private;

   --  Load the data content that correspond to the GET request and get the name as well
   --  as mime-type and date.
   overriding
   procedure Load (Server   : in Image_Servlet;
                   Request  : in out ASF.Requests.Request'Class;
                   Name     : out Ada.Strings.Unbounded.Unbounded_String;
                   Mime     : out Ada.Strings.Unbounded.Unbounded_String;
                   Date     : out Ada.Calendar.Time;
                   Data     : out ADO.Blob_Ref);

private

   type Image_Servlet is new AWA.Storages.Servlets.Storage_Servlet with null record;

end AWA.Images.Servlets;

Declare the AWA.Images.Servlets package with the Image_Servlet type


-----------------------------------------------------------------------
--  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.Test_Caller;
with Babel.Files.Buffers;
with Babel.Streams.Cached;
with Babel.Streams.Files;
with Babel.Streams.XZ;
package body Babel.Streams.Tests is

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Babel.Streams.Read",
                       Test_Stream_Composition'Access);
   end Add_Tests;

   --  ------------------------------
   --  Stream copy, compression and decompression test.
   --  Create a compressed version of the source file and then decompress the result.
   --  The source file is then compared to the decompressed result and must match.
   --  ------------------------------
   procedure Do_Copy (T    : in out Test;
                      Pool : in out Babel.Files.Buffers.Buffer_Pool;
                      Src  : in String) is
      use type Babel.Files.Buffers.Buffer_Access;

      Src_Path : constant String := Util.Tests.Get_Path (Src);
      Dst_Path : constant String := Util.Tests.Get_Test_Path ("regtests/result/" & Src & ".xz");
      Tst_Path : constant String := Util.Tests.Get_Test_Path ("regtests/result/" & Src);
      Buffer   : Babel.Files.Buffers.Buffer_Access;
   begin
      --  Compress the 'configure' file into 'configure.xz' through the file+cache+xz+file streams.
      declare
         In_File  : aliased Babel.Streams.Files.Stream_Type;
         Out_File : aliased Babel.Streams.Files.Stream_Type;
         Cache    : aliased Babel.Streams.Cached.Stream_Type;
         Lz       : aliased Babel.Streams.XZ.Stream_Type;
      begin
         Pool.Get_Buffer (Buffer);
         In_File.Open (Src_Path, Buffer);
         Cache.Load (In_File, Pool);

         Pool.Get_Buffer (Buffer);
         Out_File.Create (Dst_Path, 8#644#);
         Lz.Set_Buffer (Buffer);
         Lz.Set_Output (Out_File'Unchecked_Access);
         loop
            Cache.Read (Buffer);
            exit when Buffer = null;
            Lz.Write (Buffer);
         end loop;
         Lz.Flush;
         Lz.Close;
      end;

      --  Decompress through file+cache+xz+file
      declare
         In_File  : aliased Babel.Streams.Files.Stream_Type;
         Out_File : aliased Babel.Streams.Files.Stream_Type;
         Cache    : aliased Babel.Streams.Cached.Stream_Type;
         Lz       : aliased Babel.Streams.XZ.Stream_Type;
      begin
         Pool.Get_Buffer (Buffer);
         In_File.Open (Dst_Path, Buffer);
         Cache.Load (In_File, Pool);

         --  Setup decompression.
         Pool.Get_Buffer (Buffer);
         Lz.Set_Input (Cache'Unchecked_Access);
         Lz.Set_Buffer (Buffer);

         Out_File.Create (Tst_Path, 8#644#);
         loop
            Lz.Read (Buffer);
            exit when Buffer = null;
            Out_File.Write (Buffer);
         end loop;
         Out_File.Close;
      end;
      Util.Tests.Assert_Equal_Files (T, Src_Path, Tst_Path,
                                     "Composition stream failed for: " & Src);

   end Do_Copy;

   --  ------------------------------
   --  Test the Find function resolving some existing user.
   --  ------------------------------
   procedure Test_Stream_Composition (T : in out Test) is
      Pool     : aliased Babel.Files.Buffers.Buffer_Pool;
   begin
      Babel.Files.Buffers.Create_Pool (Into  => Pool,
                                       Size  => 1_000,
                                       Count => 1000);
      Do_Copy (T, Pool, "configure");
      Do_Copy (T, Pool, "babel.gpr");
      Do_Copy (T, Pool, "configure.in");
      Do_Copy (T, Pool, "config.guess");
      Do_Copy (T, Pool, "Makefile.in");
   end Test_Stream_Composition;

end Babel.Streams.Tests;

Implement the Do_Copy procedure to verify the compression/decompression and copy through the Babel.Streams types


-----------------------------------------------------------------------
--  mat-readers -- Reader
--  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.
-----------------------------------------------------------------------

package body MAT.Readers is

   --  ------------------------------
   --  Get the buffer endian format.
   --  ------------------------------
   function Get_Endian (Msg : in Message_Type) return Endian_Type is
   begin
      return Msg.Buffer.Endian;
   end Get_Endian;

end MAT.Readers;

Implement the Get_Endian function

Implement the Get_Endian function


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

   --  The <b>Storage_Servlet</b> represents the component that will handle
   --  an HTTP request received by the server.
   type Image_Servlet is new ASF.Servlets.Servlet with private;

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

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

private

   type Image_Servlet is new ASF.Servlets.Servlet with null record;

end AWA.Wikis.Servlets;

Declare Image_Servlet type and override the Do_Get operation


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                         A 4 G . U N I T _ R E C                          --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (C) 1995-2011, 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,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, 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 AdaCore                     --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

--  This package defines the type Unit_Record used for storing the
--  information about ASIS Compilation Units. This type is used as an actual
--  parameter for instantiating the GNAT Table package and obtaining the type
--  for defining the individual Unit Table for each ASIS Context.

with Asis;

with Asis.Extensions; use Asis.Extensions;

with A4G.A_Types;     use A4G.A_Types;

with Types;           use Types;

package  A4G.Unit_Rec is

   --  See A4G.Contt (spec) and A4G.Contt.UT for the complete documentation of
   --  the Compilation Units processing in ASIS.

   --  !!! Documentation should be put in order later!!!

   ---------------------------------
   -- Unit_Record type definition --
   ---------------------------------

   type Unit_Record is record -- the field should be commented also here!!!

      --------------------------------
      -- Fields for Unit Name Table --
      --------------------------------

      Ada_Name_Chars_Index      : Int;
      Norm_Ada_Name_Chars_Index : Int;
      File_Name_Chars_Index     : Int;
      Ref_Name_Chars_Index      : Int;
      --  Starting locations of characters in the Name_Chars table minus
      --  one (i.e. pointer to character just before first character). The
      --  reason for the bias of one is that indexes in Name_Buffer are
      --  one's origin, so this avoids unnecessary adds and subtracts of 1.

      Ada_Name_Len      : Short;
      Norm_Ada_Name_Len : Short;
      File_Name_Len     : Short;
      Ref_Name_Len      : Short;
      --  Lengths of the names in characters

      --  We keep separate starting locations and separate lengths
      --  for each "column" of Unit Name Table, but all the actual
      --  strings are stored in the same Name_Chars table

      Hash_Link : Unit_Id;
      --  Link to next entry in names table for same hash code

      -----------------------------------------------
      -- Fields for Black-Box Unit Name Attributes --
      -----------------------------------------------

      Top               : Node_Id;
      --  ??? Do we really need it?
      --  This field is used only during the tree investigation,
      --  and it is used only for the Units contained in this tree,
      --  which have been known to ASIS before (the aim is to optimize
      --  the tree investigation by eliminating the need to compute
      --  the top node for the these Units). Tree swapping makes
      --  the values of these fields obsolete, and we do not want
      --  to keep them valid after investigating the tree. Instead,
      --  if we need the top node corresponding to some Unit during
      --  processing of some ASIS query, we compute it, and this
      --  computation includes, if the Unit may be processed on the
      --  base of the currently accessed tree, resetting this
      --  tree, if necessary, and finding out the corresponding
      --  N_Compuilation_Unit node in this tree.

      Kind              : Asis.Unit_Kinds;
      Class             : Asis.Unit_Classes;
      Origin            : Asis.Unit_Origins;
      Main_Unit         : Boolean;
      Is_Body_Required  : Boolean;
      Time_Stamp        : Time_Stamp_Type;

      Is_Consistent     : Boolean;

      Source_File_Status : Source_File_Statuses;

      Full_View_Trees    : Elist_Id;
      Limited_View_Trees : Elist_Id;
      --  The lists of the trees in which the subtree for a given Unit is
      --  contained, all these trees are consistent in the sense, that all of
      --  them correspond to the same, latest version of unit's source. The
      --  first list contains trees that contain full view of the unit, the
      --  second contains trees that contain only limited views of the unit.

      Main_Tree : Tree_Id;
      --  The tree for which the given unit is a main unit. If there is no
      --  tree for which the unit is the main unit, this field set to
      --  Nil_Tree_Id

      --------------------------------------
      -- Fields for Semantic Dependencies --
      --------------------------------------

      Ancestors           : Elist_Id;
      Descendants         : Elist_Id;
      Direct_Supporters   : Elist_Id;
      Supporters          : Elist_Id;
      Implicit_Supporters : Elist_Id;
      Direct_Dependents   : Elist_Id;
      Dependents          : Elist_Id;
      Subunits_Or_Childs  : Elist_Id;

      Compilation_Dependencies : Elist_Id;

      Subunits_Computed   : Boolean;

      --  The meaning of these lists completely corresponds to the values
      --  of the Asis.Unit_Kinds.Relation_Kinds type, represented by its
      --  literals with the same names.
      --  SHOULD BE REVISED! For example, for subunits it may make sense
      --  to use Ancestors for parent bodies, and it would make sense
      --  for bodies to use Descendants for subunits.
      --
      --  All these fields are either non-empty unit lists, or equal to
      --  No_List, the latter case correspond to the situation, when
      --  the corresponding dependency list is empty (???).

      --  it would be nice to get rid of Direct_Supporters and of
      --  Direct_Dependants as of ill-defined notions (they are not
      --  defined in RM95, opposite to Supporters and Dependents

      --  We may need Implicit_Supporters for
      --  Asis.Compilation_Units.Elaboration_Order query

      --  Subunits_Computed indicates if for a given parent body all its
      --  subunits have already been computed (as a result of a Compilation
      --  Unit semantic query). Computing subunits include allocating
      --  nonexistent units for missed subunits.

      --  Do we really need the list for Ancestors? We can easy compute
      --  ancestors by stripping out selectors in normalized unit names.

      --  OPEN PROBLEMS with ASIS 95 definition
      --  =====================================

      --  1. RM95 says 10.1.1(9):
      --       A library unit is a program unit that is declared by a
      --       library_item. When a program unit is a library unit, the
      --       prefix "library" is used to refer to it (or "generic
      --       library" if generic), as well as to its declaration and
      --       body, as in "library procedure", "library package_body",
      --       or "generic library package". The term compilation unit
      --       is used to refer to a compilation_unit.  When the meaning
      --       is clear from context, the term is also used to refer to
      --       the library_item of a compilation_unit or to the proper_body
      --       of a subunit (that is, the compilation_unit without the
      --       context_clause and the separate (parent_unit_name)).
      --
      --     And AARM adds in 10.1.1(9.d):
      --       We like to use the word "unit" for declaration-plus-body
      --       things, and "item" for declaration or body separately
      --       (as in declarative_item). The terms "compilation_unit",
      --       "compilation unit" and "subunit" are exceptions to this rule.
      --
      --     RM95 says 10.1.1(10):
      --       The parent declaration of a library_item (and of the library
      --       unit) is the declaration denoted by the parent_unit_name, if
      --       any, of the defining_program_unit_name of the library_item.
      --       If there is no parent_unit_name, the parent declaration is
      --       the declaration of Standard, the library_item is a root
      --       library_item, and the library unit (renaming) is a root
      --       library unit (renaming).  The declaration and body of
      --       Standard itself have no parent declaration.  The parent unit
      --       of a library_item or library unit is the library unit
      --       declared by its parent declaration.
      --
      --     And AARM adds in 10.1.1(10.d):
      --       Library units ... have "parent declarations" [which are
      --       *compilation* units] and "parent units" [spec + body].
      --       We didn't bother to define the other possibilities: parent
      --       body of a library unit, parent declaration of a subunit,
      --       parent unit of a subunit. These are not needed...
      --
      --     RM95 says 10.1.1(11):
      --       The children of a library unit occur immediately within the
      --       declarative region of the declaration of the library unit.
      --       The ancestors of a library unit are itself, its parent, its
      --       parent's parent, and so on.  (Standard is an ancestor of
      --       every library unit.)  The descendant relation is the inverse
      --       of the ancestor relation.
      --
      --     AARM adds (10.1.1(11.b):
      --       We use the unadorned term "ancestors" here to concisely
      --       define both "ancestor unit" and "ancestor declaration"
      --
      --     THE QUESTION IS: what do the *ASIS* notions of ancestors
      --       and descendants mean - do they mean "ancestor (descendant)
      --       unit" or "ancestor (descendant) declaration"?
      --
      --     THE "WORKING" SOLUTION: now *in ASIS* "ancestor" means
      --       "ancestor declaration", and "descendant" means "descendant
      --       unit". (Is it really a good decision, if the Descendants
      --       relation is defined by ASIS as the inverse of the ancestor
      --       relation? From the other side, this looks quite natural from
      --       the application viewpoint: if we are asking about ancestors,
      --       we are very likely interested in declarations, but not
      --       bodies,, and when we are asking about descendants, we are
      --       very likely interested in *all* (compilation units which are)
      --       the descendants.
      --
      --       (Moreover, the query
      --       Asis.Compilation_Units.Corresponding_Children has only
      --       *declarations* as appropriate argument unit kinds, and it
      --       returns declarations *and bodies (if any)*

   end record;

end A4G.Unit_Rec;

Add the ASIS file $i

Add the ASIS file $i


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

package body UPnP.SSDP is
   use type Ada.Streams.Stream_Element_Offset;
   use type Ada.Streams.Stream_Element;

   --  The logger
   Log   : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("UPnP.SSDP");

   Group : constant String := "239.255.255.250";

   procedure Send (Socket  : in GNAT.Sockets.Socket_Type;
                   Content : in String;
                   To      : access GNAT.Sockets.Sock_Addr_Type);

   --  ------------------------------
   --  Initialize the SSDP scanner by opening the UDP socket.
   --  ------------------------------
   procedure Initialize (Scanner : in out Scanner_Type) is
      Address      : aliased GNAT.Sockets.Sock_Addr_Type;
   begin
      Log.Info ("Discovering gateways on the network");

      Address.Addr := GNAT.Sockets.Any_Inet_Addr;
      GNAT.Sockets.Create_Socket (Scanner.Socket, GNAT.Sockets.Family_Inet,
                                  GNAT.Sockets.Socket_Datagram);
      GNAT.Sockets.Bind_Socket (Scanner.Socket, Address);
      GNAT.Sockets.Set_Socket_Option (Scanner.Socket, GNAT.Sockets.IP_Protocol_For_IP_Level,
                                      (GNAT.Sockets.Add_Membership, GNAT.Sockets.Inet_Addr (Group),
                                       GNAT.Sockets.Any_Inet_Addr));
   end Initialize;

   procedure Send (Socket  : in GNAT.Sockets.Socket_Type;
                   Content : in String;
                   To      : access GNAT.Sockets.Sock_Addr_Type) is
      Last : Ada.Streams.Stream_Element_Offset;
      Buf  : Ada.Streams.Stream_Element_Array (1 .. Content'Length);
      for Buf'Address use Content'Address;
      pragma Import (Ada, Buf);
      pragma Unreferenced (Last);
   begin
      GNAT.Sockets.Send_Socket (Socket, Buf, Last, To);
   end Send;

   --  ------------------------------
   --  Send the SSDP discovery UDP packet on the UPnP multicast group 239.255.255.250.
   --  Set the "ST" header to the given target.  The UDP packet is sent on each interface
   --  whose IP address is defined in the set <tt>IPs</tt>.
   --  ------------------------------
   procedure Send_Discovery (Scanner : in out Scanner_Type;
                             Target  : in String;
                             IPs     : in Util.Strings.Sets.Set) is
      Address : aliased GNAT.Sockets.Sock_Addr_Type;
   begin
      Address.Addr := GNAT.Sockets.Inet_Addr (Group);
      Address.Port := 1900;
      for IP of IPs loop
         GNAT.Sockets.Set_Socket_Option (Scanner.Socket, GNAT.Sockets.IP_Protocol_For_IP_Level,
                                         (GNAT.Sockets.Multicast_If,
                                          GNAT.Sockets.Inet_Addr (IP)));

         Log.Debug ("Sending SSDP search for IGD device from {0}", IP);
         Send (Scanner.Socket, "M-SEARCH * HTTP/1.1" & ASCII.CR & ASCII.LF &
                 "HOST: 239.255.255.250:1900" & ASCII.CR & ASCII.LF &
                 "ST: " & Target & ASCII.CR & ASCII.LF &
                 "MAN: ""ssdp:discover""" & ASCII.CR & ASCII.LF &
                 "MX: 2" & ASCII.CR & ASCII.LF, Address'Access);
      end loop;
   end Send_Discovery;

   procedure Receive (Socket : in GNAT.Sockets.Socket_Type;
                      Target : in String;
                      Desc   : out Ada.Strings.Unbounded.Unbounded_String) is
      function Get_Line return String;

      Data         : Ada.Streams.Stream_Element_Array (0 .. 1500);
      Last         : Ada.Streams.Stream_Element_Offset;
      Pos   : Ada.Streams.Stream_Element_Offset := Data'First;

      function Get_Line return String is
         First : constant Ada.Streams.Stream_Element_Offset := Pos;
      begin
         while Pos <= Last loop
            if Data (Pos) = 16#0D# and then Pos + 1 <= Last and then Data (Pos + 1) = 16#0A# then
               declare
                  Result : String (1 .. Natural (Pos - First));
                  P      : Natural := 1;
               begin
                  for I in First .. Pos - 1 loop
                     Result (P) := Character'Val (Data (I));
                     P := P + 1;
                  end loop;
                  Log.Debug ("L: {0}", Result);
                  Pos := Pos + 2;
                  return Result;
               end;
            end if;
            Pos := Pos + 1;
         end loop;
         return "";
      end Get_Line;

   begin
      Desc := Ada.Strings.Unbounded.To_Unbounded_String ("");
      GNAT.Sockets.Receive_Socket (Socket, Data, Last);
      if Get_Line /= "HTTP/1.1 200 OK" then
         Log.Debug ("Receive a non HTTP/1.1 response");
         return;
      end if;
      loop
         declare
            Line : constant String := Get_Line;
            Pos  : constant Natural := Util.Strings.Index (Line, ':');
            Pos2 : Natural := Pos + 1;
         begin
            exit when Pos = 0;
            while Pos2 < Line'Last and then Line (Pos2) = ' ' loop
               Pos2 := Pos2 + 1;
            end loop;
            if Line (1 .. Pos) = "ST:" then
               if Line (Pos2 .. Line'Last) /= Target then
                  return;
               end if;
            elsif Line (1 .. Pos) = "LOCATION:" then
               Desc := Ada.Strings.Unbounded.To_Unbounded_String (Line (Pos2 .. Line'Last));
               Log.Debug ("Found a IGD device: {0}", Ada.Strings.Unbounded.To_String (Desc));
               return;
            end if;
         end;
      end loop;

   exception
      when E : others =>
         Log.Error ("Exception received", E);
   end Receive;

   --  ------------------------------
   --  Receive the UPnP SSDP discovery messages for the given target.
   --  Call the <tt>Process</tt> procedure for each of them.  The <tt>Desc</tt> parameter
   --  represents the UPnP location header which gives the UPnP XML root descriptor.
   --  Wait at most the given time.
   --  ------------------------------
   procedure Discover (Scanner : in out Scanner_Type;
                       Target  : in String;
                       Process : not null access procedure (Desc : in String);
                       Wait    : in Duration) is
      use type Ada.Calendar.Time;
      use type GNAT.Sockets.Selector_Status;

      Sel      : GNAT.Sockets.Selector_Type;
      Rset     : GNAT.Sockets.Socket_Set_Type;
      Wset     : GNAT.Sockets.Socket_Set_Type;
      Status   : GNAT.Sockets.Selector_Status;
      Desc     : Ada.Strings.Unbounded.Unbounded_String;
      Deadline : constant Ada.Calendar.Time := Ada.Calendar.Clock + Wait;
      Remain   : Duration;
   begin
      GNAT.Sockets.Create_Selector (Sel);
      loop
         GNAT.Sockets.Empty (Rset);
         GNAT.Sockets.Empty (Wset);
         GNAT.Sockets.Set (Rset, Scanner.Socket);

         Remain := Deadline - Ada.Calendar.Clock;
         exit when Remain < 0.0;
         GNAT.Sockets.Check_Selector (Selector     => Sel,
                                      R_Socket_Set => Rset,
                                      W_Socket_Set => Wset,
                                      Status       => Status,
                                      Timeout      => Remain);
         exit when Status = GNAT.Sockets.Expired;
         Receive (Scanner.Socket, Target, Desc);
         declare
            URI  : constant String := Ada.Strings.Unbounded.To_String (Desc);
            Pos  : constant Natural := Util.Strings.Index (URI, ':');
         begin
            if Pos > 0 and URI (URI'First .. Pos + 2) = "http://" then
               Process (URI);
            end if;
         end;
      end loop;
   end Discover;

   --  ------------------------------
   --  Release the socket.
   --  ------------------------------
   overriding
   procedure Finalize (Scanner : in out Scanner_Type) is
      use type GNAT.Sockets.Socket_Type;
   begin
      if Scanner.Socket /= GNAT.Sockets.No_Socket then
         GNAT.Sockets.Close_Socket (Scanner.Socket);
      end if;
   end Finalize;

end UPnP.SSDP;

Implement a UPnP SSDP discovery process

Implement a UPnP SSDP discovery process


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . E N C L _ E L                           --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (C) 1995-2010, 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,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, 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  AdaCore                   --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

--  This package contains routines for computing the enclosing element
--  for the Asis.Elements.Enclosing_Element function

with Asis;

package A4G.Encl_El is

   function Corresponding_Instantiation
     (Element : Asis.Element)
      return Asis.Element;
   --  This function accepts an Element representing an expanded generic
   --  declaration as an argument and returns the generic instantiation
   --  which was expanded in the argument declaration. According to subclause
   --  15.26, this instantiation should be returned as the Enclosing_Element
   --  for the expanded generic declaration.
   --
   --  Should we move this function in Asis.Extensions?

   function Enclosing_For_Explicit_Instance_Component
     (Element : Asis.Element)
      return Asis.Element;
   --  Computes the Enclosing Element for an explicit component of an
   --  expanded generic declaration. The problem in this case is, that if
   --  the result represents the whole expanded declaration, the
   --  Special_Case field of the result should be properly set

   function Enclosing_Element_For_Explicit
     (Element : Asis.Element)
      return Asis.Element;
   --  This is the general constructor of enclosing element for explicit
   --  elements

   function Enclosing_Element_For_Implicit
     (Element : Asis.Element)
      return Asis.Element;
   --  This is the general constructor of enclosing element for implicit
   --  elements. It's only partially implemented for now.

   function Enclosing_Element_For_Limited_View
     (Element : Asis.Element)
      return Asis.Element;
   --  This is the general constructor of enclosing element for elements from
   --  limited view.

end A4G.Encl_El;

Add the ASIS file $i

Add the ASIS file $i


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

--  == REST ==
--  The <tt>ASF.Rest</tt> package provides support to implement easily some RESTful API.
package ASF.Rest is

   type Request is abstract new ASF.Requests.Request with null record;

   type Response is abstract new ASF.Responses.Response with null record;

   --  The HTTP rest method.
   type Method_Type is (GET, HEAD, POST, PUT, DELETE, OPTIONS);

   type Descriptor is abstract tagged limited private;
   type Descriptor_Access is access all Descriptor'Class;

   --  Get the permission index associated with the REST operation.
   function Get_Permission (Handler : in Descriptor)
                            return Security.Permissions.Permission_Index;

   --  Dispatch the request to the API handler.
   procedure Dispatch (Handler : in Descriptor;
                       Req     : in out ASF.Rest.Request'Class;
                       Reply   : in out ASF.Rest.Response'Class) is abstract;

private

   type Descriptor is abstract tagged limited record
      Next       : Descriptor_Access;
      Method     : Method_Type;
      Pattern    : Util.Strings.Name_Access;
      Permission : Security.Permissions.Permission_Index := 0;
   end record;

   --  Register the API descriptor in a list.
   procedure Register (List : in out Descriptor_Access;
                       Item : in Descriptor_Access);

end ASF.Rest;

Define ASF.Rest package for the server-side API REST support


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

with AWA.Users.Servlets;
with AWA.Users.Modules;
with AWA.Mail.Modules;
with AWA.Comments.Modules;
with AWA.Blogs.Modules;
with AWA.Tags.Modules;
with AWA.Storages.Modules;
with AWA.Applications;
with AWA.Workspaces.Modules;
with AWA.Wikis.Modules;
with AWA.Wikis.Previews;
with AWA.Jobs.Modules;
with AWA.Images.Modules;
with AWA.Counters.Modules;
with AWA.Services.Filters;
with AWA.Converters.Dates;

package AWA_Test_App is

   CONFIG_PATH  : constant String := "/test";
   CONTEXT_PATH : constant String := "/test";

   type Application is new AWA.Applications.Application with private;
   type Application_Access is access all Application'Class;

   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   overriding
   procedure Initialize_Servlets (App : in out Application);

   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   overriding
   procedure Initialize_Filters (App : in out Application);

   --  Initialize the AWA modules provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the modules used by the application.
   overriding
   procedure Initialize_Modules (App : in out Application);

private

   type Application is new AWA.Applications.Application with record
      Self              : Application_Access;

      --  Application servlets and filters (add new servlet and filter instances here).
      Faces             : aliased ASF.Servlets.Faces.Faces_Servlet;
      Ajax              : aliased ASF.Servlets.Ajax.Ajax_Servlet;
      Files             : aliased Servlet.Core.Files.File_Servlet;
      Dump              : aliased ASF.Filters.Dump.Dump_Filter;
      Service_Filter    : aliased AWA.Services.Filters.Service_Filter;
      Measures          : aliased Servlet.Core.Measures.Measure_Servlet;
      No_Cache          : aliased ASF.Filters.Cache_Control.Cache_Control_Filter;

      --  Authentication servlet and filter.
      Auth              : aliased ASF.Security.Servlets.Request_Auth_Servlet;
      Verify_Auth       : aliased AWA.Users.Servlets.Verify_Auth_Servlet;

      --  Converters shared by web requests.
      Rel_Date_Converter : aliased AWA.Converters.Dates.Relative_Date_Converter;
      Size_Converter     : aliased ASF.Converters.Sizes.Size_Converter;

      --  The application modules.
      User_Module       : aliased AWA.Users.Modules.User_Module;
      Workspace_Module  : aliased AWA.Workspaces.Modules.Workspace_Module;
      Blog_Module       : aliased AWA.Blogs.Modules.Blog_Module;
      Mail_Module       : aliased AWA.Mail.Modules.Mail_Module;
      Comment_Module    : aliased AWA.Comments.Modules.Comment_Module;
      Storage_Module    : aliased AWA.Storages.Modules.Storage_Module;
      Tag_Module        : aliased AWA.Tags.Modules.Tag_Module;
      Job_Module        : aliased AWA.Jobs.Modules.Job_Module;
      Image_Module      : aliased AWA.Images.Modules.Image_Module;
      Wiki_Module       : aliased AWA.Wikis.Modules.Wiki_Module;
      Preview_Module    : aliased AWA.Wikis.Previews.Preview_Module;
      Counter_Module    : aliased AWA.Counters.Modules.Counter_Module;
   end record;

end AWA_Test_App;

Add test application for awa_command test


-----------------------------------------------------------------------
--  util-encoders-kdf-pbkdf2 -- Password-Based Key Derivation Function 2, RFC 8018.
--  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;
procedure Util.Encoders.KDF.PBKDF2 (Password : in Secret_Key;
                                    Salt     : in Secret_Key;
                                    Counter  : in Positive;
                                    Result   : out Secret_Key) is
   use Interfaces;

   Total : constant Key_Length := Salt.Length + Length + 4;
   Pos   : constant Ada.Streams.Stream_Element_Offset := 1 + Salt.Secret'Last;
   First : Ada.Streams.Stream_Element_Offset := 1;
   I     : Unsigned_32 := 1;
   U     : Secret_Key (Total);
   Len   : Ada.Streams.Stream_Element_Offset;
begin
   --  RFC 8018, 5.2.  PBKDF2
   while First <= Result.Secret'Last loop
      --  Compute: U_1 = PRF (P, S || INT (i))
      U.Secret (Salt.Secret'Range) := Salt.Secret;
      U.Secret (Pos) := Stream_Element (Shift_Left (I, 24) and 16#0ff#);
      U.Secret (Pos + 1) := Stream_Element (Shift_Left (I, 16) and 16#0ff#);
      U.Secret (Pos + 2) := Stream_Element (Shift_Left (I, 8) and 16#0ff#);
      U.Secret (Pos + 3) := Stream_Element (I and 16#0ff#);
      Len := Result.Secret'Last - First + 1;
      if Len > Length then
         Len := Length;
      end if;
      Hash (Key  => Password.Secret,
            Data => U.Secret (1 .. Pos + 3),
            Into => U.Secret (1 .. Length));

      --  Compute: F (P, S, c, i) = U_1 \xor U_2 \xor ... \xor U_c
      --  With: U_c = PRF (P, U_{c-1}) .
      Result.Secret (First .. First + Len - 1) := U.Secret (1 .. Len);
      for C in 1 .. Counter - 1 loop
         Hash (Key  => Password.Secret,
               Data => U.Secret (1 .. Length),
               Into => U.Secret (1 .. Length));
         for J in 1 .. Len loop
            Result.Secret (First + J - 1) := Result.Secret (First + J - 1) xor U.Secret (J);
         end loop;
      end loop;
      I := I + 1;
      First := First + Length;
   end loop;
end Util.Encoders.KDF.PBKDF2;

Implement the PBKDF2 function

Implement the PBKDF2 function


-----------------------------------------------------------------------
--  Memory Events - Definition and Analysis of memory events
--  Copyright (C) 2014 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 MAT.Types;
with MAT.Readers.Marshaller;
with MAT.Memory;
with MAT.Events;
package body MAT.Memory.Readers is

   MSG_MALLOC  : constant MAT.Events.Internal_Reference := 0;
   MSG_FREE    : constant MAT.Events.Internal_Reference := 1;
   MSG_REALLOC : constant MAT.Events.Internal_Reference := 2;

   M_SIZE     : constant MAT.Events.Internal_Reference := 1;
   M_FRAME    : constant MAT.Events.Internal_Reference := 2;
   M_ADDR     : constant MAT.Events.Internal_Reference := 3;
   M_OLD_ADDR : constant MAT.Events.Internal_Reference := 4;
   M_THREAD   : constant MAT.Events.Internal_Reference := 5;
   M_UNKNOWN  : constant MAT.Events.Internal_Reference := 6;
   M_TIME     : constant MAT.Events.Internal_Reference := 7;
   --  Defines the possible data kinds which are recognized by
   --  the memory unmarshaller.  All others are ignored.

   SIZE_NAME  : aliased constant String := "size";
   FRAME_NAME : aliased constant String := "frame";
   ADDR_NAME  : aliased constant String := "addr";
   OLD_NAME   : aliased constant String := "old-pointer";
   THREAD_NAME : aliased constant String := "thread";
   TIME_NAME   : aliased constant String := "time";

   Memory_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => SIZE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_SIZE),
      2 => (Name => FRAME_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_FRAME),
      3 => (Name => ADDR_NAME'Access, Size => 0,
            Kind => MAT.Events.T_POINTER, Ref => M_ADDR),
      4 => (Name => OLD_NAME'Access, Size => 0,
            Kind => MAT.Events.T_POINTER, Ref => M_ADDR),
      5 => (Name => THREAD_NAME'Access, Size => 0,
            Kind => MAT.Events.T_THREAD, Ref => M_THREAD),
      6 => (Name => TIME_NAME'Access, Size => 0,
            Kind => MAT.Events.T_TIME, Ref => M_TIME));

   ----------------------
   --  Bind the servant with the object adapter to register the
   --  events it recognizes.
   ----------------------
   procedure Bind (For_Servant : in out Memory_Servant) is
   begin
      Bind_Servant (For_Servant, "malloc", MSG_MALLOC,
                    Memory_Attributes'Access);
      Bind_Servant (For_Servant, "free", MSG_FREE,
                    Memory_Attributes'Access);
      Bind_Servant (For_Servant, "realloc", MSG_REALLOC,
                    Memory_Attributes'Access);
   end Bind;

   ----------------------
   --  A memory allocation message is received.  Register the memory
   --  slot in the allocated memory list.  An event is posted on the
   --  event channel to notify the listeners that a new slot is allocated.
   ----------------------
   procedure Process_Malloc_Message (Client : in out Memory_Servant;
                                     Addr   : in MAT.Types.Target_Addr;
                                     Slot   : in Allocation) is
      Inserted : Boolean;
--        Ev       : MAT.Memory.Events.Memory_Event := (Kind => EV_MALLOC, Addr => Addr);
   begin
      Client.Data.Memory_Slots.Insert (Addr, Slot);
--        Post (Client.Event_Channel, Ev);
   end Process_Malloc_Message;

   ----------------------
   --  A memory deallocation message.  Find the memory slot being freed
   --  and remove it from the allocated list.  Post an event on the event
   --  channel to notify the listeners that the slot is removed.
   ----------------------
   procedure Process_Free_Message (Client : in out Memory_Servant;
                                   Addr   : in MAT.Types.Target_Addr;
                                   Slot   : in Allocation) is
      It : MAT.Memory.Allocation_Maps.Cursor := Client.Data.Memory_Slots.Find (Addr);
--        Ev : Memory_Event := (Kind => EV_FREE, Addr => Addr);
   begin
      if MAT.Memory.Allocation_Maps.Has_Element (It) then
         --  Address is not in the map.  The application is freeing
         --  an already freed memory or something wrong.
         null;
      end if;
--        Post (Client.Event_Channel, Ev);
      declare
         Slot : Allocation := MAT.Memory.Allocation_Maps.Element (It);
      begin
         Frames.Release (Slot.Frame);
      end;

      --  Remove the memory slot from our map.
      Client.Data.Memory_Slots.Delete (It);
   end Process_Free_Message;

   ----------------------
   --  Unmarshall from the message the memory slot information.
   --  The data is described by the Defs table.
   ----------------------
   procedure Unmarshall_Allocation (Msg      : in out MAT.Readers.Message;
                                    Slot     : in out Allocation;
                                    Addr     : in out MAT.Types.Target_Addr;
                                    Old_Addr : in out MAT.Types.Target_Addr;
                                    Defs     : in MAT.Events.Attribute_Table) is
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_SIZE =>
                  Slot.Size := MAT.Readers.Marshaller.Get_Target_Size (Msg.Buffer, Def.Kind);

               when M_ADDR =>
                  Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg.Buffer, Def.Kind);

               when M_OLD_ADDR =>
                  Old_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg.Buffer, Def.Kind);

               when M_FRAME =>
                  --  Unmarshal_Frame (Msg, Slot.Frame);
                  null;
                  pragma Assert (False, "must fix M_FRAME");

               when M_TIME =>
                  Slot.Time := MAT.Readers.Marshaller.Get_Target_Tick (Msg.Buffer, Def.Kind);

               when M_THREAD =>
                  Slot.Thread := MAT.Readers.Marshaller.Get_Target_Thread (Msg.Buffer, Def.Kind);

               when M_UNKNOWN =>
                  MAT.Readers.Marshaller.Skip (Msg.Buffer, Def.Size);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg.Buffer, Def.Size);
            end case;
         end;
      end loop;
   end Unmarshall_Allocation;

   overriding
   procedure Dispatch (For_Servant : in out Memory_Servant;
                       Id          : in MAT.Events.Internal_Reference;
                       Params      : in MAT.Events.Const_Attribute_Table_Access;
                       Msg         : in out MAT.Readers.Message) is
      Slot     : Allocation;
      Addr     : MAT.Types.Target_Addr;
      Old_Addr : MAT.Types.Target_Addr := 0;
   begin
      case Id is
         when MSG_MALLOC =>
            Unmarshall_Allocation (Msg, Slot, Addr, Old_Addr, Params.all);
            Process_Malloc_Message (For_Servant, Addr, Slot);

         when MSG_FREE =>
            Unmarshall_Allocation (Msg, Slot, Addr, Old_Addr, Params.all);
            Process_Free_Message (For_Servant, Addr, Slot);

         when MSG_REALLOC =>
            Unmarshall_Allocation (Msg, Slot, Addr, Old_Addr, Params.all);
            Process_Malloc_Message (For_Servant, Addr, Slot);
            Process_Free_Message (For_Servant, Old_Addr, Slot);

         when others =>
            raise Program_Error;

      end case;
   end Dispatch;

end MAT.Memory.Readers;

Package to read the memory events

Package to read the memory events


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

with Util.Tests;

package Security.OAuth.JWT.Tests is

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

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

   --  Test Decode operation with errors.
   procedure Test_Decode_Error (T : in out Test);

   generic
      with function Get (From : in Token) return String;
      Value : String;
   procedure Test_Operation (T : in out Test);

   generic
      with function Get (From : in Token) return Ada.Calendar.Time;
      Value : String;
   procedure Test_Time_Operation (T : in out Test);

end Security.OAuth.JWT.Tests;

Add unit tests for JWT

Add unit tests for JWT


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

with Util.Test_Caller;

package body Security.OAuth.JWT.Tests is

   package Caller is new Util.Test_Caller (Test, "Security.OAuth.JWT");

   --  A JWT token returned by Google+.
   K : constant String := "eyJhbGciOiJSUzI1NiIsImtpZCI6IjVmOTBlMWExMGE4YzgwZWJhZWNmYzM4NzBjZDl"
     & "lMGVhMGI3ZDVmZGMifQ.eyJpc3MiOiJhY2NvdW50cy5nb29nbGUuY29tIiwiYXRfaGFzaCI6Im9Ka19EYnFvb1"
     & "FVc0FhY3k2cnkxeHciLCJhdWQiOiI4NzI2NTU5OTQwMTQuYXBwcy5nb29nbGV1c2VyY29udGVudC5jb20iLCJz"
     & "dWIiOiIxMDgzNjA3MDMwOTk3MDg5Nzg4NzAiLCJlbWFpbF92ZXJpZmllZCI6InRydWUiLCJhenAiOiI4NzI2NT"
     & "U5OTQwMTQuYXBwcy5nb29nbGV1c2VyY29udGVudC5jb20iLCJlbWFpbCI6InN0ZXBoYW5lLmNhcnJlekBnbWFp"
     & "bC5jb20iLCJpYXQiOjEzNjg5NjgyMzMsImV4cCI6MTM2ODk3MjEzM30.UL1qp2wmleV-ED2A_hlqgDLIGgJB3f"
     & "_N7fiz1CgttJcwbmMVwhag3ox2WE9C1KwXhrjwT8eigZ0WkDys5WO1dYs2G1QbDZPnsYYMyHK9XpycaDMEKtVZ"
     & "C4C6DkB1SrBHbN0Tv6ExWpszzp1JEL8nZnHd3T_AA3paqONnkvQw_yo";

   procedure Test_Operation (T : in out Test) is
      R : Token;
   begin
      R := Decode (K);
      Util.Tests.Assert_Equals (T, Value, Get (R), "Extraction failed");
   end Test_Operation;

   procedure Test_Time_Operation (T : in out Test) is
      R : Token;
   begin
      R := Decode (K);
      Util.Tests.Assert_Equals (T, Value, Ada.Calendar.Formatting.Image (Get (R)),
                                "Extraction failed");
   end Test_Time_Operation;

   procedure Test_Get_Issuer is
     new Test_Operation (Get_Issuer, "accounts.google.com");
   procedure Test_Get_Audience is
     new Test_Operation (Get_Audience, "872655994014.apps.googleusercontent.com");
   procedure Test_Get_Subject is
     new Test_Operation (Get_Subject, "108360703099708978870");
   procedure Test_Get_Authorized_Presenters is
     new Test_Operation (Get_Authorized_Presenters, "872655994014.apps.googleusercontent.com");
   procedure Test_Get_Expiration is
     new Test_Time_Operation (Get_Expiration, "2013-05-19 14:02:13");
   procedure Test_Get_Issued_At is
     new Test_Time_Operation (Get_Issued_At, "2013-05-19 12:57:13");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Security.OAuth.JWT.Decode",
                       Test_Get_Issuer'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.JWT.Get_Issuer",
                       Test_Get_Issuer'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.JWT.Get_Audience",
                       Test_Get_Audience'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.JWT.Get_Subject",
                       Test_Get_Subject'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.JWT.Get_Authorized_Presenters",
                       Test_Get_Authorized_Presenters'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.JWT.Get_Expiration",
                       Test_Get_Expiration'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.JWT.Get_Authentication_Time",
                       Test_Get_Issued_At'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.JWT.Decode (error)",
                       Test_Decode_Error'Access);

   end Add_Tests;

   --  ------------------------------
   --  Test Decode operation with errors.
   --  ------------------------------
   procedure Test_Decode_Error (T : in out Test) is
      K : constant String := "eyJhbxGciOiJSUzI1NiIsImtpZCI6IjVmOTBlMWExMGE4YzgwZWJhZWNmYzM4NzBjZDl"
        & "lMGVhMGI3ZDVmZGMifQ.eyJpc3xMiOiJhY2NvdW50cy5nb29nbGUuY29tIiwiYXRfaGFzaCI6Im9Ka19EYnFvb1"
        & "FVc0FhY3k2cnkxeHciLCJhdWQiOiI4NzI2NTU5OTQwMTQuYXBwcy5nb29nbGV1c2VyY29udGVudC5jb20iLCJz"
        & "dWIiOiIxMDgzNjA3MDMwOTk3MDg5Nzg4NzAiLCJlbWFpbF92ZXJpZmllZCI6InRydWUiLCJhenAiOiI4NzI2NT"
        & "U5OTQwMTQuYXBwcy5nb29nbGV1c2VyY29udGVudC5jb20iLCJlbWFpbCI6InN0ZXBoYW5lLmNhcnJlekBnbWFp"
        & "bC5jb20iLCJpYXQiOjEzNjg5NjgyMzMsImV4cCI6MTM2ODk3MjEzM30.UL1qp2wmleV-ED2A_hlqgDLIGgJB3f"
        & "_N7fiz1CgttJcwbmMVwhag3ox2WE9C1KwXhrjwT8eigZ0WkDys5WO1dYs2G1QbDZPnsYYMyHK9XpycaDMEKtVZ"
        & "C4C6DkB1SrBHbN0Tv6ExWpszzp1JEL8nZnHd3T_AA3paqONnkvQw_yx";
      R : Token;
   begin
      R := Decode (K);
      T.Fail ("No exception raised");
      T.Assert (False, "Bad");

   exception
      when Invalid_Token =>
         null;
   end Test_Decode_Error;

end Security.OAuth.JWT.Tests;

Add unit tests for JWT extraction

Add unit tests for JWT extraction


-----------------------------------------------------------------------
--  ado-schemas-sqlite -- SQLite Database Schemas
--  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 ADO.Drivers.Connections;
package ADO.Schemas.Sqlite is

   --  Load the database schema
   procedure Load_Schema (C      : in ADO.Drivers.Connections.Database_Connection'Class;
                          Schema : out Schema_Definition);

end ADO.Schemas.Sqlite;

Package to implement the Load_Schema procedure


-----------------------------------------------------------------------
--  util-streams-texts-tr -- Text translation utilities on streams
--  Copyright (C) 2010, 2011, 2012, 2015, 2016, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Texts.Transforms;
with Ada.Characters.Handling;
package Util.Streams.Texts.TR is
  new Util.Texts.Transforms (Stream => Print_Stream'Class,
                             Char   => Character,
                             Input  => String,
                             Put    => Write_Char,
                             To_Upper => Ada.Characters.Handling.To_Upper,
                             To_Lower => Ada.Characters.Handling.To_Lower);

Refactor Buffered_Stream and Print_Stream - move the TR package instantiation in a separate file


-----------------------------------------------------------------------
--  util-streams-aes -- AES encoding and decoding streams
--  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.
-----------------------------------------------------------------------

package body Util.Streams.AES is

   --  -----------------------
   --  Set the encryption key and mode to be used.
   --  -----------------------
   procedure Set_Key (Stream : in out Encoding_Stream;
                      Data   : in Ada.Streams.Stream_Element_Array;
                      Mode   : in Util.Encoders.AES.AES_Mode := Util.Encoders.AES.CBC) is
   begin
      Stream.Transform.Set_Key (Data, Mode);
   end Set_Key;

   --  -----------------------
   --  Set the encryption initialization vector before starting the encryption.
   --  -----------------------
   procedure Set_IV (Stream  : in out Encoding_Stream;
                     IV      : in Util.Encoders.AES.Word_Block_Type) is
   begin
      Stream.Transform.Set_IV (IV);
   end Set_IV;

   --  -----------------------
   --  Set the encryption key and mode to be used.
   --  -----------------------
   procedure Set_Key (Stream : in out Decoding_Stream;
                      Data   : in Ada.Streams.Stream_Element_Array;
                      Mode   : in Util.Encoders.AES.AES_Mode := Util.Encoders.AES.CBC) is
   begin
      Stream.Transform.Set_Key (Data, Mode);
   end Set_Key;

   --  -----------------------
   --  Set the encryption initialization vector before starting the encryption.
   --  -----------------------
   procedure Set_IV (Stream  : in out Decoding_Stream;
                     IV      : in Util.Encoders.AES.Word_Block_Type) is
   begin
      Stream.Transform.Set_IV (IV);
   end Set_IV;

end Util.Streams.AES;

Implement operations to set the key and IV for AES-128/196/256 encryption and decryption streams