Added an outline of a test milter.

7 files changed, 393 insertions, 0 deletions

diff --git a/test/README b/test/README
new file mode 100644
index 0000000..466b30a
--- /dev/null
+++ b/test/README
@@ -0,0 +1,5 @@
+This test milter can be used to test the Ada Milter API.
+
+To ensure that the test milter won't affect the delivery of regular email, it will only process messages from SMTP clients on the local host, and only those where the string "Ada_Milter_API_test_milter" occurs somewhere in a recipient address. "Ada_Milter_API_test_milter" may for example be the name of an email account, or a part of the account name, or it may be included as an address extension, as in "account+Ada_Milter_API_test_milter@domain.example", if the MTA supports address extensions.
+
+The test milter creates a Unix domain socket named /var/spool/test_milter/milter_socket. The directory /var/spool/test_milter must already exist, with write permission for the test milter and search permission for the MTA. The directory may be a symbolic link if the socket needs to be in some other directory.
diff --git a/test/build_test_milter.gpr b/test/build_test_milter.gpr
new file mode 100644
index 0000000..6746be3
--- /dev/null
+++ b/test/build_test_milter.gpr
@@ -0,0 +1,23 @@
+-- Use this project file to compile the test milter of the Ada Milter API.
+-- Copyright 2013 B. Persson, Bjorn@Rombobeorn.se
+--
+-- This project file is free software: you can redistribute it and/or modify it
+-- under the terms of the GNU General Public License version 3, as published
+-- by the Free Software Foundation.
+
+with "milter_api";
+with "system_log";
+
+project Build_Test_Milter is
+   for Main use ("test_milter");
+   for Languages use ("Ada");
+
+   package Compiler is
+      for Default_Switches ("Ada") use ("-g", "-gnato", "-Wall", "-Wextra");
+   end Compiler;
+
+   package Binder is
+      for Default_Switches ("Ada") use ("-E");
+   end Binder;
+
+end Build_Test_Milter;
diff --git a/test/test_milter.adb b/test/test_milter.adb
new file mode 100644
index 0000000..2cf2ed1
--- /dev/null
+++ b/test/test_milter.adb
@@ -0,0 +1,22 @@
+-- The Ada Milter API test milter
+-- Copyright 2012 - 2013 B. Persson, Bjorn@Rombobeorn.se
+--
+-- This program is free software: you can redistribute it and/or modify it
+-- under the terms of the GNU General Public License version 3, as published
+-- by the Free Software Foundation.
+
+
+with Test_Milter_Package;
+with Thread_Wrapping;
+with Ada.Command_Line;
+with System_Log; use System_Log;
+
+pragma Interrupt_State (Name => SIGSEGV, State => SYSTEM);
+
+procedure Test_Milter is
+begin
+   Open_Log("test_milter", Mail, Include_PID => True);
+   Set_Log_Threshold(Debug);
+   Ada.Command_Line.Set_Exit_Status(Test_Milter_Package.Run);
+   Log(Info, "Terminating.");
+end Test_Milter;
diff --git a/test/test_milter_package.adb b/test/test_milter_package.adb
new file mode 100644
index 0000000..fddb5e7
--- /dev/null
+++ b/test/test_milter_package.adb
@@ -0,0 +1,294 @@
+-- The Ada Milter API test milter
+-- Copyright 2012 - 2013 B. Persson, Bjorn@Rombobeorn.se
+--
+-- This program is free software: you can redistribute it and/or modify it
+-- under the terms of the GNU General Public License version 3, as published
+-- by the Free Software Foundation.
+
+
+with Ada.Strings.Fixed; use Ada.Strings.Fixed;
+with Milter_API; use Milter_API;
+with Berkeley_Exit_Codes;
+with System_Log; use System_Log;
+with Ada.Unchecked_Deallocation;
+with Interfaces.C;
+with Ada.Exceptions;
+with Ada.Directories;
+with Ada.Text_IO;
+with GNAT.OS_Lib;
+
+package body Test_Milter_Package is
+
+
+   type Test_Action is (None, Test_Reject, Test_Discard, Test_Fail_Temporarily);
+
+
+   type Message_Data is limited new Milter_Data with record
+      Test_Message : Boolean;
+      Action       : Test_Action;
+   end record;
+   type Message_Data_Pointer is access all Message_Data;
+   procedure Free is new Ada.Unchecked_Deallocation(Message_Data,
+                                                    Message_Data_Pointer);
+
+   Socket_Obstructed : exception;
+
+
+   function Private_Data(Context : SMFICTX_Pointer) return Message_Data_Pointer
+   is
+   begin
+      return Message_Data_Pointer(Milter_API.Private_Data(Context));
+   end Private_Data;
+
+
+   function Handle_Connection
+      (Context        : SMFICTX_Pointer;
+       Client_Name    : String;
+       Client_Address : Sockaddr)
+      return Action
+   is
+      Local_Client : Boolean := False;
+      -- Allocate a message data record for this SMTP session.
+      Data : constant Message_Data_Pointer := new Message_Data;
+   begin
+      Log(Debug, "Handle_Connection");
+      if Milter_API.Private_Data(Context) /= null then
+         Log(Warning,
+             "The private data pointer isn't null in Handle_Connection. " &
+             "Memory is probably leaking.");
+      end if;
+      -- Remember the pointer to the message data record.
+      Set_Private_Data(Context, Milter_Data_Pointer(Data));
+      declare
+         use type Interfaces.Unsigned_8;
+         Addr : constant IP_Address := Address(Client_Address);
+      begin
+         case Addr.Family is
+            when IPv4 =>
+               Local_Client := Addr.IPv4_Address(1) = 127;
+            when IPv6 =>
+               Local_Client := Addr.IPv6_Address = (1..15 => 0, 16 => 1);
+         end case;
+      exception
+         when No_Address =>
+            Log(Warning, "The MTA didn't provide the client's IP address.");
+         when Unknown_Address_Type =>
+            Log(Error, "The client address is of an unknown type.");
+      end;
+      Log(Debug,
+          "client address: " & Address(Client_Address) &
+          ", local client: " & Boolean'Image(Local_Client));
+      if Local_Client then
+         return Continue;
+      else
+         -- The test milter won't touch messages from this connection.
+         return Accept_Definitely;
+      end if;
+   end Handle_Connection;
+
+
+   function Handle_Helo
+      (Context     : SMFICTX_Pointer;
+       Stated_Name : String)
+      return Action
+   is
+      Data : constant Message_Data_Pointer := Private_Data(Context);
+   begin
+      Log(Debug, "Handle_Helo");
+      return Continue;
+   end Handle_Helo;
+
+
+   function Handle_Sender
+      (Context   : SMFICTX_Pointer;
+       Sender    : String;
+       Arguments : Arguments_Handle)
+      return Action
+   is
+      Data : constant Message_Data_Pointer := Private_Data(Context);
+   begin
+      Log(Debug, "Handle_Sender");
+      -- Initialize the message data record, or clear it of data from the
+      -- previous message in the SMTP session.
+      Data.Test_Message := False;
+      Data.Action := None;
+      return Continue;
+   end Handle_Sender;
+
+
+   function Handle_Recipient
+      (Context   : SMFICTX_Pointer;
+       Recipient : String;
+       Arguments : Arguments_Handle)
+      return Action
+   is
+      Data : constant Message_Data_Pointer := Private_Data(Context);
+   begin
+      Log(Debug, "Handle_Recipient " & Recipient);
+      if Index(Recipient, "Ada_Milter_API_test_milter") /= 0 then
+         Data.Test_Message := True;
+      end if;
+      return Continue;
+   end Handle_Recipient;
+
+
+   function Handle_Data(Context : SMFICTX_Pointer) return Action is
+      Data : constant Message_Data_Pointer := Private_Data(Context);
+   begin
+      Log(Debug, "Handle_Data");
+      if Data.Test_Message then
+         return Continue;
+      else
+         -- This message is not intended for the test milter.
+         return Accept_Definitely;
+      end if;
+   end Handle_Data;
+
+
+   function Handle_Unknown_Command
+      (Context : SMFICTX_Pointer;
+       Command : String)
+      return Action
+   is
+      Data : constant Message_Data_Pointer := Private_Data(Context);
+   begin
+      Log(Debug, "Handle_Unknown_Command");
+      return Continue;
+   end Handle_Unknown_Command;
+
+
+   function Handle_Header
+      (Context : SMFICTX_Pointer;
+       Name    : String;
+       Value   : String)
+      return Action
+   is
+      Data : constant Message_Data_Pointer := Private_Data(Context);
+   begin
+      Log(Debug, "Handle_Header " & Name);
+      return Continue;
+   end Handle_Header;
+
+
+   function Handle_End_Of_Headers(Context : SMFICTX_Pointer) return Action is
+      Data : constant Message_Data_Pointer := Private_Data(Context);
+   begin
+      Log(Debug, "Handle_End_Of_Headers");
+      return Continue;
+   end Handle_End_Of_Headers;
+
+
+   function Handle_Body
+      (Context    : SMFICTX_Pointer;
+       Body_Chunk : String)
+      return Action
+   is
+      Data : constant Message_Data_Pointer := Private_Data(Context);
+   begin
+      Log(Debug, "Handle_Body");
+      return Continue;
+   end Handle_Body;
+
+
+   function Handle_End_Of_Message(Context : SMFICTX_Pointer) return Action is
+      Data : constant Message_Data_Pointer := Private_Data(Context);
+   begin
+      Log(Debug, "Handle_End_Of_Message");
+      return Reject;
+   end Handle_End_Of_Message;
+
+
+   procedure Handle_Abort(Context : SMFICTX_Pointer) is
+      Data : constant Message_Data_Pointer := Private_Data(Context);
+   begin
+      Log(Debug, "Handle_Abort");
+   end Handle_Abort;
+
+
+   procedure Handle_Close(Context : SMFICTX_Pointer) is
+      Data : Message_Data_Pointer := Private_Data(Context);
+   begin
+      Log(Debug, "Handle_Close");
+      -- Deallocate the message data record.
+      Free(Data);
+      Set_Private_Data(Context, null);
+   end Handle_Close;
+
+
+   procedure Clean_And_Set_Socket is
+      Socket_Name : constant String := "/var/spool/test_milter/milter_socket";
+      function umask(mask : Interfaces.C.unsigned) return Interfaces.C.unsigned;
+      pragma import(C, umask);
+      mask : Interfaces.C.unsigned;  -- dummy to soak up the result from umask
+      pragma Unreferenced(mask);
+   begin
+      -- Delete the socket file if it exists, assuming it was left behind
+      -- because of a crash.
+      if Ada.Directories.Exists(Socket_Name) then
+         Log(Warning, Socket_Name & " exists. Deleting it.");
+         -- GNAT's implementation of Ada.Directories.Delete_File calls a
+         -- function named Is_Regular_File and refuses to delete a socket file,
+         -- so GNAT.OS_Lib.Delete_File must be used instead.
+         -- http://gcc.gnu.org/bugzilla/show_bug.cgi?id=56055
+         declare
+            OK : Boolean;
+         begin
+            GNAT.OS_Lib.Delete_File(Socket_Name, OK);
+            if not OK then
+               raise Socket_Obstructed with
+                  Socket_Name & " can't be created because a file with that " &
+                  "name exists and can't be deleted.";
+            end if;
+         end;
+      end if;
+      -- Clear the permissions mask to allow the MTA to use the socket.
+      mask := umask(0);
+      -- Tell the milter library where to create the socket.
+      Set_Socket("unix:" & Socket_Name);
+   end Clean_And_Set_Socket;
+
+
+   function Run return Ada.Command_Line.Exit_Status is
+      use Ada.Exceptions;
+      use Berkeley_Exit_Codes;
+      use Ada.Text_IO;
+   begin
+      Log(Info,
+          "Starting. Milter API version " & Milter_API.Binding_Version_String &
+          ", Libmilter version " & Milter_API.Libmilter_Version_String);
+      Clean_And_Set_Socket;
+      Register(Name                         => "test_milter/libmilter",
+               Connected                    => Handle_Connection'Access,
+               Helo                         => Handle_Helo'Access,
+               Sender                       => Handle_Sender'Access,
+               Recipient                    => Handle_Recipient'Access,
+               Data                         => Handle_Data'Access,
+               Unknown_Command              => Handle_Unknown_Command'Access,
+               Header                       => Handle_Header'Access,
+               End_Of_Headers               => Handle_End_Of_Headers'Access,
+               Body_Chunk                   => Handle_Body'Access,
+               End_Of_Message               => Handle_End_Of_Message'Access,
+               Aborted                      => Handle_Abort'Access,
+               Closed                       => Handle_Close'Access);
+      Milter_API.Main;
+      return Ada.Command_Line.Success;
+   exception
+      when E : Milter_API.Failure =>
+         Log(Error, Exception_Message(E));
+         return Ada.Command_Line.Failure;
+      when E : Milter_API.Unknown_Error =>
+         Log(Error, Exception_Message(E));
+         return Software_Error;
+      when E : Socket_Obstructed =>
+         Log(Error, Exception_Message(E));
+         return Cannot_Create_File;
+      when E : others =>
+         Put_Line(Standard_Error, Exception_Information(E));
+         Log(Error,
+             "Unexpected error: " & Exception_Name(E) & ": " &
+             Exception_Message(E));
+         return Software_Error;
+   end Run;
+
+
+end Test_Milter_Package;
diff --git a/test/test_milter_package.ads b/test/test_milter_package.ads
new file mode 100644
index 0000000..8e9a21b
--- /dev/null
+++ b/test/test_milter_package.ads
@@ -0,0 +1,15 @@
+-- The Ada Milter API test milter
+-- Copyright 2012 B. Persson, Bjorn@Rombobeorn.se
+--
+-- This program is free software: you can redistribute it and/or modify it
+-- under the terms of the GNU General Public License version 3, as published
+-- by the Free Software Foundation.
+
+
+with Ada.Command_Line;
+
+package Test_Milter_Package is
+
+   function Run return Ada.Command_Line.Exit_Status;
+
+end Test_Milter_Package;
diff --git a/test/thread_wrapping.adb b/test/thread_wrapping.adb
new file mode 100644
index 0000000..75201e0
--- /dev/null
+++ b/test/thread_wrapping.adb
@@ -0,0 +1,21 @@
+-- The Ada Milter API test milter
+-- Copyright 2013 B. Persson, Bjorn@Rombobeorn.se
+--
+-- This program is free software: you can redistribute it and/or modify it
+-- under the terms of the GNU General Public License version 3, as published
+-- by the Free Software Foundation.
+
+
+-- GNAT.Threads must be ready for use before wrapping of threads can begin.
+with GNAT.Threads;
+pragma Elaborate_All(GNAT.Threads);
+pragma Unreferenced(GNAT.Threads);
+
+package body Thread_Wrapping is
+
+   procedure Start_Wrapping_Threads;
+   pragma import(C, Start_Wrapping_Threads, "start_wrapping_threads");
+
+begin
+   Start_Wrapping_Threads;
+end Thread_Wrapping;
diff --git a/test/thread_wrapping.ads b/test/thread_wrapping.ads
new file mode 100644
index 0000000..a7e3487
--- /dev/null
+++ b/test/thread_wrapping.ads
@@ -0,0 +1,13 @@
+-- The Ada Milter API test milter
+-- Copyright 2013 B. Persson, Bjorn@Rombobeorn.se
+--
+-- This program is free software: you can redistribute it and/or modify it
+-- under the terms of the GNU General Public License version 3, as published
+-- by the Free Software Foundation.
+
+
+package Thread_Wrapping is
+   pragma Elaborate_Body;
+   -- Elaborating the spec and the body together isn't important, but without
+   -- this pragma this package wouldn't be allowed to have a body.
+end Thread_Wrapping;