Rombobjörn

summaryrefslogtreecommitdiff
path: root/milter_api.adb
diff options
context:
space:
mode:
Diffstat (limited to 'milter_api.adb')
-rw-r--r--milter_api.adb498
1 files changed, 409 insertions, 89 deletions
diff --git a/milter_api.adb b/milter_api.adb
index 68f9bcb..e8f02d3 100644
--- a/milter_api.adb
+++ b/milter_api.adb
@@ -1,5 +1,5 @@
--- Milter API for Ada, a binding to Libmilter, the Sendmail mail filtering API
--- Copyright 2009 B. Persson, Bjorn@Rombobeorn.se
+-- 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
@@ -7,19 +7,17 @@
with Ada.Exceptions; use Ada.Exceptions;
-with Ada.Strings.Fixed;
with System_Log; use System_Log;
+with Ada.Strings.Fixed;
package body Milter_API is
- pragma Linker_Options("-lmilter");
- pragma Linker_Options("-lpthread");
-
use Ada.Strings.Unbounded;
use type String_Arrays.Pointer;
+ use Interfaces;
- Version : constant Binding_Version_Type := (1, 2, 1);
+ Version : constant Binding_Version_Type := (2, 1, 1);
function Binding_Version return Binding_Version_Type is
begin
@@ -34,23 +32,88 @@ package body Milter_API is
Trim(Version.Implementation'Img, Left);
end Binding_Version_String;
- Target_Version : constant int := 2;
- -- Target_Version is the value of SMFI_VERSION in the version of Libmilter
- -- that this version of Milter_API is intended to match.
+ function Libmilter_Version return Libmilter_Version_Type is
+ procedure smfi_version
+ (pmajor : out unsigned;
+ pminor : out unsigned;
+ ppl : out unsigned);
+ pragma import(C, smfi_version);
+ Major : unsigned;
+ Minor : unsigned;
+ Patch_Level : unsigned;
+ begin
+ smfi_version(Major, Minor, Patch_Level);
+ return (Natural(Major), Natural(Minor), Natural(Patch_Level));
+ end Libmilter_Version;
+ function Libmilter_Version_String return String is
+ Version : constant Libmilter_Version_Type := Libmilter_Version;
+ use Ada.Strings, Ada.Strings.Fixed;
+ begin
+ return Trim(Version.Major'Img, Left) & '.' &
+ Trim(Version.Minor'Img, Left) & '.' &
+ Trim(Version.Patch_Level'Img, Left);
+ end Libmilter_Version_String;
- Real_Connect_Handler : Connect_Handler;
- Real_Helo_Handler : Helo_Handler;
- Real_Sender_Handler : Sender_Handler;
- Real_Recipient_Handler : Recipient_Handler;
- Real_Header_Handler : Header_Handler;
- Real_End_Of_Headers_Handler : End_Of_Headers_Handler;
- Real_Body_Handler : Body_Handler;
- Real_End_Of_Message_Handler : End_Of_Message_Handler;
- Real_Abort_Handler : Abort_Handler;
- Real_Close_Handler : Close_Handler;
- Real_Unknown_Command_Handler : Unknown_Command_Handler;
- Real_Data_Handler : Data_Handler;
+
+ function Flag(B : Boolean) return unsigned_long is
+ begin
+ if B then
+ return 1;
+ else
+ return 0;
+ end if;
+ end Flag;
+ pragma Inline(Flag);
+
+
+ -- Option flags:
+ SMFIF_ADDHDRS : constant := 16#1#; -- add headers
+ SMFIF_CHGBODY : constant := 16#2#; -- replace body
+ SMFIF_ADDRCPT : constant := 16#4#; -- add envelope recipients
+ SMFIF_DELRCPT : constant := 16#8#; -- delete envelope recipients
+ SMFIF_CHGHDRS : constant := 16#10#; -- change/delete headers
+ SMFIF_QUARANTINE : constant := 16#20#; -- quarantine envelope
+ SMFIF_CHGFROM : constant := 16#40#; -- change envelope sender
+ SMFIF_ADDRCPT_PAR : constant := 16#80#; -- add recipients with args
+ SMFIF_SETSYMLIST : constant := 16#100#; -- request set of symbols
+ SMFIP_NOCONNECT : constant := 16#1#; -- don't send connect info
+ SMFIP_NOHELO : constant := 16#2#; -- don't send HELO info
+ SMFIP_NOMAIL : constant := 16#4#; -- don't send MAIL info
+ SMFIP_NORCPT : constant := 16#8#; -- don't send RCPT info
+ SMFIP_NOBODY : constant := 16#10#; -- don't send body
+ SMFIP_NOHDRS : constant := 16#20#; -- don't send headers
+ SMFIP_NOEOH : constant := 16#40#; -- don't send EOH
+ SMFIP_NR_HDR : constant := 16#80#; -- No reply for headers
+ SMFIP_NOUNKNOWN : constant := 16#100#; -- don't send unknown commands
+ SMFIP_NODATA : constant := 16#200#; -- don't send DATA
+ SMFIP_SKIP : constant := 16#400#; -- MTA understands SMFIS_SKIP
+ SMFIP_RCPT_REJ : constant := 16#800#; -- also send rejected RCPTs
+ SMFIP_NR_CONN : constant := 16#1000#; -- No reply for connect
+ SMFIP_NR_HELO : constant := 16#2000#; -- No reply for HELO
+ SMFIP_NR_MAIL : constant := 16#4000#; -- No reply for MAIL
+ SMFIP_NR_RCPT : constant := 16#8000#; -- No reply for RCPT
+ SMFIP_NR_DATA : constant := 16#10000#; -- No reply for DATA
+ SMFIP_NR_UNKN : constant := 16#20000#; -- No reply for UNKN
+ SMFIP_NR_EOH : constant := 16#40000#; -- No reply for eoh
+ SMFIP_NR_BODY : constant := 16#80000#; -- No reply for body chunk
+ SMFIP_HDR_LEADSPC : constant := 16#100000#; -- header value leading space
+
+
+ -- Callback pointers:
+ Real_Negotiator : Negotiator;
+ Real_Connect_Handler : Connect_Handler;
+ Real_Helo_Handler : Helo_Handler;
+ Real_Sender_Handler : Sender_Handler;
+ Real_Recipient_Handler : Recipient_Handler;
+ Real_Data_Handler : Data_Handler;
+ Real_Unknown_Command_Handler : Unknown_Command_Handler;
+ Real_Header_Handler : Header_Handler;
+ Real_End_Of_Headers_Handler : End_Of_Headers_Handler;
+ Real_Body_Handler : Body_Handler;
+ Real_End_Of_Message_Handler : End_Of_Message_Handler;
+ Real_Abort_Handler : Abort_Handler;
+ Real_Close_Handler : Close_Handler;
type sfsistat is new int;
@@ -58,7 +121,8 @@ package body Milter_API is
procedure Oops(E : Exception_Occurrence) is
begin
- Log(Error, Exception_Information(E));
+ Log(Error,
+ "Milter_API: Error in callback routine: " & Exception_Information(E));
Stop;
end Oops;
@@ -69,29 +133,143 @@ package body Milter_API is
end Oops;
+ type C_Negotiator is access function
+ (ctx : SMFICTX_Pointer;
+ f0 : unsigned_long;
+ f1 : unsigned_long;
+ f2 : unsigned_long;
+ f3 : unsigned_long;
+ pf0 : access unsigned_long;
+ pf1 : access unsigned_long;
+ pf2 : access unsigned_long;
+ pf3 : access unsigned_long)
+ return sfsistat;
+ pragma convention(C, C_Negotiator);
+
+ function Negotiator_Relay
+ (ctx : SMFICTX_Pointer;
+ f0 : unsigned_long;
+ f1 : unsigned_long;
+ f2 : unsigned_long;
+ f3 : unsigned_long;
+ pf0 : access unsigned_long;
+ pf1 : access unsigned_long;
+ pf2 : access unsigned_long;
+ pf3 : access unsigned_long)
+ return sfsistat;
+ pragma convention(C, Negotiator_Relay);
+
+ function Negotiator_Relay
+ (ctx : SMFICTX_Pointer;
+ f0 : unsigned_long;
+ f1 : unsigned_long;
+ f2 : unsigned_long;
+ f3 : unsigned_long;
+ pf0 : access unsigned_long;
+ pf1 : access unsigned_long;
+ pf2 : access unsigned_long;
+ pf3 : access unsigned_long)
+ return sfsistat
+ is
+ Offered : constant Options :=
+ (Add_Headers => (f0 and SMFIF_ADDHDRS) /= 0,
+ Change_Or_Delete_Headers => (f0 and SMFIF_CHGHDRS) /= 0,
+ Replace_Body => (f0 and SMFIF_CHGBODY) /= 0,
+ Add_Recipients => (f0 and SMFIF_ADDRCPT_PAR) /= 0,
+ Remove_Recipients => (f0 and SMFIF_DELRCPT) /= 0,
+ Quarantine => (f0 and SMFIF_QUARANTINE) /= 0,
+ Change_Sender => (f0 and SMFIF_CHGFROM) /= 0,
+ Request_Symbols => (f0 and SMFIF_SETSYMLIST) /= 0,
+ Show_Rejected_Recipients => (f1 and SMFIP_RCPT_REJ) /= 0,
+ Skip_Further_Callbacks => (f1 and SMFIP_SKIP) /= 0,
+ Headers_With_Leading_Space => (f1 and SMFIP_HDR_LEADSPC) /= 0,
+ Suppress_Connected => (f1 and SMFIP_NOCONNECT) /= 0,
+ Suppress_Helo => (f1 and SMFIP_NOHELO) /= 0,
+ Suppress_Sender => (f1 and SMFIP_NOMAIL) /= 0,
+ Suppress_Recipient => (f1 and SMFIP_NORCPT) /= 0,
+ Suppress_Data => (f1 and SMFIP_NODATA) /= 0,
+ Suppress_Unknown_Command => (f1 and SMFIP_NOUNKNOWN) /= 0,
+ Suppress_Header => (f1 and SMFIP_NOHDRS) /= 0,
+ Suppress_End_Of_Headers => (f1 and SMFIP_NOEOH) /= 0,
+ Suppress_Body_Chunk => (f1 and SMFIP_NOBODY) /= 0,
+ No_Reply_To_Connected => (f1 and SMFIP_NR_CONN) /= 0,
+ No_Reply_To_Helo => (f1 and SMFIP_NR_HELO) /= 0,
+ No_Reply_To_Sender => (f1 and SMFIP_NR_MAIL) /= 0,
+ No_Reply_To_Recipient => (f1 and SMFIP_NR_RCPT) /= 0,
+ No_Reply_To_Data => (f1 and SMFIP_NR_DATA) /= 0,
+ No_Reply_To_Unknown_Command => (f1 and SMFIP_NR_UNKN) /= 0,
+ No_Reply_To_Header => (f1 and SMFIP_NR_HDR) /= 0,
+ No_Reply_To_End_Of_Headers => (f1 and SMFIP_NR_EOH) /= 0,
+ No_Reply_To_Body_Chunk => (f1 and SMFIP_NR_BODY) /= 0);
+ Result : Negotiation_Result;
+ Requested : Options;
+ begin
+ Real_Negotiator(ctx, Offered, Result, Requested);
+ if Result = These_Options then
+ pf0.all :=
+ SMFIF_ADDHDRS * Flag(Requested.Add_Headers) +
+ SMFIF_CHGHDRS * Flag(Requested.Change_Or_Delete_Headers) +
+ SMFIF_CHGBODY * Flag(Requested.Replace_Body) +
+ SMFIF_ADDRCPT_PAR * Flag(Requested.Add_Recipients) +
+ SMFIF_ADDRCPT * Flag(False) + -- not using smfi_addrcpt
+ SMFIF_DELRCPT * Flag(Requested.Remove_Recipients) +
+ SMFIF_QUARANTINE * Flag(Requested.Quarantine) +
+ SMFIF_CHGFROM * Flag(Requested.Change_Sender) +
+ SMFIF_SETSYMLIST * Flag(Requested.Request_Symbols);
+ pf1.all :=
+ SMFIP_RCPT_REJ * Flag(Requested.Show_Rejected_Recipients) +
+ SMFIP_SKIP * Flag(Requested.Skip_Further_Callbacks) +
+ SMFIP_HDR_LEADSPC * Flag(Requested.Headers_With_Leading_Space) +
+ SMFIP_NOCONNECT * Flag(Requested.Suppress_Connected) +
+ SMFIP_NOHELO * Flag(Requested.Suppress_Helo) +
+ SMFIP_NOMAIL * Flag(Requested.Suppress_Sender) +
+ SMFIP_NORCPT * Flag(Requested.Suppress_Recipient) +
+ SMFIP_NODATA * Flag(Requested.Suppress_Data) +
+ SMFIP_NOUNKNOWN * Flag(Requested.Suppress_Unknown_Command) +
+ SMFIP_NOHDRS * Flag(Requested.Suppress_Header) +
+ SMFIP_NOEOH * Flag(Requested.Suppress_End_Of_Headers) +
+ SMFIP_NOBODY * Flag(Requested.Suppress_Body_Chunk) +
+ SMFIP_NR_CONN * Flag(Requested.No_Reply_To_Connected) +
+ SMFIP_NR_HELO * Flag(Requested.No_Reply_To_Helo) +
+ SMFIP_NR_MAIL * Flag(Requested.No_Reply_To_Sender) +
+ SMFIP_NR_RCPT * Flag(Requested.No_Reply_To_Recipient) +
+ SMFIP_NR_DATA * Flag(Requested.No_Reply_To_Data) +
+ SMFIP_NR_UNKN * Flag(Requested.No_Reply_To_Unknown_Command) +
+ SMFIP_NR_HDR * Flag(Requested.No_Reply_To_Header) +
+ SMFIP_NR_EOH * Flag(Requested.No_Reply_To_End_Of_Headers) +
+ SMFIP_NR_BODY * Flag(Requested.No_Reply_To_Body_Chunk);
+ pf2.all := 0;
+ pf3.all := 0;
+ end if;
+ return sfsistat(Result);
+ exception
+ when E : others =>
+ Oops(E);
+ return sfsistat(Reject);
+ end Negotiator_Relay;
+
type C_Connect_Handler is access function
(ctx : SMFICTX_Pointer;
hostname : chars_ptr;
- hostaddr : access Dummy_Type)
+ hostaddr : Sockaddr)
return sfsistat;
pragma convention(C, C_Connect_Handler);
function Connect_Relay
(ctx : SMFICTX_Pointer;
hostname : chars_ptr;
- hostaddr : access Dummy_Type)
+ hostaddr : Sockaddr)
return sfsistat;
pragma convention(C, Connect_Relay);
function Connect_Relay
(ctx : SMFICTX_Pointer;
hostname : chars_ptr;
- hostaddr : access Dummy_Type)
+ hostaddr : Sockaddr)
return sfsistat
is
- Dummy : Sockaddr;
begin
- return sfsistat(Real_Connect_Handler(ctx, Value(hostname), Dummy));
+ return sfsistat(Real_Connect_Handler(ctx, Value(hostname), hostaddr));
exception
when E : others =>
return Oops(E);
@@ -375,65 +553,56 @@ package body Milter_API is
procedure Register
- (Name : String;
- 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)
+ (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)
is
- SMFIF_ADDHDRS : constant := 16#1#; -- add headers
- SMFIF_CHGBODY : constant := 16#2#; -- replace body
- SMFIF_ADDRCPT : constant := 16#4#; -- add envelope recipients
- SMFIF_DELRCPT : constant := 16#8#; -- delete envelope recipients
- SMFIF_CHGHDRS : constant := 16#10#; -- change/delete headers
- SMFIF_QUARANTINE : constant := 16#20#; -- quarantine envelope
-
- function BI(B : Boolean) return unsigned_long is
- begin
- if B then
- return 1;
- else
- return 0;
- end if;
- end BI;
-
type smfiDesc is record
- xxfi_name : chars_ptr := New_String(Name);
- xxfi_version : int := Target_Version;
+ xxfi_name : chars_ptr := New_String(Name);
+ xxfi_version : int;
xxfi_flags : unsigned_long :=
- SMFIF_ADDHDRS * BI(May_Add_Headers) +
- SMFIF_CHGHDRS * BI(May_Change_Or_Delete_Headers) +
- SMFIF_CHGBODY * BI(May_Replace_Body) +
- SMFIF_ADDRCPT * BI(May_Add_Recipients) +
- SMFIF_DELRCPT * BI(May_Remove_Recipients) +
- SMFIF_QUARANTINE * BI(May_Quarantine);
- xxfi_connect : C_Connect_Handler := null;
- xxfi_helo : C_Helo_Handler := null;
- xxfi_envfrom : C_Sender_Handler := null;
- xxfi_envrcpt : C_Recipient_Handler := null;
- xxfi_header : C_Header_Handler := null;
- xxfi_eoh : C_End_Of_Headers_Handler := null;
- xxfi_body : C_Body_Handler := null;
- xxfi_eom : C_End_Of_Message_Handler := null;
- xxfi_abort : C_Abort_Handler := null;
- xxfi_close : C_Close_Handler := null;
- xxfi_unknown : C_Unknown_Command_Handler := null;
- xxfi_data : C_Data_Handler := null;
+ SMFIF_ADDHDRS * Flag(May_Add_Headers) +
+ SMFIF_CHGHDRS * Flag(May_Change_Or_Delete_Headers) +
+ SMFIF_CHGBODY * Flag(May_Replace_Body) +
+ SMFIF_ADDRCPT_PAR * Flag(May_Add_Recipients) +
+ SMFIF_ADDRCPT * Flag(False) + -- not using smfi_addrcpt
+ SMFIF_DELRCPT * Flag(May_Remove_Recipients) +
+ SMFIF_QUARANTINE * Flag(May_Quarantine) +
+ SMFIF_CHGFROM * Flag(May_Change_Sender) +
+ SMFIF_SETSYMLIST * Flag(May_Request_Symbols);
+ xxfi_connect : C_Connect_Handler := null;
+ xxfi_helo : C_Helo_Handler := null;
+ xxfi_envfrom : C_Sender_Handler := null;
+ xxfi_envrcpt : C_Recipient_Handler := null;
+ xxfi_header : C_Header_Handler := null;
+ xxfi_eoh : C_End_Of_Headers_Handler := null;
+ xxfi_body : C_Body_Handler := null;
+ xxfi_eom : C_End_Of_Message_Handler := null;
+ xxfi_abort : C_Abort_Handler := null;
+ xxfi_close : C_Close_Handler := null;
+ xxfi_unknown : C_Unknown_Command_Handler := null;
+ xxfi_data : C_Data_Handler := null;
+ xxfi_negotiate : C_Negotiator := null;
end record;
pragma convention(C_Pass_By_Copy, smfiDesc);
Definition : smfiDesc;
@@ -441,8 +610,20 @@ package body Milter_API is
function smfi_register(descr : smfiDesc) return int;
pragma import(C, smfi_register);
+ Version : constant Libmilter_Version_Type := Libmilter_Version;
+
begin -- Register
+ -- The purpose of xxfi_version appears to be to check that the version of
+ -- Libmilter that the milter is dynamically linked with is compatible
+ -- with the version of the C header files that it was compiled against.
+ -- Such a check is meaningless for this binding, which is independent of
+ -- the C header files. Short-circuit the check by retrieving the version
+ -- of the dynamically linked library and feeding it back to the library.
+ Definition.xxfi_version := int(Version.Major * 2 ** 24 +
+ Version.Minor * 2 ** 8 +
+ Version.Patch_Level);
+
if Connected /= null then
Real_Connect_Handler := Connected;
Definition.xxfi_connect := Connect_Relay'Access;
@@ -491,6 +672,10 @@ package body Milter_API is
Real_Data_Handler := Data;
Definition.xxfi_data := Data_Relay'Access;
end if;
+ if Negotiate /= null then
+ Real_Negotiator := Negotiate;
+ Definition.xxfi_negotiate := Negotiator_Relay'Access;
+ end if;
Check_For_Error("smfi_register", smfi_register(Definition));
@@ -520,7 +705,8 @@ package body Milter_API is
procedure Open_Socket(Remove_Old_Socket : Boolean) is
function smfi_opensocket(rmsocket : int) return int;
- -- rmsocket is declared as bool. I hope a bool is always an int.
+ -- rmsocket is declared as bool, but bool is defined as int in mfapi.h,
+ -- subject to a lot of ifs.
pragma import(C, smfi_opensocket);
function I(B : Boolean) return int is
begin if B then return 1; else return 0; end if; end I;
@@ -549,6 +735,23 @@ package body Milter_API is
smfi_stop;
end Stop;
+ procedure Request_Symbols
+ (Context : SMFICTX_Pointer;
+ Stage : Protocol_Stage;
+ Names : String)
+ is
+ function smfi_setsymlist
+ (ctx : SMFICTX_Pointer;
+ stage : int;
+ macros : char_array)
+ return int;
+ pragma import(C, smfi_setsymlist);
+ begin
+ Check_For_Error("smfi_setsymlist", smfi_setsymlist(Context,
+ int(Stage),
+ To_C(Names)));
+ end Request_Symbols;
+
function Arguments(Handle : Arguments_Handle) return Unbounded_Strings is
Ustrings : Unbounded_Strings
(1 .. Natural(String_Arrays.Virtual_Length(Handle.Pointer)));
@@ -642,6 +845,91 @@ package body Milter_API is
Message_Ptr));
end Set_Reply;
+ procedure Set_Reply
+ (Context : SMFICTX_Pointer;
+ Reply_Code : String_Of_Three;
+ Extended_Code : String := "";
+ Message : Reply_Lines)
+ is separate;
+
+ milter_api_address_type_ipv4 : constant Unsigned_8 := 1;
+ milter_api_address_type_ipv6 : constant Unsigned_8 := 2;
+ milter_api_address_type_unknown : constant Unsigned_8 := 255;
+ pragma export(C, milter_api_address_type_ipv4);
+ pragma export(C, milter_api_address_type_ipv6);
+ pragma export(C, milter_api_address_type_unknown);
+
+ function Address(Endpoint : Sockaddr) return IP_Address is
+ type Unsigned_8_Pointer is access Unsigned_8;
+ function milter_api_address_type(endpoint : Sockaddr) return Unsigned_8;
+ procedure milter_api_ipv4_address(endpoint : in Sockaddr;
+ buffer : out Byte_Array);
+ procedure milter_api_ipv6_address(endpoint : in Sockaddr;
+ buffer : out Byte_Array);
+ pragma import(C, milter_api_address_type);
+ pragma import(C, milter_api_ipv4_address);
+ pragma import(C, milter_api_ipv6_address);
+ Address_Type : Unsigned_8;
+ begin
+ if Endpoint = Null_Address then
+ raise No_Address;
+ else
+ Address_Type := milter_api_address_type(Endpoint);
+ case Address_Type is
+ when milter_api_address_type_ipv4 =>
+ declare
+ Address : IP_Address(IPv4);
+ begin
+ milter_api_ipv4_address(Endpoint, Address.IPv4_Address);
+ return Address;
+ end;
+ when milter_api_address_type_ipv6 =>
+ declare
+ Address : IP_Address(IPv6);
+ begin
+ milter_api_ipv6_address(Endpoint, Address.IPv6_Address);
+ return Address;
+ end;
+ when others =>
+ raise Unknown_Address_Type;
+ end case;
+ end if;
+ end Address;
+
+ function Address(Endpoint : Sockaddr) return String is
+ procedure milter_api_address_string(endpoint : in Sockaddr;
+ buffer : out char_array;
+ size : in Unsigned_8);
+ pragma import(C, milter_api_address_string);
+ Buffer : char_array(1..46);
+ -- An IPv4-mapped IPv6 address in hybrid notation requires at most 45
+ -- characters plus a nul character.
+ begin
+ if Endpoint = Null_Address then
+ return "(address unavailable)";
+ else
+ milter_api_address_string(Endpoint, Buffer, Buffer'Length);
+ return To_Ada(Buffer);
+ end if;
+ end Address;
+
+ function Port(Endpoint : Sockaddr) return Unsigned_16 is
+ function milter_api_address_type(endpoint : Sockaddr) return Unsigned_8;
+ function milter_api_port(endpoint : Sockaddr) return Unsigned_16;
+ pragma import(C, milter_api_address_type);
+ pragma import(C, milter_api_port);
+ begin
+ if Endpoint = Null_Address then
+ raise No_Address;
+ else
+ case milter_api_address_type(Endpoint) is
+ when milter_api_address_type_ipv4 | milter_api_address_type_ipv6 =>
+ return milter_api_port(Endpoint);
+ when others =>
+ raise Unknown_Address_Type;
+ end case;
+ end if;
+ end Port;
procedure Add_Header
(Context : SMFICTX_Pointer;
@@ -721,14 +1009,46 @@ package body Milter_API is
To_C(Value)));
end Insert_Header;
- procedure Add_Recipient(Context : SMFICTX_Pointer; Address : String) is
- function smfi_addrcpt
+ procedure Change_Sender
+ (Context : SMFICTX_Pointer;
+ Address : String;
+ Parameters : String := "")
+ is
+ function smfi_chgfrom
(ctx : SMFICTX_Pointer;
- rcpt : char_array)
+ mail : char_array;
+ args : chars_ptr)
return int;
- pragma import(C, smfi_addrcpt);
+ pragma import(C, smfi_chgfrom);
+ C_Parameters : aliased char_array := To_C(Parameters);
+ Parameters_Ptr : chars_ptr := Null_Ptr;
begin
- Check_For_Error("smfi_addrcpt", smfi_addrcpt(Context, To_C(Address)));
+ if Parameters'Length > 0 then
+ Parameters_Ptr := To_Chars_Ptr(C_Parameters'Unchecked_Access);
+ end if;
+ Check_For_Error("smfi_chgfrom",
+ smfi_chgfrom(Context, To_C(Address), Parameters_Ptr));
+ end Change_Sender;
+
+ procedure Add_Recipient
+ (Context : SMFICTX_Pointer;
+ Address : String;
+ Parameters : String := "")
+ is
+ function smfi_addrcpt_par
+ (ctx : SMFICTX_Pointer;
+ rcpt : char_array;
+ args : chars_ptr)
+ return int;
+ pragma import(C, smfi_addrcpt_par);
+ C_Parameters : aliased char_array := To_C(Parameters);
+ Parameters_Ptr : chars_ptr := Null_Ptr;
+ begin
+ if Parameters'Length > 0 then
+ Parameters_Ptr := To_Chars_Ptr(C_Parameters'Unchecked_Access);
+ end if;
+ Check_For_Error("smfi_addrcpt_par",
+ smfi_addrcpt_par(Context, To_C(Address), Parameters_Ptr));
end Add_Recipient;
procedure Delete_Recipient(Context : SMFICTX_Pointer; Address : String) is