-- Ada Milter API, a binding to Libmilter, the Sendmail mail filtering API -- Copyright 2009 - 2012 B. Persson, Bjorn@Rombobeorn.se -- -- This library 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.Unbounded; with Interfaces.C.Strings; with Interfaces.C.Pointers; with System; package Milter_API is -- -- Version numbers -- type Binding_Version_Type is record Specification_Major : Positive; Specification_Minor : Positive; Implementation : Positive; end record; function Binding_Version return Binding_Version_Type; -- Binding_Version returns the version of Milter_API that the program is -- linked with. If it is dynamically linked, then this is the version that -- is loaded at run time. -- The fields in the result are: -- · Specification_Major: incremented for each new major version of the -- Milter_API specification (this file). -- · Specification_Minor: incremented when changes are made to the -- specification and the major version number cannot be incremented. -- · Implementation: incremented for each new version of Milter_API -- when the specification is unchanged. function Binding_Version_String return String; -- Binding_Version_String returns the same version information as -- Binding_Version, but in string form. type Libmilter_Version_Type is record Major : Natural; Minor : Natural; Patch_Level : Natural; end record; function Libmilter_Version return Libmilter_Version_Type; -- Libmilter_Version returns the version of Libmilter that Milter_API is -- linked with (calls smfi_version). If it is dynamically linked, then this -- is the version that is loaded at run time. function Libmilter_Version_String return String; -- Libmilter_Version_String returns the same version information as -- Libmilter_Version, but in string form. -- -- Data types and constants -- type Options is record Add_Headers : Boolean := False; -- The milter may add header fields to messages (call Add_Header). Change_Or_Delete_Headers : Boolean := False; -- The milter may change and/or delete header fields in messages (call -- Change_Header and/or Delete_Header). Replace_Body : Boolean := False; -- The milter may replace message bodies (call Replace_Body). Add_Recipients : Boolean := False; -- The milter may add recipients to the SMTP envelope (with or without -- ESMTP extension parameters attached) (call Add_Recipient). Remove_Recipients : Boolean := False; -- The milter may remove recipients from the SMTP envelope (call -- Delete_Recipient). Quarantine : Boolean := False; -- The milter may quarantine messages (call Quarantine_Message). Change_Sender : Boolean := False; -- The milter may change the sender in the SMTP envelope (call -- Change_Sender). Request_Symbols : Boolean := False; -- The milter may specify a set of symbols ("macros") that it wants (call -- Request_Symbols). Show_Rejected_Recipients : Boolean := False; -- Call the Recipient_Handler also for RCPT commands that the MTA rejects -- because the user is unknown or similar reasons. RCPT commands that are -- rejected because of syntax errors or suchlike will still not be shown -- to the milter. If the symbol {rcpt_mailer} has the value "error", then -- the recipient will be rejected by the MTA. In that case the symbols -- {rcpt_host} and {rcpt_addr} will usually contain an enhanced status -- code and an error text, respectively. Skip_Further_Callbacks : Boolean := False; -- Callback routines may return Skip. Headers_With_Leading_Space : Boolean := False; -- Pass header values to the Header_Handler with leading space intact, -- and do not add a leading space to headers when they are added, -- inserted or changed. Suppress_Connected : Boolean := False; -- Don't call the Connect_Handler. Suppress_Helo : Boolean := False; -- Don't call the Helo_Handler. Suppress_Sender : Boolean := False; -- Don't call the Sender_Handler. Suppress_Recipient : Boolean := False; -- Don't call the Recipient_Handler Suppress_Data : Boolean := False; -- Don't call the Data_Handler. Suppress_Unknown_Command : Boolean := False; -- Don't call the Unknown_Command_Handler. Suppress_Header : Boolean := False; -- Don't call the Header_Handler. Suppress_End_Of_Headers : Boolean := False; -- Don't call the End_Of_Headers_Handler. Suppress_Body_Chunk : Boolean := False; -- Don't call the Body_Handler. No_Reply_To_Connected : Boolean := False; -- The Connect_Handler will return No_Reply. No_Reply_To_Helo : Boolean := False; -- The Helo_Handler will return No_Reply. No_Reply_To_Sender : Boolean := False; -- The Sender_Handler will return No_Reply. No_Reply_To_Recipient : Boolean := False; -- The Recipient_Handler will return No_Reply. No_Reply_To_Data : Boolean := False; -- The Data_Handler will return No_Reply. No_Reply_To_Unknown_Command : Boolean := False; -- The Unknown_Command_Handler will return No_Reply. No_Reply_To_Header : Boolean := False; -- The Header_Handler will return No_Reply. No_Reply_To_End_Of_Headers : Boolean := False; -- The End_Of_Headers_Handler will return No_Reply. No_Reply_To_Body_Chunk : Boolean := False; -- The Body_Handler will return No_Reply. end record; type SMFICTX_Pointer is private; -- SMFICTX_Pointer is the type of the opaque context pointers that Libmilter -- passes to the callback routines, and that these in turn must pass to the -- data access and message handling routines. type Milter_Data is limited interface; type Milter_Data_Pointer is access all Milter_Data'Class; pragma Convention(C, Milter_Data_Pointer); -- In order to keep some data between callback invocations, the milter must -- derive a type from Milter_Data and allocate one object of that type for -- each SMTP session. The pointer to that object must be stored with -- Set_Private_Data and retrieved with Private_Data. type Protocol_Stage is private; -- A Protocol_Stage is passed to Request_Symbols to specify which callback -- routines want the requested symbols. At_Connect : constant Protocol_Stage; At_Helo : constant Protocol_Stage; At_Sender : constant Protocol_Stage; At_Recipient : constant Protocol_Stage; At_Data : constant Protocol_Stage; At_End_Of_Headers : constant Protocol_Stage; At_End_Of_Message : constant Protocol_Stage; type Negotiation_Result is private; -- Negotiation_Result is returned by the callback routine Negotiate. All_Options : constant Negotiation_Result; -- Use all available protocol steps and actions. -- (SMFIS_ALL_OPTS) These_Options : constant Negotiation_Result; -- Use the selected protocol steps and actions. -- (SMFIS_CONTINUE) Failed : constant Negotiation_Result; -- The milter failed to start up. -- (SMFIS_REJECT) type Action is private; -- Action is returned by callback routines. The value is an instruction to -- the MTA on how to proceed with the message or connection. Continue : constant Action; -- Continue processing the message/connection. -- (SMFIS_CONTINUE) Reject : constant Action; -- Reject the message/connection. -- No further routines will be called for this message -- (or connection, if returned from a connection-oriented routine). -- (SMFIS_REJECT) Discard : constant Action; -- Accept the message, -- but silently discard the message. -- No further routines will be called for this message. -- This is only meaningful from message-oriented routines. -- (SMFIS_DISCARD) Accept_Definitely : constant Action; -- Accept the message/connection. -- No further routines will be called for this message -- (or connection, if returned from a connection-oriented routine; -- in this case, it causes all messages on this connection -- to be accepted without filtering). -- (SMFIS_ACCEPT) Fail_Temporarily : constant Action; -- Return a temporary failure, i.e., -- the corresponding SMTP command will return a 4xx status code. -- In some cases this may prevent further routines from -- being called on this message or connection, -- although in other cases (e.g., when processing an envelope -- recipient) processing of the message will continue. -- (SMFIS_TEMPFAIL) No_Reply : constant Action; -- Do not send a reply to the MTA. -- (SMFIS_NOREPLY) Skip : constant Action; -- Skip over rest of same callbacks, e.g., body. -- (SMFIS_SKIP) type Sockaddr is private; -- A Sockaddr is an opaque handle that points to a TCP endpoint address -- (that is a combination of an IP address and a TCP port). The functions -- Address and Port may be used to retrieve the address data. type Address_Family is (IPv4, IPv6); type Byte_Array is array(Positive range <>) of Interfaces.Unsigned_8; for Byte_Array'Component_Size use 8; type IP_Address(Family : Address_Family := IPv4) is record case Family is when IPv4 => IPv4_Address : Byte_Array(1..4); when IPv6 => IPv6_Address : Byte_Array(1..16); end case; end record; type Arguments_Handle is private; -- An Arguments_Handle holds ESMTP arguments to a MAIL or RCPT command. The -- function Arguments may be used to retrieve the arguments. type Unbounded_Strings is array(Positive range <>) of Ada.Strings.Unbounded.Unbounded_String; subtype String_Of_Three is String(1..3); -- three-digit (RFC 2821) reply code subtype Reply_Line_Index is Positive range 1 .. 32; type Reply_Lines is array(Reply_Line_Index range <>) of Ada.Strings.Unbounded.Unbounded_String; -- -- Callback types -- type Negotiator is access procedure (Context : in SMFICTX_Pointer; -- the opaque context handle Offered : in Options; -- options the MTA can provide Result : out Negotiation_Result; -- how to proceed Requested : out Options); -- options the milter wants to use -- called at the start of each SMTP connection -- A Negotiator enables a milter to determine which options are available -- and dynamically select those which it needs and which are offered. If -- some options are not available, the milter may fall back to a less -- optimized way of working, operate with reduced functionality, or abort -- the session and ask the user to upgrade. -- corresponds to xxfi_negotiate -- The possible values of Result are: -- * All_Options: Use all available protocol steps and actions. The value of -- Requested will be ignored. -- * These_Options: Use those protocol steps and actions that are specified -- in Requested. -- * Failed: The milter failed to start up. It will not be contacted again -- for the current connection. -- More options may be added in future versions of Milter_API. If so, they -- will be off by default so that milters that are unaware of them will -- continue working the same way as before. To ensure that your Negotiator -- will be compatible with future extensions, do not assign an aggregate to -- Requested listing all the components. Either declare an Options variable -- and assign to individual components, or use an aggregate with named -- component associations and an "others => <>" association. type Connect_Handler is access function (Context : SMFICTX_Pointer; -- the opaque context handle Client_Name : String; -- the name of the client Client_Address : Sockaddr) -- the address of the client return Action; -- called at the start of each SMTP connection -- corresponds to xxfi_connect -- Client_Name is the host name of the client, as determined by a reverse -- lookup on the host address. Client_Address describes the client's endpoint -- of the SMTP connection. The means to access the contents of Client_Address -- are not implemented. type Helo_Handler is access function (Context : SMFICTX_Pointer; -- the opaque context handle Stated_Name : String) -- what the client sent as parameter to -- the HELO or EHLO command return Action; -- called when the client sends a HELO or EHLO command -- corresponds to xxfi_helo type Sender_Handler is access function (Context : SMFICTX_Pointer; -- the opaque context handle Sender : String; -- the SMTP envelope sender address Arguments : Arguments_Handle) -- ESMTP arguments to the MAIL command return Action; -- called once at the beginning of each message, when the client sends the -- MAIL command -- corresponds to xxfi_envfrom type Recipient_Handler is access function (Context : SMFICTX_Pointer; -- the opaque context handle Recipient : String; -- an SMTP envelope recipient address Arguments : Arguments_Handle) -- ESMTP arguments to the RCPT command return Action; -- called once per recipient, when the client sends an RCPT command -- corresponds to xxfi_envrcpt type Data_Handler is access function (Context : SMFICTX_Pointer) -- the opaque context handle return Action; -- called when the client sends the DATA command -- corresponds to xxfi_data type Unknown_Command_Handler is access function (Context : SMFICTX_Pointer; -- the opaque context handle Command : String) -- the unknown command including arguments return Action; -- called if the client sends an SMTP command that is either unknown or not -- implemented by the MTA -- corresponds to xxfi_unknown type Header_Handler is access function (Context : SMFICTX_Pointer; -- the opaque context handle Name : String; -- the name of the header Value : String) -- the content of the header return Action; -- called once per message header -- corresponds to xxfi_header type End_Of_Headers_Handler is access function (Context : SMFICTX_Pointer) -- the opaque context handle return Action; -- called after all headers have been processed -- corresponds to xxfi_eoh type Body_Handler is access function (Context : SMFICTX_Pointer; -- the opaque context handle Body_Chunk : String) -- a piece of the message body return Action; -- called zero or more times between End_Of_Headers_Handler and -- End_Of_Message_Handler -- corresponds to xxfi_body type End_Of_Message_Handler is access function (Context : SMFICTX_Pointer) -- the opaque context handle return Action; -- called at the end of a message -- This is the place to call message modification procedures. -- corresponds to xxfi_eom type Abort_Handler is access procedure (Context : SMFICTX_Pointer); -- the opaque context handle -- called at any time during message processing if the message is aborted -- corresponds to xxfi_abort type Close_Handler is access procedure (Context : SMFICTX_Pointer); -- the opaque context handle -- called once at the end of each connection -- corresponds to xxfi_close -- -- Exceptions -- Failure : exception; -- A call to an API procedure failed. -- (The corresponding C function returned MI_FAILURE.) Unknown_Error : exception; -- A C function returned an undocumented result code. No_Address : exception; -- A Sockaddr handle that didn't point to anything was passed to Address or -- Port. Unknown_Address_Type : exception; -- A Sockaddr handle that pointed to something other than an IPv4 or IPv6 -- address was passed to Address or Port. -- -- Library control procedures -- procedure Register (Name : String; Negotiate : Negotiator := null; Connected : Connect_Handler := null; Helo : Helo_Handler := null; Sender : Sender_Handler := null; Recipient : Recipient_Handler := null; Data : Data_Handler := null; Unknown_Command : Unknown_Command_Handler := null; Header : Header_Handler := null; End_Of_Headers : End_Of_Headers_Handler := null; Body_Chunk : Body_Handler := null; End_Of_Message : End_Of_Message_Handler := null; Aborted : Abort_Handler := null; Closed : Close_Handler := null; May_Add_Headers : Boolean := False; May_Change_Or_Delete_Headers : Boolean := False; May_Replace_Body : Boolean := False; May_Add_Recipients : Boolean := False; May_Remove_Recipients : Boolean := False; May_Quarantine : Boolean := False; May_Change_Sender : Boolean := False; May_Request_Symbols : Boolean := False); -- Register must be called exactly once before Main. It registers the -- callbacks and properties of the milter (calls smfi_register). procedure Set_Timeout(Timeout : Natural); -- Set_Timeout should only be called before Main. It sets the number of -- seconds Libmilter will wait for an MTA connection before timing out a -- socket (calls smfi_settimeout). procedure Set_Connection_Queue_Length(Length : Positive); -- Set_Connection_Queue_Length should only be called before Main. It -- sets the number of incoming connections to allow in the listen queue -- (calls smfi_setbacklog). procedure Set_Socket(Address : String); -- Set_Socket must be called once before Main. It specifies the socket -- through which the milter should communicate with the MTA (calls -- smfi_setconn). procedure Open_Socket(Remove_Old_Socket : Boolean); -- Open_Socket should only be called before Main. It creates the socket -- specified previously by a call to Set_Socket (calls smfi_opensocket). -- This allows the calling application to ensure that the socket can be -- created. If the socket is specified as a Unix domain socket and -- Remove_Old_Socket is true, then Libmilter will try to remove any existing -- socket before creating a new one. -- If Open_Socket is not called, then Main will create the socket. procedure Main; -- Hands control to the Libmilter event loop (calls smfi_main). procedure Set_Debug_Level(Level : Natural); -- Set_Debug_Level may be called from any routine at any time. It changes -- Libmilter's internal debug logging level (calls smfi_setdbg). A value of -- zero turns off debug logging. The greater the value the more detailed the -- logging. procedure Stop; -- Stop may be called from any of the callback routines or any error-handling -- routines at any time. It tells Libmilter to shut down the milter (calls -- smfi_stop). -- -- Protocol negotiation procedure -- procedure Request_Symbols (Context : SMFICTX_Pointer; -- the opaque context handle Stage : Protocol_Stage; -- when the symbols are wanted Names : String); -- space-separated list of wanted symbols -- Defines the set of symbols ("macros") that the milter wants to receive -- from the MTA at the specified protocol stage (calls smfi_setsymlist). -- -- Data access subprograms -- function Arguments(Handle : Arguments_Handle) return Unbounded_Strings; -- Converts the ESMTP arguments to a MAIL or RCPT command into an array of -- unbounded strings. procedure Get_Symbol_Value (Context : in SMFICTX_Pointer; -- the opaque context handle Name : in String; -- the name of the requested symbol Defined : out Boolean; -- whether the requested symbol exists Value : out Ada.Strings.Unbounded.Unbounded_String); -- Requests the value of a symbol ("macro") from the MTA (calls -- smfi_getsymval). Value is meaningful only if Defined is True. procedure Set_Private_Data (Context : SMFICTX_Pointer; -- the opaque context handle Data : Milter_Data_Pointer); -- pointer to private data -- Sets the private data pointer to be returned by future calls to -- Private_Data for this connection (calls smfi_setpriv). function Private_Data (Context : SMFICTX_Pointer) -- the opaque context handle return Milter_Data_Pointer; -- Retrieves the private data pointer previously stored with Set_Private_Data -- for this connection (calls smfi_getpriv). procedure Set_Reply (Context : SMFICTX_Pointer; -- the opaque context handle Reply_Code : String_Of_Three; -- three-digit (RFC 2821) reply code Extended_Code : String := ""; -- extended (RFC 2034) reply code Message : String := ""); -- the text part of the reply -- Sets the reply codes and message to be used in subsequent SMTP error -- replies caused by the milter (calls smfi_setreply). procedure Set_Reply (Context : SMFICTX_Pointer; -- the opaque context handle Reply_Code : String_Of_Three; -- three-digit (RFC 2821) reply code Extended_Code : String := ""; -- extended (RFC 2034) reply code Message : Reply_Lines); -- the text part of the reply -- Sets the reply codes and multiple-line message to be used in subsequent -- SMTP error replies caused by the milter (calls smfi_setmlreply). function Address(Endpoint : Sockaddr) return IP_Address; -- Returns the IP address from a Sockaddr handle, or raises No_Address if -- the handle doesn't point to anything. function Address(Endpoint : Sockaddr) return String; -- Returns the textual representation of the IP address from a Sockaddr -- handle, or returns "(address unavailable)" if the handle doesn't point to -- anything. function Port(Endpoint : Sockaddr) return Interfaces.Unsigned_16; -- Returns the TCP port from a Sockaddr handle, or raises No_Address if the -- handle doesn't point to anything. -- -- Message modification procedures -- -- These procedures may only be called from a callback function registered as -- End_Of_Message. procedure Add_Header (Context : SMFICTX_Pointer; -- the opaque context handle Name : String; -- the header field name Value : String); -- the header field body -- Adds a header field to the current message (calls smfi_addheader). procedure Change_Header (Context : SMFICTX_Pointer; -- the opaque context handle Name : String; -- the header field name Index : Positive; -- index among headers with the same name Value : String); -- the new header field body -- Replaces the header field body of the specified header field in the -- current message (calls smfi_chgheader). Index specifies which of the -- headers with the name Name shall be changed. procedure Delete_Header (Context : SMFICTX_Pointer; -- the opaque context handle Name : String; -- the header field name Index : Positive); -- index among headers with the same name -- Removes the specified header field from the current message (calls -- smfi_chgheader with headerv set to null). procedure Insert_Header (Context : SMFICTX_Pointer; -- the opaque context handle Index : Positive; -- index among all headers Name : String; -- the header field name Value : String); -- the header field body -- Adds a header field at a specified position in the current message -- (calls smfi_insheader). Index specifies where in the list of headers it -- shall be inserted. 1 makes it the first header, 2 the second and so on. procedure Change_Sender (Context : SMFICTX_Pointer; -- the opaque context handle Address : String; -- the new sender address Parameters : String := ""); -- extension parameters -- Changes the sender address of the SMTP envelope of the current message, -- optionally with ESMTP extension parameters attached (calls smfi_chgfrom). procedure Add_Recipient (Context : SMFICTX_Pointer; -- the opaque context handle Address : String; -- the new recipient address Parameters : String := ""); -- extension parameters -- Adds a recipient address to the SMTP envelope of the current message, -- optionally with ESMTP extension parameters attached (calls -- smfi_addrcpt_par). procedure Delete_Recipient (Context : SMFICTX_Pointer; -- the opaque context handle Address : String); -- the recipient address to be removed -- Removes the specified recipient address from the SMTP envelope of the -- current message (calls smfi_delrcpt). procedure Replace_Body (Context : SMFICTX_Pointer; -- the opaque context handle Data : String); -- the new message body -- Replaces the body of the current message (calls smfi_replacebody). If -- called more than once, subsequent calls append data to the new body. -- -- Other message handling procedures -- -- These procedures may only be called from a callback function registered as -- End_Of_Message. procedure Report_Progress (Context : SMFICTX_Pointer); -- the opaque context handle -- Notifies the MTA that the milter is still working on a message (calls -- smfi_progress). procedure Quarantine_Message (Context : SMFICTX_Pointer; -- the opaque context handle Reason : String); -- the quarantine reason -- Quarantines the current message (calls smfi_quarantine). private type Dummy_Type is null record; type SMFICTX_Pointer is access Dummy_Type; pragma convention(C, Dummy_Type); pragma convention(C, SMFICTX_Pointer); type Protocol_Stage is range 0 .. 6; At_Connect : constant Protocol_Stage := 0; At_Helo : constant Protocol_Stage := 1; At_Sender : constant Protocol_Stage := 2; At_Recipient : constant Protocol_Stage := 3; At_Data : constant Protocol_Stage := 4; At_End_Of_Message : constant Protocol_Stage := 5; At_End_Of_Headers : constant Protocol_Stage := 6; type Negotiation_Result is range 0 .. 10; These_Options : constant Negotiation_Result := 0; Failed : constant Negotiation_Result := 1; All_Options : constant Negotiation_Result := 10; type Action is range 0 .. 8; Continue : constant Action := 0; Reject : constant Action := 1; Discard : constant Action := 2; Accept_Definitely : constant Action := 3; Fail_Temporarily : constant Action := 4; No_Reply : constant Action := 7; Skip : constant Action := 8; type Sockaddr is new System.Address; Null_Address : constant Sockaddr := Sockaddr(System.Null_Address); use Interfaces.C; use Interfaces.C.Strings; type chars_ptr_array is array(size_t range <>) of aliased chars_ptr; -- This type definition can be removed if and when Interfaces.C.Strings gets -- updated to conform to Ada 2005. package String_Arrays is new Interfaces.C.Pointers(Index => size_t, Element => chars_ptr, Element_Array => chars_ptr_array, Default_Terminator => Null_Ptr); type Arguments_Handle is record Pointer : String_Arrays.Pointer; end record; end Milter_API;