File : src/aws-net-ssl.adb


------------------------------------------------------------------------------
--                              Ada Web Server                              --
--                                                                          --
--                         Copyright (C) 2000-2004                          --
--                                ACT-Europe                                --
--                                                                          --
--  Authors: Dmitriy Anisimkov - Pascal Obry                                --
--                                                                          --
--  This library is free software; you can redistribute it and/or modify    --
--  it under the terms of the GNU General Public License as published by    --
--  the Free Software Foundation; either version 2 of the License, 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.  See the GNU       --
--  General Public License for more details.                                --
--                                                                          --
--  You should have received a copy of the GNU General Public License       --
--  along with this library; if not, write to the Free Software Foundation, --
--  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.          --
--                                                                          --
--  As a special exception, if other files instantiate generics from this   --
--  unit, or you link this unit with other files to produce an executable,  --
--  this  unit  does not  by itself cause  the resulting executable to be   --
--  covered by the GNU General Public License. This exception does not      --
--  however invalidate any other reasons why the executable file  might be  --
--  covered by the  GNU Public License.                                     --
------------------------------------------------------------------------------

--  $Id: aws-net-ssl.adb,v 1.32 2004/03/23 08:30:01 anisimko Exp $

--  Routines here are wrappers around standard sockets and SSL.
--
--  IMPORTANT: The default certificate used for the SSL connection is
--  "cert.pem" (in the working directory) if it exists. If this file does not
--  exists it is required to initialize the SSL layer certificate with
--  AWS.Server.Set_Security.

with Ada.Calendar;
with Ada.Exceptions;
with Ada.Unchecked_Deallocation;

with AWS.Config;
with AWS.Net.Std;
with AWS.Utils;

with Interfaces.C;
with SSL.Thin;
with System.Storage_Elements;
with System;

package body AWS.Net.SSL is

   use Ada;

   pragma Linker_Options ("-lnosslaws");
   --  This is the library used to link without SSL support. The symbols there
   --  will be used only if the application is not linked with the real SSL
   --  libraries.

   use type Interfaces.C.int;
   use type System.Address;

   subtype NSST is Net.Std.Socket_Type;

   Default_Config : Config := new TS_SSL;

   procedure Error_If (Error : in Boolean);
   pragma Inline (Error_If);
   --  Raises Socket_Error if Error is true. Attach the SSL error message

   procedure Set_Read_Ahead (Socket : in Socket_Type; Value : in Boolean);
   --  ???

   function Error_Str (Code : in TSSL.Error_Code) return String;
   --  Returns the SSL error message for error Code

   procedure Init_Random;
   --  Initialize the SSL library with a random number

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

   function Verify_Callback
     (preverify_ok : in Integer;
      ctx          : in System.Address)
      return Integer;
   --  Dummy verify procedure that always return ok. This is needed to be able
   --  to retreive the client's certificate.

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

   procedure Accept_Socket
     (Socket     : in     Net.Socket_Type'Class;
      New_Socket : in out Socket_Type) is
   begin
      if New_Socket.Config = null then
         Initialize_Default_Config;
         New_Socket.Config := Default_Config;
      end if;

      loop
         Net.Std.Accept_Socket (Socket, NSST (New_Socket));

         New_Socket.Config.Set_FD (New_Socket);

         TSSL.SSL_set_accept_state (New_Socket.SSL);

         exit when TSSL.SSL_accept (New_Socket.SSL) > 0;

         Shutdown (New_Socket);

         --  We cannot reuse allocated SSL handle.
         --  Free it before the next use.

         TSSL.SSL_free (New_Socket.SSL);
         New_Socket.SSL := TSSL.Null_Pointer;
      end loop;

      Set_Read_Ahead (New_Socket, True);

   exception
      when others =>
         Free (New_Socket);
         raise;
   end Accept_Socket;

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

   procedure Connect
     (Socket   : in out Socket_Type;
      Host     : in     String;
      Port     : in     Positive) is
   begin
      Net.Std.Connect (NSST (Socket), Host, Port);

      if Socket.Config = null then
         Initialize_Default_Config;
         Socket.Config := Default_Config;
      end if;

      Socket.Config.Set_FD (Socket);

      TSSL.SSL_set_connect_state (Socket.SSL);

      if TSSL.SSL_connect (Socket.SSL) = -1 then
         declare
            use Interfaces;

            Error_Code : constant Integer
              := Integer (TSSL.SSL_get_error (Socket.SSL, -1));
         begin
            Net.Std.Shutdown (NSST (Socket));
            Free (Socket);

            Ada.Exceptions.Raise_Exception
              (Socket_Error'Identity,
               "Error (" & Utils.Image (Error_Code)
                 & ") on SSL connect initiation");
         end;
      end if;
   end Connect;

   --------------
   -- Error_If --
   --------------

   procedure Error_If (Error : in Boolean) is
      use Ada;
   begin
      if Error then
         Exceptions.Raise_Exception
           (Socket_Error'Identity, Error_Str (TSSL.ERR_get_error));
      end if;
   end Error_If;

   ---------------
   -- Error_Str --
   ---------------

   function Error_Str (Code : in TSSL.Error_Code) return String is
      use Interfaces;
      use type TSSL.Error_Code;
      Buffer : C.char_array := (0 .. 511 => Interfaces.C.nul);
      pragma Warnings (Off, Buffer);
   begin
      if Code = 0 then
         return "Not an error";
      else
         TSSL.ERR_error_string_n (Code, Buffer, Buffer'Length);
         return C.To_Ada (Buffer);
      end if;
   end Error_Str;

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

   procedure Free (Socket : in out Socket_Type) is
   begin
      if Socket.SSL /= TSSL.Null_Pointer then
         TSSL.SSL_free (Socket.SSL);
         Socket.SSL := TSSL.Null_Pointer;
      end if;

      Net.Std.Free (NSST (Socket));
   end Free;

   -----------------
   -- Init_Random --
   -----------------

   procedure Init_Random is
      use Ada.Calendar;
      use System.Storage_Elements;

      Buf : String
        := Duration'Image
             (Clock - Time_Of (Year  => Year_Number'First,
                               Month => Month_Number'First,
                               Day   => Day_Number'First))
           & Integer_Address'Image (To_Integer (Init_Random'Address));
   begin
      TSSL.RAND_seed (Buf'Address, Buf'Length);
   end Init_Random;

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

   procedure Initialize
     (Config               : in out SSL.Config;
      Certificate_Filename : in     String;
      Security_Mode        : in     Method     := SSLv23;
      Key_Filename         : in     String     := "";
      Exchange_Certificate : in     Boolean    := False) is
   begin
      if Config = null then
         Config := new TS_SSL;
      end if;

      Config.Initialize
        (Certificate_Filename, Security_Mode, Key_Filename,
         Exchange_Certificate);
   end Initialize;

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

   procedure Initialize_Default_Config is
      package CNF renames AWS.Config;
      Default : CNF.Object renames CNF.Default_Config;
   begin
      Default_Config.Initialize
        (Certificate_Filename => CNF.Certificate (Default),
         Security_Mode        => Method'Value (CNF.Security_Mode (Default)),
         Key_Filename         => CNF.Key (Default),
         Exchange_Certificate => CNF.Exchange_Certificate (Default));
   end Initialize_Default_Config;

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

   function Receive
     (Socket : in Socket_Type;
      Max    : in Stream_Element_Count := 4096)
      return Stream_Element_Array
   is
      Buffer : Stream_Element_Array (0 .. Max - 1);
      Len    : Interfaces.C.int;
   begin
      Len := TSSL.SSL_read (Socket.SSL, Buffer'Address, Buffer'Length);
      Error_If (Len <= 0);

      return Buffer
        (Buffer'First .. Buffer'First - 1 + Stream_Element_Count (Len));
   end Receive;

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

   procedure Release (Config : in out SSL.Config) is
      procedure Free is new Ada.Unchecked_Deallocation (TS_SSL, SSL.Config);
   begin
      if Config /= null then
         Config.Finalize;
         Free (Config);
      end if;
   end Release;

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

   procedure Send
     (Socket : in Socket_Type;
      Data   : in Ada.Streams.Stream_Element_Array) is
   begin
      Error_If (TSSL.SSL_write (Socket.SSL, Data'Address, Data'Length) = -1);
   end Send;

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

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

   --------------------
   -- Set_Read_Ahead --
   --------------------

   procedure Set_Read_Ahead (Socket : in Socket_Type; Value : in Boolean)  is
   begin
      TSSL.SSL_set_read_ahead (S => Socket.SSL, Yes => Boolean'Pos (Value));
   end Set_Read_Ahead;

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

   procedure Shutdown (Socket : in Socket_Type) is
   begin
      TSSL.SSL_set_shutdown
        (Socket.SSL, TSSL.SSL_SENT_SHUTDOWN + TSSL.SSL_RECEIVED_SHUTDOWN);
      Net.Std.Shutdown (NSST (Socket));
   end Shutdown;

   ------------
   -- TS_SSL --
   ------------

   protected body TS_SSL is

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

      procedure Finalize is
      begin
         TSSL.SSL_CTX_free (Context);
         Context := TSSL.Null_Pointer;
      end Finalize;

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

      procedure Initialize
        (Certificate_Filename : in String;
         Security_Mode        : in Method;
         Key_Filename         : in String;
         Exchange_Certificate : in Boolean)
      is

         type Meth_Func is access function return TSSL.SSL_Method;
         pragma Convention (C, Meth_Func);

         procedure Set_Quiet_Shutdown (Value : in Boolean := True);

         procedure Set_Sess_Cache_Size (Value : in Natural);

         procedure Set_Certificate
           (Cert_Filename : in String;
            Key_Filename  : in String := "");

         Methods : constant array (Method) of Meth_Func
           := (SSLv2          => TSSL.SSLv2_method'Access,
               SSLv2_Server   => TSSL.SSLv2_server_method'Access,
               SSLv2_Client   => TSSL.SSLv2_client_method'Access,
               SSLv23         => TSSL.SSLv23_method'Access,
               SSLv23_Server  => TSSL.SSLv23_server_method'Access,
               SSLv23_Client  => TSSL.SSLv23_client_method'Access,
               TLSv1          => TSSL.TLSv1_method'Access,
               TLSv1_Server   => TSSL.TLSv1_server_method'Access,
               TLSv1_Client   => TSSL.TLSv1_client_method'Access,
               SSLv3          => TSSL.SSLv3_method'Access,
               SSLv3_Server   => TSSL.SSLv3_server_method'Access,
               SSLv3_Client   => TSSL.SSLv3_client_method'Access);

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

         procedure Set_Certificate
           (Cert_Filename : in String;
            Key_Filename  : in String := "")
         is

            function Key_File_Name return String;
            --  Returns the key file (Key_Filename) if it is defined and the
            --  certificate filename (Cert_Filename) otherwise.

            -------------------
            -- Key_File_Name --
            -------------------

            function Key_File_Name return String is
            begin
               if Key_Filename = "" then
                  return Cert_Filename;
               else
                  return Key_Filename;
               end if;
            end Key_File_Name;

            use Interfaces.C;

         begin
            Error_If
              (TSSL.SSL_CTX_use_certificate_file
                 (Ctx    => Context,
                  File   => To_C (Cert_Filename),
                  C_Type => TSSL.SSL_FILETYPE_PEM) = -1);

            Error_If
              (TSSL.SSL_CTX_use_PrivateKey_file
                 (Ctx    => Context,
                  File   => To_C (Key_File_Name),
                  C_Type => TSSL.SSL_FILETYPE_PEM) = -1);

            Error_If
              (TSSL.SSL_CTX_check_private_key (Ctx => Context) = -1);

            if TSSL.SSL_CTX_ctrl
              (Ctx  => Context,
               Cmd  => TSSL.SSL_CTRL_NEED_TMP_RSA,
               Larg => 0,
               Parg => TSSL.Null_Pointer) /= 0
            then
               Error_If
                 (TSSL.SSL_CTX_ctrl
                    (Ctx  => Context,
                     Cmd  => TSSL.SSL_CTRL_SET_TMP_RSA,
                     Larg => 0,
                     Parg => Private_Key) = -1);
            end if;
         end Set_Certificate;

         ------------------------
         -- Set_Quiet_Shutdown --
         ------------------------

         procedure Set_Quiet_Shutdown (Value : in Boolean := True) is
         begin
            TSSL.SSL_CTX_set_quiet_shutdown
              (Ctx  => Context,
               Mode => Boolean'Pos (Value));
         end Set_Quiet_Shutdown;

         -------------------------
         -- Set_Sess_Cache_Size --
         -------------------------

         procedure Set_Sess_Cache_Size (Value : in Natural) is
         begin
            Error_If
              (TSSL.SSL_CTX_ctrl
                 (Ctx  => Context,
                  Cmd  => TSSL.SSL_CTRL_SET_SESS_CACHE_SIZE,
                  Larg => Interfaces.C.int (Value),
                  Parg => TSSL.Null_Pointer) = -1);
         end Set_Sess_Cache_Size;

      begin
         if not Initialized then
            if Context /= TSSL.Null_Pointer then
               Finalize;
            end if;

            --  Initialize context

            Context := TSSL.SSL_CTX_new (Methods (Security_Mode).all);
            Error_If (Context = TSSL.Null_Pointer);

            if Exchange_Certificate then
               --  Client is requested to send its certificate once
               TSSL.SSL_CTX_set_verify
                 (Context,
                  TSSL.SSL_VERIFY_PEER + TSSL.SSL_VERIFY_CLIENT_ONCE,
                  Verify_Callback'Address);
            end if;

            --  Initialize private key

            Private_Key := TSSL.RSA_generate_key
              (Bits     => 512,
               E        => TSSL.RSA_F4,
               Callback => null,
               Cb_Arg   => TSSL.Null_Pointer);

            Error_If (Private_Key = TSSL.Null_Pointer);

            Set_Certificate (Certificate_Filename, Key_Filename);

            Set_Quiet_Shutdown;
            Set_Sess_Cache_Size (16);

            Initialized := True;
         end if;
      end Initialize;

      ------------
      -- Set_FD --
      ------------

      procedure Set_FD (Socket : in out Socket_Type) is
      begin
         if Socket.SSL = TSSL.Null_Pointer then
            Socket.SSL := TSSL.SSL_new (Context);
            Error_If (Socket.SSL = TSSL.Null_Pointer);
         else
            Error_If (TSSL.SSL_clear (Socket.SSL) /= 1);
         end if;

         Error_If
           (TSSL.SSL_set_fd
              (Socket.SSL,
               Interfaces.C.int (Get_FD (Socket))) = -1);
      end Set_FD;

   end TS_SSL;

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

   function Verify_Callback
     (preverify_ok : in Integer;
      ctx          : in System.Address)
      return Integer
   is
      pragma Unreferenced (preverify_ok, ctx);
   begin
      return 1;
   end Verify_Callback;

begin
   TSSL.SSL_load_error_strings;
   TSSL.SSL_library_init;
   Init_Random;
end AWS.Net.SSL;