aws_24.0.0_2b75fe6d/regtests/0226_client_cert/client_cert.adb

------------------------------------------------------------------------------
--                              Ada Web Server                              --
--                                                                          --
--                     Copyright (C) 2012-2014, AdaCore                     --
--                                                                          --
--  This 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 software 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   --
--  distributed  with  this  software;   see  file COPYING3.  If not, go    --
--  to http://www.gnu.org/licenses for a complete copy of the license.      --
------------------------------------------------------------------------------

--  This must be the exact same test than tgetparam. The only difference is
--  that it uses HTTPS protocol. We test that output is the same as the non
--  secure version.

with Ada.Calendar.Formatting;
with Ada.Calendar.Time_Zones;
with Ada.Exceptions;
with Ada.Text_IO;

with AWS.Client;
with AWS.Config.Set;
with AWS.Messages;
with AWS.MIME;
with AWS.Net.Log;
with AWS.Net.SSL.Certificate;
with AWS.Parameters;
with AWS.Response;
with AWS.Server.Status;
with AWS.Status;
with AWS.Translator;
with AWS.URL;
with AWS.Utils;

with GNAT.Traceback.Symbolic;

procedure Client_Cert is

   use Ada;
   use Ada.Text_IO;
   use AWS;

   package NSC renames AWS.Net.SSL.Certificate;

   Client_Certificate_Name : constant String := "aws-client.pem";
   Client_Certificate      : constant NSC.Object :=
                               NSC.Load (Client_Certificate_Name);

   function CB (Request : Status.Data) return Response.Data;

   procedure Display_Certificate (Cert : NSC.Object);

   function Image (DT : Calendar.Time) return String;

   --------
   -- CB --
   --------

   function CB (Request : Status.Data) return Response.Data is
      use type NSC.Object;
      URI  : constant String                := Status.URI (Request);
      Sock : constant Net.Socket_Type'Class := Status.Socket (Request);
      Cert : constant NSC.Object := NSC.Get (Net.SSL.Socket_Type (Sock));
   begin
      if URI = "/simple" then
         New_Line;
         Put_Line ("Client certificate as received by the server:");

         if NSC.Subject (Cert) /= "" and then Cert /= Client_Certificate then
            Put_Line ("Wrong client certificate !");
         end if;

         Display_Certificate (Cert);

         return Response.Build (MIME.Text_HTML, "simple ok");

      else
         Put_Line ("Unknown URI " & URI);
         return Response.Build
           (MIME.Text_HTML, URI & " not found", Messages.S404);
      end if;
   end CB;

   -------------------------
   -- Display_Certificate --
   -------------------------

   procedure Display_Certificate (Cert : NSC.Object) is
      use type NSC.Object;
   begin
      if Cert = NSC.Undefined then
         Put_Line ("No certificate.");
      else
         Put_Line ("Name       : " & NSC.Common_Name (Cert));
         Put_Line ("Subject    : " & NSC.Subject (Cert));
         Put_Line ("Issuer     : " & NSC.Issuer (Cert));
         Put_Line ("Activation : " & Image (NSC.Activation_Time (Cert)));
         Put_Line ("Expiration : " & Image (NSC.Expiration_Time (Cert)));
         Put_Line ("Verified   : " & Boolean'Image (NSC.Verified (Cert)));
         --  Put_Line ("Status: " & NSC.Status_Message (Cert));
         New_Line;
      end if;
      Flush;
   end Display_Certificate;

   -----------
   -- Error --
   -----------

   procedure Error (Socket : Net.Socket_Type'Class; Message : String) is
      use GNAT.Traceback;
      Trace : Tracebacks_Array (1 .. 64);
      Last  : Natural;
   begin
      Call_Chain (Trace, Last);

      Text_IO.Put_Line
        ("# Network error: "
         & Message & Symbolic.Symbolic_Traceback (Trace (1 .. Last)));
   end Error;

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

   function Image (DT : Ada.Calendar.Time) return String is
   begin
      return Calendar.Formatting.Image
        (DT, Time_Zone => Calendar.Time_Zones.UTC_Time_Offset (DT));
   end Image;

   -------------
   -- Request --
   -------------

   procedure Request
     (URL : String; CA : String := ""; Crt : String := Client_Certificate_Name)
   is
      use type Messages.Status_Code;

      O_URL : constant AWS.URL.Object := AWS.URL.Parse (URL);
      R     : Response.Data;
      C     : Client.HTTP_Connection;
      Cert  : NSC.Object;
      Cfg   : Net.SSL.Config;

   begin
      Net.SSL.Initialize
        (Cfg,
         Security_Mode        => Net.SSL.TLS_Client,
         Certificate_Filename => Crt,
         Trusted_CA_Filename  => CA);

      Client.Create (C, URL, SSL_Config => Cfg);

      begin
         Cert := Client.Get_Certificate (C);
      exception
         when E : others =>
            Put_Line (Ada.Exceptions.Exception_Message (E));
            return;
      end;

      if NSC."=" (Cert, Client_Certificate) then
         Put_Line ("Client certificate could not be on client side.");
      end if;

      Client.Set_Retry (C, 0);

      Client.Get (C, R, AWS.URL.Abs_Path (O_URL));

      if Response.Status_Code (R) /= Messages.S400
        or else not
          Utils.Match
            (Response.Message_Body (R),
             "GET request error. raised AWS.NET.SOCKET_ERROR :")
        or else NSC.Verified (Cert)
      then
         New_Line;
         Put_Line ("Server certificate as received by the client:");
         Display_Certificate (Cert);

         Put_Line ("=> " & Response.Message_Body (R));
         New_Line;
      end if;

      Client.Close (C);
   end Request;

   -----------------
   -- Verify_Cert --
   -----------------

   function Verify_Cert (Cert : NSC.Object) return Boolean is
      use type Calendar.Time;
   begin
      Text_IO.Put_Line ("Client certificate from verify routine:");
      Display_Certificate (Cert);

      --  Return verified status from the SSL layer

      return NSC.Verified (Cert);
   end Verify_Cert;

   HTTP1, HTTP2, HTTP3 : Server.HTTP;
   Conf                : Config.Object;
   SSL1, SSL2, SSL3    : Net.SSL.Config;

begin
   Put_Line ("Start main, wait for server to start...");

   Config.Set.Server_Host (Conf, "localhost");
   Config.Set.Server_Port (Conf, 0);
   Config.Set.Max_Connection (Conf, 5);
   Config.Set.Security (Conf, True);

   --  SSL1 config, no trusted CA

   Net.SSL.Initialize
     (SSL1,
      Certificate_Filename => "aws-server.crt",
      Key_Filename         => "aws-server.key",
      Exchange_Certificate => True,
      Certificate_Required => True);

   NSC.Set_Verify_Callback (SSL1, Verify_Cert'Unrestricted_Access);

   Server.Set_SSL_Config (HTTP1, SSL1);

   --  SSL2 config, with a trusted CA

   Net.SSL.Initialize
     (SSL2,
      Certificate_Filename => "aws-server.crt",
      Key_Filename         => "aws-server.key",
      Exchange_Certificate => True,
      Certificate_Required => True,
      Trusted_CA_Filename  => "CA-clt.crt");

   NSC.Set_Verify_Callback (SSL2, Verify_Cert'Unrestricted_Access);

   Server.Set_SSL_Config (HTTP2, SSL2);

   --  Run 1

   Server.Start (HTTP1, CB'Unrestricted_Access, Conf);

   Put_Line ("Server 1 started");
   New_Line;

   Request (AWS.Server.Status.Local_URL (HTTP1) & "/simple");

   Net.Log.Start (Error => Error'Unrestricted_Access, Write => null);

   Server.Shutdown (HTTP1);

   --  Run 2

   Server.Start (HTTP2, CB'Unrestricted_Access, Conf);

   Put_Line ("Server 2 started");
   New_Line;

   Request (AWS.Server.Status.Local_URL (HTTP2) & "/simple", "CA-srv.crt");

   Server.Shutdown (HTTP2);

   Net.SSL.Initialize
     (SSL3,
      Certificate_Filename => "aws-server.crt",
      Key_Filename         => "aws-server.key",
      Exchange_Certificate => True,
      Certificate_Required => False);

   Server.Set_SSL_Config (HTTP3, SSL3);

   Server.Start (HTTP3, CB'Unrestricted_Access, Conf);

   Put_Line ("Server 3 started");
   New_Line;

   Request (AWS.Server.Status.Local_URL (HTTP3) & "/simple", "CA-srv.crt");
   Request (AWS.Server.Status.Local_URL (HTTP3) & "/simple", "CA-srv.crt", "");

   --  Looks like in the last request client see the server certificate as a
   --  non trusted, but has a correct truster authority, in both OpenSSL and
   --  GNUTLS. Need investigate.

   Server.Shutdown (HTTP3);

   Set_Line_Length (79);
   Put_Line (AWS.Translator.Base64_Encode (NSC.DER (Client_Certificate)));

exception
   when E : others =>
      Put_Line ("Main Error " & Exceptions.Exception_Information (E));
      Server.Shutdown (HTTP1);
      Server.Shutdown (HTTP2);
end Client_Cert;