diff options
Diffstat (limited to 'test/test_milter_package.adb')
| -rw-r--r-- | test/test_milter_package.adb | 294 |
1 files changed, 294 insertions, 0 deletions
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; |