~nytpu/tlsada

a315917308e9fc66d6de9d3d80c4df7a2c09143e — nytpu 1 year, 11 months ago 3064764
Automatically initialize Contexts to obviate an explicit Create call.

Using the Rosen trick[1], Contexts are now automatically initialized so
consumers do not need to explicitly call the proper Create.

[1]: https://en.wikibooks.org/wiki/Ada_Programming/Object_Orientation#Multiple_Inheritance_via_Mix-in
M src/example/client_example.adb => src/example/client_example.adb +1 -2
@@ 14,8 14,7 @@ with TLS.Contexts.Client;

procedure Client_Example is
	Conf : TLS.Configure.Config;
	Client : aliased TLS.Contexts.Client.Client_Context :=
		TLS.Contexts.Client.Create;
	Client : aliased TLS.Contexts.Client.Client_Context;
begin
	-- Argument parsing
	if Argument_Count < 2 or Argument_Count > 3 then

M src/example/server_example.adb => src/example/server_example.adb +1 -2
@@ 41,8 41,7 @@ procedure Server_Example is
	Conf : TLS.Configure.Config;
	Address : Sock_Addr_Type;
	Server_Socket : Socket_Type;
	Server_TLS : aliased TLS.Contexts.Server.Server_Context :=
		TLS.Contexts.Server.Create;
	Server_TLS : aliased TLS.Contexts.Server.Server_Context;
begin
	Put_Line("Binding to '" & Bind_Address & "'");
	Put_Line("Press Control-C to exit.");

M src/tls-contexts-client.adb => src/tls-contexts-client.adb +10 -8
@@ 17,14 17,6 @@ package body TLS.Contexts.Client is
	pragma Style_Checks(Off, Bs);


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

	overriding function Create return Client_Context
	is ((Root_Stream_Type with Initialize_Client));


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


@@ 126,4 118,14 @@ package body TLS.Contexts.Client is
				raise TLS_Error with Retrieve_Error_Message(Ctx.Context)
	);


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

	overriding procedure Initialize (Object : in out Controlled_Mixin) is
	begin
		Initialize_Client(Object.Enclosing.Context);
	end Initialize;

end TLS.Contexts.Client;

M src/tls-contexts-client.ads => src/tls-contexts-client.ads +10 -3
@@ 9,11 9,11 @@ pragma Ada_2012;

with GNAT.Sockets;  use GNAT.Sockets;

private with Ada.Finalization;

package TLS.Contexts.Client is

	type Client_Context is new Context with private;
	overriding function Create return Client_Context
		with Post => Is_Initialized(Create'Result);

	-- Connect to a given hostname and port using a given context
	procedure Connect


@@ 55,6 55,13 @@ package TLS.Contexts.Client is


private
	type Client_Context is new Context with null record;
	type Controlled_Mixin (Enclosing : access Client_Context) is
		new Ada.Finalization.Limited_Controlled with null record;
	overriding procedure Initialize (Object : in out Controlled_Mixin);

	type Client_Context is new Context with record
		-- Client_Context'Access refers to the actual enclosing instance!
		Mix_In : Controlled_Mixin(Enclosing => Client_Context'Access);
	end record;

end TLS.Contexts.Client;

M src/tls-contexts-server.adb => src/tls-contexts-server.adb +10 -8
@@ 17,14 17,6 @@ package body TLS.Contexts.Server is
	pragma Style_Checks(Off, Bs);


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

	overriding function Create return Server_Context
	is (Server_Context'(Root_Stream_Type with Initialize_Server));


	----------------
	-- Accept_TLS --
	----------------


@@ 56,4 48,14 @@ package body TLS.Contexts.Server is
	function SNI_Servername (Ctx : Server_Context) return String
	is (To_String(Call_String_Function(Bs.tls_conn_servername'Access, Ctx.Context)));


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

	overriding procedure Initialize (Object : in out Controlled_Mixin) is
	begin
		Initialize_Server(Object.Enclosing.Context);
	end Initialize;

end TLS.Contexts.Server;

M src/tls-contexts-server.ads => src/tls-contexts-server.ads +8 -3
@@ 12,8 12,6 @@ with GNAT.Sockets;  use GNAT.Sockets;
package TLS.Contexts.Server is

	type Server_Context is new Context with private;
	overriding function Create return Server_Context
		with Post => Is_Initialized(Create'Result);

	-- Accept a connection over a socket with an existing connection and output
	-- a new context suitable for reading and writing.  The Server_Ctx remains


@@ 36,6 34,13 @@ package TLS.Contexts.Server is


private
	type Server_Context is new Context with null record;
	type Controlled_Mixin (Enclosing : access Server_Context) is
		new Ada.Finalization.Limited_Controlled with null record;
	overriding procedure Initialize (Object : in out Controlled_Mixin);

	type Server_Context is new Context with record
		-- Client_Context'Access refers to the actual enclosing instance!
		Mix_In : Controlled_Mixin(Enclosing => Server_Context'Access);
	end record;

end TLS.Contexts.Server;

M src/tls-contexts.adb => src/tls-contexts.adb +12 -16
@@ 542,15 542,13 @@ package body TLS.Contexts is
	-- Initialize_Client --
	-----------------------

	function Initialize_Client return Context_Wrapper is
	procedure Initialize_Client (Object : in out Context_Wrapper) is
	begin
		return Ctx : Context_Wrapper do
			Ctx.Context := Bs.tls_client;
			if Ctx.Context = null then
				raise TLS_Error
					with "unable to generate libtls tls context";
			end if;
		end return;
		Object.Context := Bs.tls_client;
		if Object.Context = null then
			raise TLS_Error
				with "unable to generate libtls tls context";
		end if;
	end Initialize_Client;




@@ 558,15 556,13 @@ package body TLS.Contexts is
	-- Initialize_Server --
	-----------------------

	function Initialize_Server return Context_Wrapper is
	procedure Initialize_Server (Object : in out Context_Wrapper) is
	begin
		return Ctx : Context_Wrapper do
			Ctx.Context := Bs.tls_server;
			if Ctx.Context = null then
				raise TLS_Error
					with "unable to generate libtls tls context";
			end if;
		end return;
		Object.Context := Bs.tls_server;
		if Object.Context = null then
			raise TLS_Error
				with "unable to generate libtls tls context";
		end if;
	end Initialize_Server;



M src/tls-contexts.ads => src/tls-contexts.ads +6 -7
@@ 107,9 107,6 @@ package TLS.Contexts is
	-- Has the same interface as Ada.Streams.Stream_IO
	type Context is abstract limited new Root_Stream_Type with private;

	-- Generate a new Context with all internal structures initialized
	function Create return Context is abstract;

	-- Return whether a context has been properly initialized
	function Is_Initialized (Ctx : Context) return Boolean;



@@ 191,12 188,14 @@ private
	end record;

	-- Initialize an internal client context
	function Initialize_Client return Context_Wrapper
		with Post => Initialize_Client'Result.Context /= null;
	procedure Initialize_Client (Object : in out Context_Wrapper)
		with Pre => Object.Context = null,
			Post => Object.Context /= null;

	-- Initialize an internal server context
	function Initialize_Server return Context_Wrapper
		with Post => Initialize_Server'Result.Context /= null;
	procedure Initialize_Server (Object : in out Context_Wrapper)
		with Pre => Object.Context = null,
			Post => Object.Context /= null;

	-- Close the active TLS connection
	procedure Close (Ctx : in out Context_Wrapper);