------------------------------------------------------------------------------
--                              Ada Web Server                              --
--                                                                          --
--                     Copyright (C) 2006-2018, AdaCore                     --
--                                                                          --
--  This library 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 3,  or (at your  option) any --
--  later version. This library is distributed in the hope that it will be  --
--  useful, but WITHOUT ANY WARRANTY;  without even the implied warranty of --
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                    --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--  You should have received a copy of the GNU General Public License and   --
--  a copy of the GCC Runtime Library Exception along with this program;    --
--  see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see   --
--  <http://www.gnu.org/licenses/>.                                         --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
------------------------------------------------------------------------------

pragma Ada_2012;

with Ada.Characters.Handling;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Containers.Ordered_Maps;
with Ada.Directories;
with Ada.Strings.Hash;
with Ada.Strings.Hash_Case_Insensitive;
with Ada.Strings.Equal_Case_Insensitive;
with Ada.Strings.Maps.Constants;
with Ada.Text_IO;
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;

with Interfaces.C.Strings;
with System.Memory;

with AWS.Config;
with AWS.Net.Log;
with AWS.Net.SSL.Certificate.Impl;
with AWS.Net.SSL.RSA_DH_Generators;
with AWS.OS_Lib;
with AWS.Resources;
with AWS.Translator;
with AWS.Utils;

package body AWS.Net.SSL is

   use Interfaces;
   use Ada.Strings;
   use Ada.Strings.Maps;

   use type C.int;
   use type C.unsigned;

   package CS renames C.Strings;

   subtype NSST is Net.Std.Socket_Type;

   subtype Datum_Type is Certificate.Impl.Datum_Type;

   function Load_File (Filename : String) return Datum_Type
     renames Certificate.Impl.Load_File;

   type PCert_Array is
     array (Positive range <>) of aliased TSSL.gnutls_pcert_st
     with Convention => C;

   DH_Params  : array (0 .. 1) of aliased TSSL.gnutls_dh_params_t
     with Atomic_Components;
   RSA_Params : array (0 .. 1) of aliased TSSL.gnutls_rsa_params_t
     with Atomic_Components;
   --  0 element for current use, 1 element for remain usage after creation new
   --  0 element.

   IP_Address_Characters : constant Character_Set :=
                             To_Set (".:") or Constants.Decimal_Digit_Set;

   function Copy (Item : TSSL.gnutls_datum_t) return TSSL.gnutls_datum_t;
   --  Creates gnutls_datum_t copy

   function Image (Item : TSSL.gnutls_datum_t) return String;

   function Lib_Alloc (Size : System.Memory.size_t) return System.Address
     with Convention => C;
   --  Set allocated data to zero to workaroung GNUTLS bug in
   --  gnutls_pcert_list_import_x509_raw when it parse file without
   --  certificate. Should be fixed in 3.3.1, 3.2.12, 3.1.22 GNUTLS versions.

   function Lib_Realloc
     (Ptr  : System.Address;
      Size : System.Memory.size_t) return System.Address
     with Convention => C;
   --  C library could use null pointer as input parameter for realloc, but
   --  gnatmem does not care about it and logging Free of the null pointer
   --  and than claiming for "Releasing deallocated memory".

   procedure Lib_Free (Ptr  : System.Address) with Convention => C;
   --  C library could put null pointer as input parameter for free, but
   --  gnatmem does not care about it and logging Free of the null pointer
   --  and than claiming for "Releasing deallocated memory".

   type PCert_Array_Access is access all PCert_Array;

   procedure Free (Datum : in out Datum_Type) with Inline;

   procedure Check_Error_Code (Code : C.int);
   procedure Check_Error_Code (Code : C.int; Socket : Socket_Type'Class);

   procedure Code_Processing
     (Code : C.int; Socket : Socket_Type'Class; Timeout : Duration);

   procedure Code_Processing (Code : C.int; Socket : Socket_Type'Class);

   procedure Check_Config (Socket : in out Socket_Type) with Inline;

   procedure Do_Handshake_Internal (Socket : Socket_Type) with Inline;
   --  The real handshake is done here

   function To_Config is new Unchecked_Conversion (System.Address, Config);

   function Write_Socket
     (S : C.int; Msg : System.Address; Len : C.int) return C.int
     with Convention => C;
   --  Would be used only on defined MSG_NOSIGNAL platforms to avoid SIGPIPE
   --  signal.

   function DB_Store
     (p1   : System.Address;
      key  : TSSL.gnutls_datum_t;
      data : TSSL.gnutls_datum_t) return C.int with Convention => C;

   function DB_Remove
     (p1 : System.Address; key : TSSL.gnutls_datum_t) return C.int
     with Convention => C;

   function DB_Retrieve
     (p1  : System.Address;
      key : TSSL.gnutls_datum_t) return TSSL.gnutls_datum_t
     with Convention => C;

   procedure Debug_Output_Default (Text : String);

   procedure SSL_Log (level : C.int; text : CS.chars_ptr)
     with Convention => C;

   procedure SSL_Log_Audit
     (sessn : TSSL.gnutls_session_t; level : C.int; text : CS.chars_ptr)
     with Convention => C;

   procedure SSL_Log_Common
     (Prefix : String; Level : C.int; text : CS.chars_ptr);

   function Equal (Left, Right : TSSL.gnutls_datum_t) return Boolean;

   function Hash (Item : TSSL.gnutls_datum_t) return Containers.Hash_Type;

   procedure Check_File (Prefix, Filename : String);
   --  Check that Filename is present, raise an exception adding
   --  Prefix in front of the message.

   type Session_Element is record
      Datum : TSSL.gnutls_datum_t;
      Birth : Calendar.Time;
   end record;

   package Session_Container is
     new Containers.Hashed_Maps
           (Key_Type        => TSSL.gnutls_datum_t,
            Element_Type    => Session_Element,
            Hash            => Hash,
            Equivalent_Keys => Equal);

   package Time_Set is
     new Containers.Ordered_Maps
           (Key_Type     => Calendar.Time,
            Element_Type => TSSL.gnutls_datum_t,
            "<"          => Calendar."<",
            "="          => Equal);

   protected type Session_Cache is

      procedure Set_Size (Size : Natural);
      --  Set the maximum cache size

      function Get_Size return Natural;
      --  Get the maximum cache size

      function Length return Natural;
      --  Returns number of sessions currently in cache

      procedure Put (Key, Data : TSSL.gnutls_datum_t);

      function Get (Key : TSSL.gnutls_datum_t) return TSSL.gnutls_datum_t;

      procedure Drop (Key : TSSL.gnutls_datum_t);

      procedure Clear;

   private
      Size : Natural := Natural'Last;
      Map  : Session_Container.Map;
      DTI  : Time_Set.Map; --  To remove oldest sessions to fit Size
   end Session_Cache;

   type Certificate_Holder is record
      PCerts : PCert_Array_Access;
      TLS_PK : aliased TSSL.gnutls_privkey_t;
   end record;

   package Host_Certificates is new Ada.Containers.Indefinite_Hashed_Maps
     (String, Certificate_Holder, Hash => Hash_Case_Insensitive,
      Equivalent_Keys => Equal_Case_Insensitive);

   type TS_SSL is record
      CC             : aliased TSSL.gnutls_certificate_credentials_t;
      PCert_Lists    : Host_Certificates.Map;
      Priority_Cache : aliased TSSL.gnutls_priority_t;
      Ticket_Support : Boolean;
      Ticket_Key     : aliased TSSL.gnutls_datum_t := (System.Null_Address, 0);
      Sessions       : Session_Cache;
      RCC            : Boolean := False; -- Request client certificate
      CREQ           : Boolean := False; -- Certificate is required
      Verify_CB      : Net.SSL.Certificate.Verify_Callback;
      CRL_File       : C.Strings.chars_ptr := C.Strings.Null_Ptr;
      CRL_Semaphore  : Utils.Semaphore;
      CRL_Time_Stamp : Calendar.Time := Utils.AWS_Epoch;
   end record;

   procedure Initialize
     (Config               : in out TS_SSL;
      Certificate_Filename : String;
      Security_Mode        : Method;
      Priorities           : String;
      Ticket_Support       : Boolean;
      Key_Filename         : String;
      Exchange_Certificate : Boolean;
      Certificate_Required : Boolean;
      Trusted_CA_Filename  : String;
      CRL_Filename         : String;
      Session_Cache_Size   : Natural);

   procedure Add_Host_Certificate
     (Config               : in out TS_SSL;
      Host                 : String;
      Certificate_Filename : String;
      Key_Filename         : String);

   procedure Session_Client (Socket : in out Socket_Type; Host : String);
   procedure Session_Server (Socket : in out Socket_Type);
   --  Bind the SSL socket handle with the socket

   procedure Session_Transport (Socket : in out Socket_Type);

   function Verify_Callback (Session : TSSL.gnutls_session_t) return C.int
     with Convention => C;

   procedure Finalize (Config : in out TS_SSL);

   Default_Config : aliased TS_SSL;

   protected Default_Config_Sync is

      procedure Create;
      --  Create default config with default parameters

      procedure Initialize
        (Certificate_Filename : String;
         Security_Mode        : Method;
         Priorities           : String;
         Ticket_Support       : Boolean;
         Key_Filename         : String;
         Exchange_Certificate : Boolean;
         Certificate_Required : Boolean;
         Trusted_CA_Filename  : String;
         CRL_Filename         : String;
         Session_Cache_Size   : Natural);

   private
      Done : Boolean := False;
   end Default_Config_Sync;

   procedure Initialize_Default_Config;
   --  Initializes default config. It could be called more then once, because
   --  secondary initialization is ignored.

   procedure Secure
     (Source : Net.Socket_Type'Class;
      Target : out Socket_Type;
      Config : SSL.Config);
   --  Make Target a secure socket for Source using the given configuration

   function Retrieve_Certificate
     (Session         : TSSL.gnutls_session_t;
      req_ca_rdn      : access constant TSSL.gnutls_datum_t;
      nreqs           : C.int;
      pk_algos        : access constant TSSL.gnutls_pk_algorithm_t;
      pk_algos_length : C.int;
      pcert           : access TSSL.a_gnutls_pcert_st;
      pcert_length    : access C.unsigned;
      privkey         : access TSSL.gnutls_privkey_t) return C.int
      with Convention => C;

   function Params_Callback
     (Sessn  : TSSL.gnutls_session_t;
      Kind   : TSSL.gnutls_params_type_t;
      Params : access TSSL.gnutls_params_st) return C.int
     with Convention => C;
   --  Callback to give Diffie-Hellman and/or RSA parameters

   -------------------------
   -- Abort_DH_Generation --
   -------------------------

   procedure Abort_DH_Generation is
   begin
      Abort_DH_Flag := True;
   end Abort_DH_Generation;

   -------------------
   -- Accept_Socket --
   -------------------

   overriding procedure Accept_Socket
     (Socket : Net.Socket_Type'Class; New_Socket : in out Socket_Type) is
   begin
      loop
         Net.Std.Accept_Socket (Socket, NSST (New_Socket));
         Session_Server (New_Socket);

         begin
            Do_Handshake (New_Socket);
            exit;
         exception
            when Socket_Error =>
               New_Socket.Shutdown;
         end;
      end loop;
   end Accept_Socket;

   --------------------------
   -- Add_Host_Certificate --
   --------------------------

   procedure Add_Host_Certificate
     (Config               : SSL.Config;
      Host                 : String;
      Certificate_Filename : String;
      Key_Filename         : String := "") is
   begin
      Add_Host_Certificate
        (Config.all, Host, Certificate_Filename, Key_Filename);
   end Add_Host_Certificate;

   procedure Add_Host_Certificate
     (Config               : in out TS_SSL;
      Host                 : String;
      Certificate_Filename : String;
      Key_Filename         : String)
   is
      Cert     : aliased Datum_Type;
      Key      : aliased Datum_Type;
      TLS_PK   : aliased TSSL.gnutls_privkey_t;

      Password : constant String :=
        Net.SSL.Certificate.Get_Password
          (if Key_Filename = "" then Certificate_Filename else Key_Filename);

      Pwd : CS.chars_ptr :=
        (if Password = "" then CS.Null_Ptr else CS.New_String (Password));

      function Load_PCert_List (Try_Size : Positive) return PCert_Array;

      procedure Final;
      Drop : Utils.Finalizer (Final'Access) with Unreferenced;

      -----------
      -- Final --
      -----------

      procedure Final is
      begin
         CS.Free (Pwd);
         Free (Cert);

         if Key_Filename /= "" then
            Free (Key);
         end if;
      end Final;

      ---------------------
      -- Load_PCert_List --
      ---------------------

      function Load_PCert_List (Try_Size : Positive) return PCert_Array is
         Result : PCert_Array (1 .. Try_Size);
         Size   : aliased C.unsigned := C.unsigned (Try_Size);

         RC : constant C.int :=
           TSSL.gnutls_pcert_list_import_x509_raw
             (Result (1)'Access,
              Size'Access,
              Cert.Datum'Unchecked_Access,
              TSSL.GNUTLS_X509_FMT_PEM,
              TSSL.GNUTLS_X509_CRT_LIST_IMPORT_FAIL_IF_EXCEED);
      begin
         if RC = TSSL.GNUTLS_E_SHORT_MEMORY_BUFFER then
            return Load_PCert_List (Positive (Size));
         else
            Check_Error_Code (RC);
         end if;

         return Result (1 .. Positive (Size));
      end Load_PCert_List;

   begin
      Check_File ("Certificate", Certificate_Filename);

      Cert := Load_File (Certificate_Filename);

      if Key_Filename = "" then
         Key := Cert;
      else
         Check_File ("Key", Key_Filename);
         Key := Load_File (Key_Filename);
      end if;

      Check_Error_Code (TSSL.gnutls_privkey_init (TLS_PK'Access));
      Check_Error_Code
        (TSSL.gnutls_privkey_import_x509_raw
           (TLS_PK, Key.Datum'Unchecked_Access, TSSL.GNUTLS_X509_FMT_PEM, Pwd,
            0));

      Config.PCert_Lists.Insert
        (Host, (new PCert_Array'(Load_PCert_List (4)), TLS_PK));
   end Add_Host_Certificate;

   ------------------
   -- Check_Config --
   ------------------

   procedure Check_Config (Socket : in out Socket_Type) is
   begin
      if Socket.Config = null then
         Initialize_Default_Config;
         Socket.Config := Default_Config'Access;
      end if;
   end Check_Config;

   ----------------------
   -- Check_Error_Code --
   ----------------------

   procedure Check_Error_Code (Code : C.int; Socket : Socket_Type'Class) is
   begin
      if Code /= 0 then
         Raise_Socket_Error
           (Socket, C.Strings.Value (TSSL.gnutls_strerror (Code)));
      end if;
   end Check_Error_Code;

   procedure Check_Error_Code (Code : C.int) is
   begin
      if Code /= 0 then
         Raise_Socket_Error
           (Socket_Type'(Std.Socket_Type with others => <>),
            C.Strings.Value (TSSL.gnutls_strerror (Code)));
      end if;
   end Check_Error_Code;

   ----------------
   -- Check_File --
   ----------------

   procedure Check_File (Prefix, Filename : String) is
      use type Directories.File_Kind;
   begin
      if Directories.Kind (Filename) /= Directories.Ordinary_File then
         raise Socket_Error
           with Prefix & " file """ & Filename & """ error.";
      end if;
   end Check_File;

   ------------------------
   -- Cipher_Description --
   ------------------------

   overriding function Cipher_Description (Socket : Socket_Type) return String
   is
      use TSSL;
   begin
      return CS.Value (gnutls_cipher_get_name (gnutls_cipher_get (Socket.SSL)))
        & ' ' & CS.Value
                  (gnutls_protocol_get_name
                     (gnutls_protocol_get_version (Socket.SSL)))
        & ' ' & CS.Value (gnutls_kx_get_name (gnutls_kx_get (Socket.SSL)))
        & ' ' & CS.Value (gnutls_mac_get_name (gnutls_mac_get (Socket.SSL)));
   end Cipher_Description;

   -------------
   -- Ciphers --
   -------------

   procedure Ciphers (Cipher : not null access procedure (Name : String)) is
      use type CS.chars_ptr;
      Name    : CS.chars_ptr;
      cs_id   : array (0 .. 1) of aliased C.unsigned_char;
      kx      : aliased TSSL.gnutls_kx_algorithm_t;
      ciph    : aliased TSSL.gnutls_cipher_algorithm_t;
      mac     : aliased TSSL.gnutls_mac_algorithm_t;
      min_ver : aliased TSSL.gnutls_protocol_t;
   begin
      for J in 0 .. C.size_t'Last loop
         Name := TSSL.gnutls_cipher_suite_info
                   (J, cs_id (0)'Access, kx'Access, ciph'Access, mac'Access,
                    min_ver'Access);

         exit when Name = CS.Null_Ptr;

         Cipher (Utils.Hex (C.unsigned_char'Pos (cs_id (0)), 2)
            & ' ' & Utils.Hex (C.unsigned_char'Pos (cs_id (1)), 2)
            & ' ' & CS.Value (TSSL.gnutls_protocol_get_name (min_ver))
            & ' ' & CS.Value (TSSL.gnutls_kx_get_name (kx))
            & ' ' & CS.Value (TSSL.gnutls_cipher_get_name (ciph))
            & ' ' & CS.Value (TSSL.gnutls_mac_get_name (mac)));
      end loop;
   end Ciphers;

   -------------------------
   -- Clear_Session_Cache --
   -------------------------

   procedure Clear_Session_Cache (Config : SSL.Config := Null_Config) is
   begin
      if Config = Null_Config then
         Default_Config.Sessions.Clear;
      else
         Config.Sessions.Clear;
      end if;
   end Clear_Session_Cache;

   ---------------------
   -- Code_Processing --
   ---------------------

   procedure Code_Processing
     (Code : C.int; Socket : Socket_Type'Class; Timeout : Duration) is
   begin
      case Code is
         when TSSL.GNUTLS_E_INTERRUPTED | TSSL.GNUTLS_E_AGAIN =>
            case TSSL.gnutls_record_get_direction (Socket.SSL) is
               when 0      => Wait_For (Input, Socket, Timeout);
               when 1      => Wait_For (Output, Socket, Timeout);
               when others =>
                  Log_Error ("Unexpected gnutls_record_get_direction result");
                  raise Program_Error;
            end case;

         when others =>
            Check_Error_Code (Code, Socket);
      end case;
   end Code_Processing;

   procedure Code_Processing (Code : C.int; Socket : Socket_Type'Class) is
   begin
      Code_Processing (Code, Socket, Net.Socket_Type (Socket).Timeout);
   end Code_Processing;

   -------------
   -- Connect --
   -------------

   overriding procedure Connect
     (Socket : in out Socket_Type;
      Host   : String;
      Port   : Positive;
      Wait   : Boolean     := True;
      Family : Family_Type := Family_Unspec) is
   begin
      Net.Std.Connect (NSST (Socket), Host, Port, Wait, Family);

      Session_Client (Socket, Host);

      if Wait then
         Do_Handshake (Socket);
      end if;
   end Connect;

   ----------
   -- Copy --
   ----------

   function Copy (Item : TSSL.gnutls_datum_t) return TSSL.gnutls_datum_t is
      Result : TSSL.gnutls_datum_t;

      type Array_Access is access
        all Stream_Element_Array (1 .. Stream_Element_Offset (Item.size));

      function To_Array is
        new Unchecked_Conversion (TSSL.a_unsigned_char_t, Array_Access);

   begin
      if Item.size = 0 then
         return Item;
      end if;

      Result.data := TSSL.gnutls_malloc (C.size_t (Item.size));
      Result.size := Item.size;
      To_Array (Result.data).all := To_Array (Item.data).all;

      return Result;
   end Copy;

   ---------------
   -- DB_Remove --
   ---------------

   function DB_Remove
     (p1 : System.Address; key : TSSL.gnutls_datum_t) return C.int
   is
      Cfg : constant Config := To_Config (p1);
   begin
      if Debug_Output /= null then
         Debug_Output ("Remove session " & Image (key) & ASCII.LF);
      end if;

      Cfg.Sessions.Drop (key);
      return 0;
   exception
      when E : others =>
         Log_Error (Exception_Information (E));
         return 1;
   end DB_Remove;

   -----------------
   -- DB_Retrieve --
   -----------------

   function DB_Retrieve
     (p1  : System.Address;
      key : TSSL.gnutls_datum_t) return TSSL.gnutls_datum_t
   is
      Cfg : constant Config := To_Config (p1);
   begin
      if Debug_Output /= null then
         Debug_Output ("Retrieve session " & Image (key) & ASCII.LF);
      end if;

      return Copy (Cfg.Sessions.Get (key));
   exception
      when E : others =>
         Log_Error (Exception_Information (E));
         return (System.Null_Address, 0);
   end DB_Retrieve;

   --------------
   -- DB_Store --
   --------------

   function DB_Store
     (p1   : System.Address;
      key  : TSSL.gnutls_datum_t;
      data : TSSL.gnutls_datum_t) return C.int
   is
      Cfg : constant Config := To_Config (p1);
   begin
      if Debug_Output /= null then
         Debug_Output ("Store session " & Image (key) & ASCII.LF);
      end if;

      Cfg.Sessions.Put (key, data);

      return 0;
   exception
      when E : others =>
         Log_Error (Exception_Information (E));
         return 1;
   end DB_Store;

   --------------------------
   -- Debug_Output_Default --
   --------------------------

   procedure Debug_Output_Default (Text : String) is
   begin
      Text_IO.Put (Text_IO.Current_Error, Text);
   end Debug_Output_Default;

   -------------------------
   -- Default_Config_Sync --
   -------------------------

   protected body Default_Config_Sync is

      ------------
      -- Create --
      ------------

      procedure Create is
         package CNF renames AWS.Config;
         Default : CNF.Object renames CNF.Default_Config;
      begin
         if not Done then
            Initialize
              (Config               => Default_Config,
               Certificate_Filename => CNF.Certificate (Default),
               Security_Mode        => Method'Value
                                         (CNF.Security_Mode (Default)),
               Priorities           => CNF.Cipher_Priorities (Default),
               Ticket_Support       => CNF.TLS_Ticket_Support (Default),
               Key_Filename         => CNF.Key (Default),
               Exchange_Certificate => CNF.Exchange_Certificate (Default),
               Certificate_Required => CNF.Certificate_Required (Default),
               Trusted_CA_Filename  => CNF.Trusted_CA (Default),
               CRL_Filename         => CNF.CRL_File (Default),
               Session_Cache_Size   => 16#4000#);
            Done := True;
         end if;
      end Create;

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

      procedure Initialize
        (Certificate_Filename : String;
         Security_Mode        : Method;
         Priorities           : String;
         Ticket_Support       : Boolean;
         Key_Filename         : String;
         Exchange_Certificate : Boolean;
         Certificate_Required : Boolean;
         Trusted_CA_Filename  : String;
         CRL_Filename         : String;
         Session_Cache_Size   : Natural) is
      begin
         if not Done then
            Initialize
              (Default_Config,
               Certificate_Filename,  Security_Mode, Priorities,
               Ticket_Support, Key_Filename, Exchange_Certificate,
               Certificate_Required, Trusted_CA_Filename, CRL_Filename,
               Session_Cache_Size);
            Done := True;
         end if;
      end Initialize;

   end Default_Config_Sync;

   ------------------
   -- Do_Handshake --
   ------------------

   procedure Do_Handshake (Socket : in out Socket_Type) is
   begin
      Do_Handshake_Internal (Socket);
   end Do_Handshake;

   ---------------------------
   -- Do_Handshake_Internal --
   ---------------------------

   procedure Do_Handshake_Internal (Socket : Socket_Type) is
      Code : C.int;
   begin
      if Socket.IO.Handshaken.all then
         return;
      end if;

      loop
         Code := TSSL.gnutls_handshake (Socket.SSL);

         exit when Code = TSSL.GNUTLS_E_SUCCESS;

         if Debug_Output /= null and then Socket.Get_FD /= No_Socket then
            Debug_Output
              ("Handshake" & Socket.Get_Port'Img & Socket.Peer_Port'Img
               & Socket.Get_FD'Img & Code'Img & ASCII.LF);
         end if;

         Code_Processing (Code, Socket);
      end loop;

      Socket.IO.Handshaken.all := True;
   end Do_Handshake_Internal;

   -----------
   -- Equal --
   -----------

   function Equal (Left, Right : TSSL.gnutls_datum_t) return Boolean is
      type Array_Access is
        access all Stream_Element_Array (1 .. Stream_Element_Offset'Last);
      function To_Array is
        new Unchecked_Conversion (TSSL.a_unsigned_char_t, Array_Access);
   begin
      return Left.size = Right.size
        and then
          To_Array (Left.data) (1 .. Stream_Element_Offset (Left.size))
            = To_Array (Right.data) (1 .. Stream_Element_Offset (Right.size));
   end Equal;

   --------------
   -- Finalize --
   --------------

   procedure Finalize (Config : in out TS_SSL) is
      use type TSSL.gnutls_certificate_credentials_t;
      use type TSSL.gnutls_priority_t;

      procedure Unchecked_Free is
        new Unchecked_Deallocation (PCert_Array, PCert_Array_Access);

   begin
      if Config.CC /= null then
         TSSL.gnutls_certificate_free_credentials (Config.CC);
         Config.CC := null;
      end if;

      for Cert of Config.PCert_Lists loop
         for C of Cert.PCerts.all loop
            TSSL.gnutls_pcert_deinit (C);
         end loop;

         Unchecked_Free (Cert.PCerts);
         TSSL.gnutls_privkey_deinit (Cert.TLS_PK);
      end loop;

      if Config.Priority_Cache /= null then
         TSSL.gnutls_priority_deinit (Config.Priority_Cache);
         Config.Priority_Cache := null;
      end if;

      TSSL.gnutls_free (Config.Ticket_Key.data);
      Config.Ticket_Key.data := System.Null_Address;

      Config.Sessions.Clear;
   end Finalize;

   ----------
   -- Free --
   ----------

   overriding procedure Free (Socket : in out Socket_Type) is
      use type TSSL.gnutls_session_t;
      procedure Unchecked_Free is new
        Unchecked_Deallocation (Boolean, TSSL.Boolean_Access);
   begin
      if Socket.SSL /= null then
         TSSL.gnutls_deinit (Socket.SSL);
         Socket.SSL := null;
      end if;

      Unchecked_Free (Socket.IO.Handshaken);
      Net.Std.Free (NSST (Socket));
   end Free;

   procedure Free (Datum : in out Datum_Type) is
   begin
      Utils.Unchecked_Free (Datum.Data);
   end Free;

   procedure Free (Session : in out Session_Type) is
      procedure Unchecked_Free is
        new Unchecked_Deallocation (TSSL.Session_Record, Session_Type);
   begin
      if Session = null then
         return;
      end if;

      TSSL.gnutls_free (Session.Data.data);
      Unchecked_Free (Session);
   end Free;

   procedure Free (Key : in out Private_Key) is
   begin
      if Key /= null then
         TSSL.gnutls_privkey_deinit (TSSL.Private_Key (Key));
         Key := null;
      end if;
   end Free;

   -----------------
   -- Generate_DH --
   -----------------

   procedure Generate_DH is
      use type TSSL.gnutls_dh_params_t;

      New_One : aliased TSSL.gnutls_dh_params_t;
      OK      : Boolean;
      Bits    : C.unsigned;

      function Loaded return Boolean;

      procedure Save;

      ------------
      -- Loaded --
      ------------

      function Loaded return Boolean is
         Filename : constant String :=
                      RSA_DH_Generators.Parameters_Filename
                        ("dh-" & Utils.Image (Integer (Bits)), Exist => True);
         Datum    : Datum_Type;
      begin
         if Filename = "" then
            return False;
         end if;

         Datum := Load_File (Filename);

         Check_Error_Code
           (TSSL.gnutls_dh_params_import_pkcs3
              (New_One, Datum.Datum'Unchecked_Access,
               TSSL.GNUTLS_X509_FMT_PEM));

         Free (Datum);

         DH_Time (DH_Time_Idx + 1) := Resources.File_Timestamp (Filename);
         DH_Time_Idx := DH_Time_Idx + 1;

         return True;
      end Loaded;

      ----------
      -- Save --
      ----------

      procedure Save is
         Filename : constant String :=
                      RSA_DH_Generators.Parameters_Filename
                        ("dh-" & Utils.Image (Integer (Bits)), Exist => False);
         Data     : String (1 .. 4096);
         Last     : aliased C.size_t := Data'Length;
         File     : Text_IO.File_Type;
      begin
         if Filename = "" then
            return;
         end if;

         Check_Error_Code
           (TSSL.gnutls_dh_params_export_pkcs3
              (New_One, TSSL.GNUTLS_X509_FMT_PEM, Data'Address,
               Last'Unchecked_Access));

         Text_IO.Create
           (File, Text_IO.Out_File, Filename, Form => "shared=no");

         Text_IO.Put (File, Data (1 .. Natural (Last)));

         Text_IO.Close (File);
      end Save;

   begin
      DH_Lock.Try_Lock (OK);

      if not OK then
         --  Already in concurrent generation
         return;
      end if;

      Check_Error_Code (TSSL.gnutls_dh_params_init (New_One'Access));

      Bits := TSSL.gnutls_sec_param_to_pk_bits
                (TSSL.GNUTLS_PK_DH, TSSL.GNUTLS_SEC_PARAM_NORMAL);

      if DH_Params (0) /= null or else not Loaded then
         Check_Error_Code (TSSL.gnutls_dh_params_generate2 (New_One, Bits));
         DH_Time (DH_Time_Idx + 1) := Calendar.Clock;
         DH_Time_Idx := DH_Time_Idx + 1;
         Save;
      end if;

      TSSL.gnutls_dh_params_deinit (DH_Params (1));

      DH_Params (1) := DH_Params (0);
      DH_Params (0) := New_One;

      DH_Lock.Unlock;
   end Generate_DH;

   ------------------
   -- Generate_RSA --
   ------------------

   procedure Generate_RSA is
      New_One : aliased TSSL.gnutls_rsa_params_t;
      OK      : Boolean;
   begin
      RSA_Lock.Try_Lock (OK);

      if not OK then
         --  Already in concurrent generation
         return;
      end if;

      Check_Error_Code (TSSL.gnutls_x509_privkey_init (New_One'Access));
      Check_Error_Code
        (TSSL.gnutls_x509_privkey_generate
           (New_One, TSSL.GNUTLS_PK_RSA,
            TSSL.gnutls_sec_param_to_pk_bits
              (TSSL.GNUTLS_PK_RSA, TSSL.GNUTLS_SEC_PARAM_NORMAL), 0));

      TSSL.gnutls_x509_privkey_deinit (RSA_Params (1));

      RSA_Params (1) := RSA_Params (0);
      RSA_Params (0) := New_One;

      RSA_Time (RSA_Time_Idx + 1) := Calendar.Clock;
      RSA_Time_Idx := RSA_Time_Idx + 1;

      RSA_Lock.Unlock;
   end Generate_RSA;

   ----------
   -- Hash --
   ----------

   function Hash
     (Item : TSSL.gnutls_datum_t) return Containers.Hash_Type
   is
      type String_Access is access all String (Positive);
      function To_Access is
        new Unchecked_Conversion (TSSL.a_unsigned_char_t, String_Access);
   begin
      return Strings.Hash
        (To_Access (Item.data) (1 .. Natural (Item.size)));
   end Hash;

   -----------
   -- Image --
   -----------

   function Image (Item : TSSL.gnutls_datum_t) return String is
      type String_Access is access all String (1 .. Natural (Item.size));

      function To_Access is
        new Unchecked_Conversion (TSSL.a_unsigned_char_t, String_Access);

      Src    : constant String_Access := To_Access (Item.data);
      Result : String (1 .. Natural (Item.size) * 2);

   begin
      if System."=" (Item.data, System.Null_Address) then
         return "";
      end if;

      for J in 1 .. Natural (Item.size) loop
         Result (J * 2 - 1 .. J * 2) :=
           Ada.Characters.Handling.To_Lower
             (Utils.Hex (Character'Pos (Src (J)), 2));
      end loop;

      return Result;
   end Image;

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

   procedure Initialize
     (Config               : in out SSL.Config;
      Certificate_Filename : String;
      Security_Mode        : Method     := TLS;
      Priorities           : String     := "";
      Ticket_Support       : Boolean    := False;
      Key_Filename         : String     := "";
      Exchange_Certificate : Boolean    := False;
      Certificate_Required : Boolean    := False;
      Trusted_CA_Filename  : String     := "";
      CRL_Filename         : String     := "";
      Session_Cache_Size   : Natural    := 16#4000#) is
   begin
      if Config = null then
         Config := new TS_SSL;
      end if;

      Initialize
        (Config.all,
         Certificate_Filename => Certificate_Filename,
         Security_Mode        => Security_Mode,
         Priorities           => Priorities,
         Ticket_Support       => Ticket_Support,
         Key_Filename         => Key_Filename,
         Exchange_Certificate => Exchange_Certificate,
         Certificate_Required => Certificate_Required,
         Trusted_CA_Filename  => Trusted_CA_Filename,
         CRL_Filename         => CRL_Filename,
         Session_Cache_Size   => Session_Cache_Size);
   end Initialize;

   procedure Initialize
     (Config               : in out TS_SSL;
      Certificate_Filename : String;
      Security_Mode        : Method;
      Priorities           : String;
      Ticket_Support       : Boolean;
      Key_Filename         : String;
      Exchange_Certificate : Boolean;
      Certificate_Required : Boolean;
      Trusted_CA_Filename  : String;
      CRL_Filename         : String;
      Session_Cache_Size   : Natural)
   is
      procedure Set_Certificate;
      --  Set credentials from Cetificate_Filename and Key_Filename

      function Get_Priorities return String;
      --  Returns the Priorities string from Initialize of a default one
      --  depending on the Security_Mode.

      --------------------
      -- Get_Priorities --
      --------------------

      function Get_Priorities return String is
      begin
         if Priorities /= "" then
            return Priorities;

         else
            case Security_Mode is
               when TLS | TLS_Server | TLS_Client =>
                  return "NORMAL";

               when TLSv1 | TLSv1_Server | TLSv1_Client =>
                  return "NORMAL:-VERS-TLS-ALL:+VERS-TLS1.0";

               when TLSv1_1 | TLSv1_1_Server | TLSv1_1_Client =>
                  return "NORMAL:-VERS-TLS-ALL:+VERS-TLS1.1";

               when TLSv1_2 | TLSv1_2_Server | TLSv1_2_Client =>
                  return "NORMAL:-VERS-TLS-ALL:+VERS-TLS1.2";

            end case;
         end if;
      end Get_Priorities;

      ---------------------
      -- Set_Certificate --
      ---------------------

      procedure Set_Certificate is

         procedure Final;

         Trust_CA : aliased Datum_Type;
         Drop     : Utils.Finalizer (Final'Access) with Unreferenced;

         -----------
         -- Final --
         -----------

         procedure Final is
         begin
            Free (Trust_CA);
         end Final;

      begin
         Add_Host_Certificate (Config, "", Certificate_Filename, Key_Filename);

         TSSL.gnutls_certificate_set_retrieve_function2
           (Config.CC, Retrieve_Certificate'Access);

         if Trusted_CA_Filename /= "" then
            Check_File ("CA", Trusted_CA_Filename);
            Trust_CA := Load_File (Trusted_CA_Filename);

            if TSSL.gnutls_certificate_set_x509_trust_mem
              (Config.CC, Trust_CA.Datum'Unchecked_Access,
               TSSL.GNUTLS_X509_FMT_PEM) = -1
            then
               raise Socket_Error
                 with "cannot set CA file " & Trusted_CA_Filename;
            end if;
         end if;
      end Set_Certificate;

   begin -- Initialize
      Config.Sessions.Set_Size (Session_Cache_Size);
      Config.Ticket_Support := Ticket_Support;

      Check_Error_Code
        (TSSL.gnutls_certificate_allocate_credentials (Config.CC'Access));
      --  Looks like it is possible to use gnutls_certificate_credentials_t
      --  on client side without certificate assigned. See
      --  "Simple client example with X.509 certificate support" example
      --  at http://www.gnutls.org/manual/html_node
      --  Commented code
      --  /* If client holds a certificate it can be set using the following:
      --   *
      --   gnutls_certificate_set_x509_key_file (xcred,
      --   "cert.pem", "key.pem",
      --   GNUTLS_X509_FMT_PEM);
      --   */

      if Certificate_Filename /= "" then
         Set_Certificate;
      end if;

      if Security_Mode = SSLv23
        or else Security_Mode = TLSv1
        or else Security_Mode = TLSv1_1
        or else Security_Mode = TLSv1_2
        or else Security_Mode = SSLv3
        or else Security_Mode = SSLv23_Server
        or else Security_Mode = TLSv1_Server
        or else Security_Mode = TLSv1_1_Server
        or else Security_Mode = TLSv1_2_Server
        or else Security_Mode = SSLv3_Server
      then
         Config.RCC := Exchange_Certificate;
         Config.CREQ := Certificate_Required;

         if Ticket_Support then
            Check_Error_Code
              (TSSL.gnutls_session_ticket_key_generate
                 (Config.Ticket_Key'Access));
         end if;

         TSSL.gnutls_certificate_set_params_function
           (Config.CC, Params_Callback'Access);
      end if;

      TSSL.gnutls_certificate_set_verify_function
        (cred => Config.CC, func => Verify_Callback'Access);

      if CRL_Filename /= "" then
         Config.CRL_File := C.Strings.New_String (CRL_Filename);
      end if;

      declare
         GP : constant String := Get_Priorities;
         Pr : aliased C.char_array := C.To_C (GP);
         Pp : CS.chars_ptr;
         Er : aliased CS.chars_ptr;
         RC : C.int;
      begin
         if GP /= "" then
            Pp := CS.To_Chars_Ptr (Pr'Unchecked_Access);
         end if;

         RC := TSSL.gnutls_priority_init
                 (priority_cache => Config.Priority_Cache'Access,
                  priorities     => Pp,
                  err_pos        => Er'Access);

         if RC = TSSL.GNUTLS_E_INVALID_REQUEST then
            Log_Error ("Priority syntax error '" & CS.Value (Er) & ''');
         else
            Check_Error_Code (RC);
         end if;
      end;
   end Initialize;

   -------------------------------
   -- Initialize_Default_Config --
   -------------------------------

   procedure Initialize_Default_Config
     (Certificate_Filename : String;
      Security_Mode        : Method   := TLS;
      Priorities           : String   := "";
      Ticket_Support       : Boolean  := False;
      Key_Filename         : String   := "";
      Exchange_Certificate : Boolean  := False;
      Certificate_Required : Boolean  := False;
      Trusted_CA_Filename  : String   := "";
      CRL_Filename         : String   := "";
      Session_Cache_Size   : Natural  := 16#4000#) is
   begin
      Default_Config_Sync.Initialize
        (Certificate_Filename, Security_Mode, Priorities, Ticket_Support,
         Key_Filename, Exchange_Certificate, Certificate_Required,
         Trusted_CA_Filename, CRL_Filename, Session_Cache_Size);
   end Initialize_Default_Config;

   procedure Initialize_Default_Config is
   begin
      Default_Config_Sync.Create;
   end Initialize_Default_Config;

   ---------------
   -- Lib_Alloc --
   ---------------

   function Lib_Alloc (Size : System.Memory.size_t) return System.Address is
      type Binary_Access is
        access all Stream_Element_Array (1 .. Stream_Element_Offset (Size));
      function To_Access is
        new Unchecked_Conversion (System.Address, Binary_Access);
      Result : constant System.Address := System.Memory.Alloc (Size);
   begin
      To_Access (Result).all := (others => 0);
      return Result;
   end Lib_Alloc;

   --------------
   -- Lib_Free --
   --------------

   procedure Lib_Free (Ptr  : System.Address) is
      use System;
   begin
      if Ptr /= Null_Address then
         Memory.Free (Ptr);
      end if;
   end Lib_Free;

   -----------------
   -- Lib_Realloc --
   -----------------

   function Lib_Realloc
     (Ptr  : System.Address;
      Size : System.Memory.size_t) return System.Address
   is
      use System;
   begin
      if Ptr = Null_Address then
         return Lib_Alloc (Size);
      else
         return Memory.Realloc (Ptr, Size);
      end if;
   end Lib_Realloc;

   ----------
   -- Load --
   ----------

   function Load (Filename : String) return Private_Key is
      Data : Datum_Type := Load_File (Filename);
      Key  : aliased TSSL.Private_Key;
   begin
      Check_Error_Code (TSSL.gnutls_privkey_init (Key'Access));
      Check_Error_Code
        (TSSL.gnutls_privkey_import_x509_raw
           (Key, Data.Datum'Unchecked_Access, TSSL.GNUTLS_X509_FMT_PEM,
            CS.Null_Ptr, 0));

      Free (Data);

      return Private_Key (Key);
   end Load;

   ---------------
   -- Log_Error --
   ---------------

   procedure Log_Error (Text : String) is
   begin
      Log.Error (Socket_Type'(Std.Socket_Type with others => <>), Text);
   end Log_Error;

   ---------------------
   -- Params_Callback --
   ---------------------

   function Params_Callback
     (Sessn  : TSSL.gnutls_session_t;
      Kind   : TSSL.gnutls_params_type_t;
      Params : access TSSL.gnutls_params_st) return C.int
   is
      pragma Unreferenced (Sessn);
   begin
      case Kind is
         when TSSL.GNUTLS_PARAMS_RSA_EXPORT =>
            Params.params.rsa_export := RSA_Params (0);

         when TSSL.GNUTLS_PARAMS_DH =>
            Params.params.dh := DH_Params (0);

         when others =>
            return -1;
      end case;

      Params.kind   := Kind;
      Params.deinit := 0;

      return 0;
   end Params_Callback;

   -------------
   -- Pending --
   -------------

   overriding function Pending
     (Socket : Socket_Type) return Stream_Element_Count is
   begin
      return Stream_Element_Count
        (TSSL.gnutls_record_check_pending (Socket.SSL));
   end Pending;

   -------------
   -- Receive --
   -------------

   overriding procedure Receive
     (Socket : Socket_Type;
      Data   : out Stream_Element_Array;
      Last   : out Stream_Element_Offset)
   is
      Code  : TSSL.ssize_t;
      First : Stream_Element_Offset := Data'First;
   begin
      Do_Handshake_Internal (Socket);

      loop
         Code := TSSL.gnutls_record_recv
                   (Socket.SSL, Data (First)'Address,
                    C.size_t (Data'Length - First + Data'First));

         if Code > 0 then
            First := First + Stream_Element_Offset (Code);
            Last  := First - 1;

            exit when Last = Data'Last;

         else
            exit when First > Data'First and then NSST (Socket).Pending = 0;

            if Code = 0 then
               raise Socket_Error with Peer_Closed_Message;
            end if;

            Code_Processing (Code, Socket);
         end if;
      end loop;
   end Receive;

   -------------
   -- Release --
   -------------

   procedure Release (Config : in out SSL.Config) is
      procedure Unchecked_Free is
        new Unchecked_Deallocation (TS_SSL, SSL.Config);
   begin
      if Config /= null and then Config /= Default_Config'Access then
         Finalize (Config.all);
         Unchecked_Free (Config);
      end if;
   end Release;

   --------------------------
   -- Retrieve_Certificate --
   --------------------------

   function Retrieve_Certificate
     (Session         : TSSL.gnutls_session_t;
      req_ca_rdn      : access constant TSSL.gnutls_datum_t;
      nreqs           : C.int;
      pk_algos        : access constant TSSL.gnutls_pk_algorithm_t;
      pk_algos_length : C.int;
      pcert           : access TSSL.a_gnutls_pcert_st;
      pcert_length    : access C.unsigned;
      privkey         : access TSSL.gnutls_privkey_t) return C.int
   is
      pragma Unreferenced (req_ca_rdn, nreqs, pk_algos, pk_algos_length);
      use type Ada.Containers.Count_Type;

      SN   : aliased C.char_array (0 .. 255);
      Kind : aliased TSSL.gnutls_server_name_type_t;
      Size : aliased C.size_t := SN'Length;
      Cfg  : constant Config :=
        To_Config (TSSL.gnutls_session_get_ptr (Session));
      CN   : Host_Certificates.Cursor;
      CH   : Certificate_Holder;

      function Get_Server_Name return String;

      ---------------------
      -- Get_Server_Name --
      ---------------------

      function Get_Server_Name return String is
         RC : constant C.int := TSSL.gnutls_server_name_get
           (Session, SN'Address, Size'Unchecked_Access,
            Kind'Access, 0);
      begin
         case RC is
         when TSSL.GNUTLS_E_SHORT_MEMORY_BUFFER =>
            Log_Error ("Requested server name too long " & C.To_Ada (SN)
                       & Size'Img);
            return "";
         when TSSL.GNUTLS_E_REQUESTED_DATA_NOT_AVAILABLE =>
            return "";
         when TSSL.GNUTLS_E_SUCCESS =>
            return C.To_Ada (SN);
         when others =>
            raise Socket_Error with
              "gnutls_server_name_get error code " & RC'Img;
         end case;
      end Get_Server_Name;

   begin
      if Cfg.PCert_Lists.Length = 1 then
         --  Server does not expect different SNI requests
         CN := Cfg.PCert_Lists.First;
      else
         declare
            Server_Name : constant String := Get_Server_Name;
         begin
            CN := Cfg.PCert_Lists.Find (Server_Name);

            if not Host_Certificates.Has_Element (CN) then
               Log_Error
                 ("Certifiace for server '" & Server_Name & "' not found");
               CN := Cfg.PCert_Lists.Find ("");
            end if;
         end;
      end if;

      CH := Host_Certificates.Element (CN);

      pcert.all        := CH.PCerts (CH.PCerts'First)'Access;
      pcert_length.all := CH.PCerts'Length;
      privkey.all      := CH.TLS_PK;

      return 0;

   exception
      when E : others =>
         Log_Error (Exception_Information (E));
         return -1;
   end Retrieve_Certificate;

   ------------
   -- Secure --
   ------------

   procedure Secure
     (Source : Net.Socket_Type'Class;
      Target : out Socket_Type;
      Config : SSL.Config) is
   begin
      Std.Socket_Type (Target) := Std.Socket_Type (Source);
      Target.Config := Config;
      Check_Config (Target);
   end Secure;

   -------------------
   -- Secure_Client --
   -------------------

   function Secure_Client
     (Socket : Net.Socket_Type'Class;
      Config : SSL.Config := Null_Config;
      Host   : String     := "") return Socket_Type
   is
      Result : Socket_Type;
   begin
      Secure (Socket, Result, Config);
      Session_Client (Result, Host);
      return Result;
   end Secure_Client;

   -------------------
   -- Secure_Server --
   -------------------

   function Secure_Server
     (Socket : Net.Socket_Type'Class;
      Config : SSL.Config := Null_Config) return Socket_Type
   is
      Result : Socket_Type;
   begin
      Secure (Socket, Result, Config);
      Session_Server (Result);
      return Result;
   end Secure_Server;

   ----------
   -- Send --
   ----------

   overriding procedure Send
     (Socket : Socket_Type;
      Data   : Stream_Element_Array;
      Last   : out Stream_Element_Offset)
   is
      Code : TSSL.ssize_t;
   begin
      Do_Handshake_Internal (Socket);

      if Data'Length = 0 then
         Last := Last_Index (Data'First, 0);
         return;
      end if;

      loop
         Code :=
           TSSL.gnutls_record_send (Socket.SSL, Data'Address, Data'Length);

         if Code >= 0 then
            Last := Last_Index (Data'First, Natural (Code));
            exit;
         end if;

         case Code is
            when TSSL.GNUTLS_E_INTERRUPTED =>
               case TSSL.gnutls_record_get_direction (Socket.SSL) is
                  when 0 =>
                     if Socket.Pending = 0 then
                        Last := Last_Index (Data'First, 0);
                        exit;
                     end if;

                  when 1 =>
                     if not Socket.Check ((Output => True, Input => False))
                       (Output)
                     then
                        Last := Last_Index (Data'First, 0);
                        exit;
                     end if;

                  when others =>
                     raise Program_Error;
               end case;

            when TSSL.GNUTLS_E_AGAIN =>
               Last := Last_Index (Data'First, 0);
               exit;

            when others =>
               Check_Error_Code (Code, Socket);
         end case;
      end loop;
   end Send;

   -------------------
   -- Session_Cache --
   -------------------

   protected body Session_Cache is

      -----------
      -- Clear --
      -----------

      procedure Clear is
      begin
         for J in Map.Iterate loop
            TSSL.gnutls_free (Map (J).Datum.data);
         end loop;

         Map.Clear;

         for J in DTI.Iterate loop
            TSSL.gnutls_free (DTI (J).data);
         end loop;

         DTI.Clear;
      end Clear;

      ----------
      -- Drop --
      ----------

      procedure Drop (Key : TSSL.gnutls_datum_t) is
         Cs : Session_Container.Cursor := Map.Find (Key);
         Dd : constant TSSL.a_unsigned_char_t := Map (Cs).Datum.data;
         Kd : constant TSSL.a_unsigned_char_t :=
                Session_Container.Key (Cs).data;
         Dt : constant Calendar.Time := Map (Cs).Birth;
      begin
         Map.Delete (Cs);
         DTI.Delete (Dt);
         TSSL.gnutls_free (Kd);
         TSSL.gnutls_free (Dd);
      end Drop;

      ---------
      -- Get --
      ---------

      function Get (Key : TSSL.gnutls_datum_t) return TSSL.gnutls_datum_t is
         Ce : constant Session_Container.Cursor := Map.Find (Key);
      begin
         if Session_Container.Has_Element (Ce) then
            return Map (Key).Datum;
         else
            return (System.Null_Address, 0);
         end if;
      end Get;

      --------------
      -- Get_Size --
      --------------

      function Get_Size return Natural is
      begin
         return Size;
      end Get_Size;

      ------------
      -- Length --
      ------------

      function Length return Natural is
      begin
         return Natural (Map.Length);
      end Length;

      ---------
      -- Put --
      ---------

      procedure Put (Key, Data : TSSL.gnutls_datum_t) is
         use Ada.Calendar;
         E  : Session_Element;
         Ce : Time_Set.Cursor;
         Cm : Session_Container.Cursor := Map.Find (Key);
         OK : Boolean;
         K  : TSSL.gnutls_datum_t;
      begin
         if Session_Container.Has_Element (Cm) then
            K := Session_Container.Key (Cm);
            E := Map (Cm);

            Map.Delete (Cm);
            DTI.Delete (E.Birth);
            TSSL.gnutls_free (E.Datum.data);
         else
            K := Copy (Key);
         end if;

         E := (Copy (Data), Clock);

         for J in 1 .. 8 loop
            DTI.Insert (E.Birth, K, Ce, OK);
            exit when OK;
            E.Birth := E.Birth + Duration'Small;
         end loop;

         if not OK then
            raise Program_Error with "Time index entry creation";
         end if;

         Map.Insert (K, E);

         while Natural (Map.Length) > Size loop
            Drop (DTI.First_Element);
         end loop;
      end Put;

      --------------
      -- Set_Size --
      --------------

      procedure Set_Size (Size : Natural) is
      begin
         Session_Cache.Size := Size;
      end Set_Size;

   end Session_Cache;

   --------------------------
   -- Session_Cache_Number --
   --------------------------

   function Session_Cache_Number
     (Config : SSL.Config := Null_Config) return Natural
   is
      Cfg : constant SSL.Config :=
              (if Config = Null_Config then Default_Config'Access else Config);
   begin
      return Cfg.Sessions.Length;
   end Session_Cache_Number;

   --------------------
   -- Session_Client --
   --------------------

   procedure Session_Client (Socket : in out Socket_Type; Host : String) is
      use TSSL;
   begin
      Check_Config (Socket);

      Check_Error_Code
        (gnutls_init
           (Socket.SSL'Access,
            GNUTLS_CLIENT + (if Socket.Config.Ticket_Support then 0
                             else GNUTLS_NO_EXTENSIONS)),
         Socket);

      if Socket.Config.Ticket_Support then
         Check_Error_Code (gnutls_session_ticket_enable_client (Socket.SSL));
      end if;

      if Socket.Sessn /= null then
         Socket.Set_Session_Data (Socket.Sessn);
         Socket.Sessn := null;
      end if;

      Check_Error_Code
        (gnutls_credentials_set (Socket.SSL, cred => Socket.Config.CC),
         Socket);

      Session_Transport (Socket);

      if Host /= "" and then not (To_Set (Host) <= IP_Address_Characters) then
         --  GNUTLS does not allow to set physical address text representation
         --  as server name.

         Check_Error_Code
           (TSSL.gnutls_server_name_set
              (Socket.SSL, TSSL.GNUTLS_NAME_DNS, Host'Address, Host'Length));
      end if;
   end Session_Client;

   ------------------
   -- Session_Data --
   ------------------

   function Session_Data (Socket : Socket_Type) return Session_Type is
      Result : Session_Type;
      Id     : aliased Stream_Element_Array (1 .. 64);
      Len    : aliased C.size_t := Id'Length;
   begin
      Check_Error_Code
        (TSSL.gnutls_session_get_id
           (Socket.SSL, Id'Address, Len'Unchecked_Access));

      Result := new TSSL.Session_Record (Stream_Element_Count (Len));

      Result.Id := Id (1 .. Stream_Element_Count (Len));

      Check_Error_Code
        (TSSL.gnutls_session_get_data2 (Socket.SSL, Result.Data'Access));

      return Result;
   end Session_Data;

   ----------------------
   -- Session_Id_Image --
   ----------------------

   function Session_Id_Image (Session : Session_Type) return String is
   begin
      if Session = null then
         return "";
      else
         return Translator.Base64_Encode (Session.Id);
      end if;
   end Session_Id_Image;

   function Session_Id_Image (Socket : Socket_Type) return String is
      Id  : aliased Stream_Element_Array (1 .. 64);
      Len : aliased C.size_t := Id'Length;
   begin
      Check_Error_Code
        (TSSL.gnutls_session_get_id
           (Socket.SSL, Id'Address, Len'Unchecked_Access));

      return Translator.Base64_Encode (Id (1 .. Stream_Element_Offset (Len)));
   end Session_Id_Image;

   --------------------
   -- Session_Reused --
   --------------------

   function Session_Reused (Socket : Socket_Type) return Boolean is
   begin
      return TSSL.gnutls_session_is_resumed (Socket.SSL) /= 0;
   end Session_Reused;

   --------------------
   -- Session_Server --
   --------------------

   procedure Session_Server (Socket : in out Socket_Type) is
      use TSSL;
      use type C.Strings.chars_ptr;
      use type System.Address;
   begin
      Check_Config (Socket);

      if DH_Params (0) = null
        and then RSA_Params (0) = null
        and then not RSA_Lock.Locked and then not DH_Lock.Locked
      then
         Start_Parameters_Generation (DH => True);
      end if;

      Check_Error_Code
        (gnutls_init
           (Socket.SSL'Access,
            GNUTLS_SERVER + (if Socket.Config.Ticket_Support then 0
                             else GNUTLS_NO_EXTENSIONS)),
         Socket);

      if Socket.Config.Ticket_Support then
         Check_Error_Code
           (gnutls_session_ticket_enable_server
              (Socket.SSL, Socket.Config.Ticket_Key'Access));
      end if;

      if Socket.Config.Sessions.Get_Size > 0 then
         gnutls_db_set_ptr (Socket.SSL, Socket.Config.all'Address);
         gnutls_db_set_retrieve_function (Socket.SSL, DB_Retrieve'Access);
         gnutls_db_set_remove_function (Socket.SSL, DB_Remove'Access);
         gnutls_db_set_store_function (Socket.SSL, DB_Store'Access);
      end if;

      Check_Error_Code
        (gnutls_credentials_set (Socket.SSL, cred => Socket.Config.CC),
         Socket);

      if Socket.Config.RCC then
         gnutls_certificate_server_set_request
           (Socket.SSL,
            (if Socket.Config.CREQ
             then GNUTLS_CERT_REQUIRE else GNUTLS_CERT_REQUEST));

         if Socket.Config.CRL_File /= C.Strings.Null_Ptr then
            declare
               use type Calendar.Time;

               TS : constant Calendar.Time :=
                      Utils.File_Time_Stamp
                        (C.Strings.Value (Socket.Config.CRL_File));
               RC : C.int;
            begin
               if Socket.Config.CRL_Time_Stamp = Utils.AWS_Epoch
                 or else Socket.Config.CRL_Time_Stamp /= TS
               then
                  Socket.Config.CRL_Semaphore.Seize;

                  Socket.Config.CRL_Time_Stamp := TS;

                  RC := TSSL.gnutls_certificate_set_x509_crl_file
                          (Socket.Config.CC,
                           Socket.Config.CRL_File,
                           TSSL.GNUTLS_X509_FMT_PEM);

                  Socket.Config.CRL_Semaphore.Release;

                  if RC = -1 then
                     raise Socket_Error
                       with "cannot set CRL file "
                         & C.Strings.Value (Socket.Config.CRL_File);
                  end if;
               end if;
            end;
         end if;

      else
         gnutls_certificate_server_set_request
           (Socket.SSL, GNUTLS_CERT_IGNORE);
      end if;

      Session_Transport (Socket);
   end Session_Server;

   -----------------------
   -- Session_Transport --
   -----------------------

   procedure Session_Transport (Socket : in out Socket_Type) is
   begin
      Check_Error_Code
        (TSSL.gnutls_priority_set (Socket.SSL, Socket.Config.Priority_Cache),
         Socket);

      TSSL.gnutls_transport_set_ptr
        (Socket.SSL, TSSL.gnutls_transport_ptr_t (Socket.Get_FD));

      pragma Warnings (Off, "*condition is always *");

      if OS_Lib.MSG_NOSIGNAL /= -1 then
         TSSL.gnutls_transport_set_push_function
           (Socket.SSL, push_func => Write_Socket'Address);
      end if;

      pragma Warnings (On, "*condition is always *");

      Socket.IO.Handshaken := new Boolean'(False);

      --  Record the SSL config to use in Verify_Callback for server and for
      --  Retrieve_Certificate for client.

      TSSL.gnutls_session_set_ptr (Socket.SSL, Socket.Config.all'Address);
   end Session_Transport;

   ----------------
   -- Set_Config --
   ----------------

   procedure Set_Config (Socket : in out Socket_Type; Config : SSL.Config) is
   begin
      Socket.Config := Config;
   end Set_Config;

   ---------------
   -- Set_Debug --
   ---------------

   procedure Set_Debug
     (Level : Natural; Output : Debug_Output_Procedure := null) is
   begin
      Debug_Output :=
        (if Output = null and then Level > 0
         then Debug_Output_Default'Access
         else Output);

      TSSL.gnutls_global_set_log_function (SSL_Log'Access);
      TSSL.gnutls_global_set_audit_log_function (SSL_Log_Audit'Access);
      TSSL.gnutls_global_set_log_level (C.int (Level));
   end Set_Debug;

   ----------------------------
   -- Set_Session_Cache_Size --
   ----------------------------

   procedure Set_Session_Cache_Size
     (Size : Natural; Config : SSL.Config := Null_Config) is
   begin
      if Config = Null_Config then
         Initialize_Default_Config;
         Default_Config.Sessions.Set_Size (Size);
      else
         Config.Sessions.Set_Size (Size);
      end if;
   end Set_Session_Cache_Size;

   ----------------------
   -- Set_Session_Data --
   ----------------------

   procedure Set_Session_Data
     (Socket : in out Socket_Type; Data : Session_Type)
   is
      use type TSSL.gnutls_session_t;
   begin
      if Socket.SSL = null or else Socket.Get_FD = No_Socket then
         Socket.Sessn := Data;
      else
         Check_Error_Code
           (TSSL.gnutls_session_set_data
              (Socket.SSL, Data.Data.data, C.size_t (Data.Data.size)));
      end if;
   end Set_Session_Data;

   -------------------------
   -- Set_Verify_Callback --
   -------------------------

   procedure Set_Verify_Callback
     (Config : in out SSL.Config; Callback : System.Address)
   is
      function To_Callback is new Unchecked_Conversion
        (System.Address, Net.SSL.Certificate.Verify_Callback);
   begin
      Config.Verify_CB := To_Callback (Callback);
   end Set_Verify_Callback;

   --------------
   -- Shutdown --
   --------------

   overriding procedure Shutdown
     (Socket : Socket_Type; How : Shutmode_Type := Shut_Read_Write)
   is
      use type TSSL.Boolean_Access;
      use type TSSL.gnutls_session_t;

      Code : C.int;
      To_C : constant array (Shutmode_Type) of TSSL.gnutls_close_request_t :=
               (Shut_Read_Write => TSSL.GNUTLS_SHUT_RDWR,
                Shut_Read       => TSSL.GNUTLS_SHUT_RDWR, -- Absent, use RDWR
                Shut_Write      => TSSL.GNUTLS_SHUT_WR);
   begin
      if Socket.IO.Handshaken /= null and then Socket.IO.Handshaken.all then
         --  Must be done only after successful handshake

         loop
            Code := TSSL.gnutls_bye (Socket.SSL, To_C (How));

            exit when Code = TSSL.GNUTLS_E_SUCCESS;

            begin
               Code_Processing
                 (Code, Socket,
                  Duration'Min
                    (Net.Socket_Type (Socket).Timeout, Shutdown_Read_Timeout));
            exception
               when E : others =>
                  Net.Log.Error (Socket, Exception_Message (E));
                  exit;
            end;
         end loop;
      end if;

      if Socket.SSL /= null then
         TSSL.gnutls_transport_set_ptr (Socket.SSL, 0);
      end if;

      Net.Std.Shutdown (NSST (Socket), How);
   end Shutdown;

   ---------------
   -- Signature --
   ---------------

   function Signature
     (Ptr  : System.Address;
      Size : Interfaces.C.size_t;
      Key  : Private_Key;
      Hash : Hash_Method) return Stream_Element_Array
   is
      To_C : constant array (Hash_Method) of TSSL.gnutls_mac_algorithm_t
               := (MD5    => TSSL.GNUTLS_MAC_MD5,
                   SHA1   => TSSL.GNUTLS_MAC_SHA1,
                   SHA224 => TSSL.GNUTLS_MAC_SHA224,
                   SHA256 => TSSL.GNUTLS_MAC_SHA256,
                   SHA384 => TSSL.GNUTLS_MAC_SHA384,
                   SHA512 => TSSL.GNUTLS_MAC_SHA512);
      Dat : aliased TSSL.gnutls_datum_t := (Ptr, C.unsigned (Size));
      Sig : aliased TSSL.gnutls_datum_t;
   begin
      Check_Error_Code
        (TSSL.gnutls_privkey_sign_data
           (signer    => TSSL.Private_Key (Key),
            hash      => TSSL.gnutls_digest_algorithm_t (To_C (Hash)),
            flags     => 0,
            data      => Dat'Unchecked_Access,
            signature => Sig'Access));

      declare
         type Array_Access is access all
            Stream_Element_Array (1 .. Stream_Element_Offset (Sig.size));

         function To_Result is
           new Unchecked_Conversion (TSSL.a_unsigned_char_t, Array_Access);

         Result : constant Stream_Element_Array := To_Result (Sig.data).all;
      begin
         TSSL.gnutls_free (Sig.data);
         return Result;
      end;
   end Signature;

   -----------------
   -- Socket_Pair --
   -----------------

   overriding procedure Socket_Pair (S1, S2 : out Socket_Type) is
      ST1, ST2 : Std.Socket_Type;
   begin
      Std.Socket_Pair (ST1, ST2);
      S1 := Secure_Server (ST1);
      S2 := Secure_Client (ST2);
   end Socket_Pair;

   -------------
   -- SSL_Log --
   -------------

   procedure SSL_Log (level : C.int; text : CS.chars_ptr) is
   begin
      SSL_Log_Common ("", level, text);
   end SSL_Log;

   -------------------
   -- SSL_Log_Audit --
   -------------------

   procedure SSL_Log_Audit
     (sessn : TSSL.gnutls_session_t; level : C.int; text : CS.chars_ptr)
   is
      pragma Unreferenced (sessn);
   begin
      SSL_Log_Common ("@", level, text);
   end SSL_Log_Audit;

   --------------------
   -- SSL_Log_Common --
   --------------------

   procedure SSL_Log_Common
     (Prefix : String; Level : C.int; text : CS.chars_ptr)
   is
      Lev : constant String  := Level'Img;
      Fst : Positive := Lev'First;
      Adt : constant String := CS.Value (text);
   begin
      if Lev (Fst) = ' ' then
         Fst := Fst + 1;
      end if;

      Debug_Output ("|<" & Prefix & Lev (Fst .. Lev'Last) & ">| " & Adt);
   end SSL_Log_Common;

   ---------------------------------
   -- Start_Parameters_Generation --
   ---------------------------------

   procedure Start_Parameters_Generation
     (DH : Boolean; Logging : access procedure (Text : String) := null) is
   begin
      RSA_DH_Generators.Start_Parameters_Generation (DH, Logging);
   end Start_Parameters_Generation;

   ---------------------
   -- Verify_Callback --
   ---------------------

   function Verify_Callback (Session : TSSL.gnutls_session_t) return C.int is
      use type Net.SSL.Certificate.Verify_Callback;
      use type TSSL.a_gnutls_datum_t;

      type Datum_List is
        array (1 .. C.unsigned'Last) of aliased TSSL.gnutls_datum_t
      with Convention => C;

      type Datum_List_Access is access all Datum_List;

      function To_Array_Access is
        new Unchecked_Conversion (TSSL.a_gnutls_datum_t, Datum_List_Access);

      Status        : aliased C.unsigned;
      Cfg           : Config;
      Cert_List     : TSSL.a_gnutls_datum_t;
      Cert_List_Len : aliased C.unsigned;
      Cert          : aliased TSSL.gnutls_x509_crt_t;
      Error_Code    : C.int;

      function Is_Error (Code : C.int) return Boolean;

      --------------
      -- Is_Error --
      --------------

      function Is_Error (Code : C.int) return Boolean is
      begin
         if Code < 0 then
            Log_Error (C.Strings.Value (TSSL.gnutls_strerror (Code)));
            return True;
         end if;

         return False;
      end Is_Error;

   begin
      --  Get the session config

      Cfg := To_Config (TSSL.gnutls_session_get_ptr (Session));

      Error_Code := TSSL.gnutls_certificate_verify_peers2
                      (Session, Status'Access);

      if Error_Code = TSSL.GNUTLS_E_NO_CERTIFICATE_FOUND
        and then not Cfg.CREQ
      then
         return 0;
      elsif Is_Error (Error_Code) then
         return TSSL.GNUTLS_E_CERTIFICATE_ERROR;
      end if;

      --  Get the peer certificate

      Cert_List := TSSL.gnutls_certificate_get_peers
        (Session, Cert_List_Len'Access);

      if Cert_List = null then
         Log_Error ("gnutls_certificate_get_peers null result");
         return TSSL.GNUTLS_E_CERTIFICATE_ERROR;
      end if;

      if Cfg.Verify_CB /= null then
         for J in reverse 1 .. Cert_List_Len loop
            if Is_Error (TSSL.gnutls_x509_crt_init (Cert'Access)) then
               return TSSL.GNUTLS_E_CERTIFICATE_ERROR;
            end if;

            if Is_Error
                 (TSSL.gnutls_x509_crt_import
                    (Cert, To_Array_Access (Cert_List) (J)'Unchecked_Access,
                     TSSL.GNUTLS_X509_FMT_DER))
            then
               return TSSL.GNUTLS_E_CERTIFICATE_ERROR;
            end if;

            if not Cfg.Verify_CB (Net.SSL.Certificate.Impl.Read (Status, Cert))
              and then Status = 0
            then
               Status := 1;
            end if;

            TSSL.gnutls_x509_crt_deinit (Cert);
         end loop;
      end if;

      if Status = 0 or else not Cfg.CREQ then
         return 0;
      else
         return TSSL.GNUTLS_E_CERTIFICATE_ERROR;
      end if;

   exception
      when E : others =>
         Log_Error (Exception_Message (E));
         return TSSL.GNUTLS_E_CERTIFICATE_ERROR;
   end Verify_Callback;

   -------------
   -- Version --
   -------------

   function Version (Build_Info : Boolean := False) return String is
      use C.Strings;
      pragma Unreferenced (Build_Info);
   begin
      return "GNUTLS " & Value (TSSL.gnutls_check_version (Null_Ptr));
   end Version;

   ------------------
   -- Write_Socket --
   ------------------

   function Write_Socket
     (S : C.int; Msg : System.Address; Len : C.int) return C.int
   is
      function C_Send
        (S     : C.int;
         Msg   : System.Address;
         Len   : C.int;
         Flags : C.int) return C.int
      with Import, Convention => Stdcall, External_Name => "send";

   begin
      return C_Send (S, Msg, Len, OS_Lib.MSG_NOSIGNAL);
   end Write_Socket;

begin
   TSSL.gnutls_global_set_mem_functions
     (alloc_func        => Lib_Alloc'Address,
      secure_alloc_func => System.Memory.Alloc'Address,
      is_secure_func    => null,
      realloc_func      => Lib_Realloc'Address,
      free_func         => Lib_Free'Access);

   if TSSL.gnutls_global_init /= 0 then
      raise Program_Error;
   end if;
end AWS.Net.SSL;
