-- Ada Milter API, a binding to Libmilter, the Sendmail mail filtering API -- Copyright 2009 - 2013 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.Exceptions; use Ada.Exceptions; with System_Log; use System_Log; with Ada.Strings.Fixed; package body Milter_API is use Ada.Strings.Unbounded; use type String_Arrays.Pointer; use Interfaces; Version : constant Binding_Version_Type := (2, 1, 2); function Binding_Version return Binding_Version_Type is begin return Version; end Binding_Version; function Binding_Version_String return String is use Ada.Strings, Ada.Strings.Fixed; begin return Trim(Version.Specification_Major'Img, Left) & '.' & Trim(Version.Specification_Minor'Img, Left) & '.' & Trim(Version.Implementation'Img, Left); end Binding_Version_String; 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; 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; procedure Oops(E : Exception_Occurrence) is begin Log(Error, "Milter_API: Error in callback routine: " & Exception_Information(E)); Stop; end Oops; function Oops(E : Exception_Occurrence) return sfsistat is begin Oops(E); return sfsistat(Accept_Definitely); 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 pragma Unreferenced(f2); pragma Unreferenced(f3); -- f2 and f3 are space for future extensions. 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 : Sockaddr) return sfsistat; pragma convention(C, C_Connect_Handler); function Connect_Relay (ctx : SMFICTX_Pointer; hostname : chars_ptr; hostaddr : Sockaddr) return sfsistat; pragma convention(C, Connect_Relay); function Connect_Relay (ctx : SMFICTX_Pointer; hostname : chars_ptr; hostaddr : Sockaddr) return sfsistat is begin return sfsistat(Real_Connect_Handler(ctx, Value(hostname), hostaddr)); exception when E : others => return Oops(E); end Connect_Relay; type C_Helo_Handler is access function (ctx : SMFICTX_Pointer; helohost : chars_ptr) return sfsistat; pragma convention(C, C_Helo_Handler); function Helo_Relay (ctx : SMFICTX_Pointer; helohost : chars_ptr) return sfsistat; pragma convention(C, Helo_Relay); function Helo_Relay (ctx : SMFICTX_Pointer; helohost : chars_ptr) return sfsistat is begin return sfsistat(Real_Helo_Handler(ctx, Value(helohost))); exception when E : others => return Oops(E); end Helo_Relay; type C_Sender_Handler is access function (ctx : SMFICTX_Pointer; argv : String_Arrays.Pointer) return sfsistat; pragma convention(C, C_Sender_Handler); function Sender_Relay (ctx : SMFICTX_Pointer; argv : String_Arrays.Pointer) return sfsistat; pragma convention(C, Sender_Relay); function Sender_Relay (ctx : SMFICTX_Pointer; argv : String_Arrays.Pointer) return sfsistat is begin return sfsistat(Real_Sender_Handler (ctx, Value(argv.all), (Pointer => argv + 1))); exception when E : others => return Oops(E); end Sender_Relay; type C_Recipient_Handler is access function (ctx : SMFICTX_Pointer; argv : String_Arrays.Pointer) return sfsistat; pragma convention(C, C_Recipient_Handler); function Recipient_Relay (ctx : SMFICTX_Pointer; argv : String_Arrays.Pointer) return sfsistat; pragma convention(C, Recipient_Relay); function Recipient_Relay (ctx : SMFICTX_Pointer; argv : String_Arrays.Pointer) return sfsistat is begin return sfsistat(Real_Recipient_Handler (ctx, Value(argv.all), (Pointer => argv + 1))); exception when E : others => return Oops(E); end Recipient_Relay; type C_Data_Handler is access function (ctx : SMFICTX_Pointer) return sfsistat; pragma convention(C, C_Data_Handler); function Data_Relay (ctx : SMFICTX_Pointer) return sfsistat; pragma convention(C, Data_Relay); function Data_Relay (ctx : SMFICTX_Pointer) return sfsistat is begin return sfsistat(Real_Data_Handler(ctx)); exception when E : others => return Oops(E); end Data_Relay; type C_Unknown_Command_Handler is access function (ctx : SMFICTX_Pointer; arg : chars_ptr) return sfsistat; pragma convention(C, C_Unknown_Command_Handler); function Unknown_Command_Relay (ctx : SMFICTX_Pointer; arg : chars_ptr) return sfsistat; pragma convention(C, Unknown_Command_Relay); function Unknown_Command_Relay (ctx : SMFICTX_Pointer; arg : chars_ptr) return sfsistat is begin return sfsistat(Real_Unknown_Command_Handler(ctx, Value(arg))); exception when E : others => return Oops(E); end Unknown_Command_Relay; type C_Header_Handler is access function (ctx : SMFICTX_Pointer; headerf : chars_ptr; headerv : chars_ptr) return sfsistat; pragma convention(C, C_Header_Handler); function Header_Relay (ctx : SMFICTX_Pointer; headerf : chars_ptr; headerv : chars_ptr) return sfsistat; pragma convention(C, Header_Relay); function Header_Relay (ctx : SMFICTX_Pointer; headerf : chars_ptr; headerv : chars_ptr) return sfsistat is begin return sfsistat(Real_Header_Handler(ctx, Value(headerf), Value(headerv))); exception when E : others => return Oops(E); end Header_Relay; type C_End_Of_Headers_Handler is access function (ctx : SMFICTX_Pointer) return sfsistat; pragma convention(C, C_End_Of_Headers_Handler); function End_Of_Headers_Relay (ctx : SMFICTX_Pointer) return sfsistat; pragma convention(C, End_Of_Headers_Relay); function End_Of_Headers_Relay (ctx : SMFICTX_Pointer) return sfsistat is begin return sfsistat(Real_End_Of_Headers_Handler(ctx)); exception when E : others => return Oops(E); end End_Of_Headers_Relay; type C_Body_Handler is access function (ctx : SMFICTX_Pointer; bodyp : chars_ptr; len : size_t) return sfsistat; pragma convention(C, C_Body_Handler); function Body_Relay (ctx : SMFICTX_Pointer; bodyp : chars_ptr; len : size_t) return sfsistat; pragma convention(C, Body_Relay); function Body_Relay (ctx : SMFICTX_Pointer; bodyp : chars_ptr; len : size_t) return sfsistat is begin return sfsistat(Real_Body_Handler(ctx, Value(bodyp, len))); exception when E : others => return Oops(E); end Body_Relay; type C_End_Of_Message_Handler is access function (ctx : SMFICTX_Pointer) return sfsistat; pragma convention(C, C_End_Of_Message_Handler); function End_Of_Message_Relay (ctx : SMFICTX_Pointer) return sfsistat; pragma convention(C, End_Of_Message_Relay); function End_Of_Message_Relay (ctx : SMFICTX_Pointer) return sfsistat is begin return sfsistat(Real_End_Of_Message_Handler(ctx)); exception when E : others => return Oops(E); end End_Of_Message_Relay; type C_Abort_Handler is access function (ctx : SMFICTX_Pointer) return sfsistat; pragma convention(C, C_Abort_Handler); function Abort_Relay (ctx : SMFICTX_Pointer) return sfsistat; pragma convention(C, Abort_Relay); function Abort_Relay (ctx : SMFICTX_Pointer) return sfsistat is begin Real_Abort_Handler(ctx); return sfsistat(Continue); exception when E : others => return Oops(E); end Abort_Relay; type C_Close_Handler is access function (ctx : SMFICTX_Pointer) return sfsistat; pragma convention(C, C_Close_Handler); function Close_Relay (ctx : SMFICTX_Pointer) return sfsistat; pragma convention(C, Close_Relay); function Close_Relay (ctx : SMFICTX_Pointer) return sfsistat is begin Real_Close_Handler(ctx); return sfsistat(Continue); exception when E : others => return Oops(E); end Close_Relay; MI_SUCCESS : constant := 0; MI_FAILURE : constant := -1; procedure Raise_For_Error(Function_Name : String; Result_Code : int) is -- Raise_For_Error is called from Check_For_Error when a Libmilter function -- signals an error. It is not called from anywhere else. begin case Result_Code is when MI_SUCCESS => -- Check_For_Error ensures that this won't happen. raise Program_Error; when MI_FAILURE => raise Failure with Function_Name & " reported failure."; when others => raise Unknown_Error with Function_Name & " returned the undocumented result code " & Ada.Strings.Fixed.Trim(Result_Code'Img, Ada.Strings.Left) & '.'; end case; end Raise_For_Error; procedure Check_For_Error(Function_Name : String; Result_Code : int) is -- Check_For_Error checks the result code from a Libmilter function and -- raises an exception if the result code indicates an error. begin if Result_Code /= MI_SUCCESS then Raise_For_Error(Function_Name, Result_Code); end if; end Check_For_Error; pragma Inline(Check_For_Error); -- Some of the Libmilter functions wrapped below are specified to always -- return MI_SUCCESS, but we always check for errors anyway, just in case -- they return something unexpected one day. They do return a result code -- after all. 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) is type smfiDesc is record xxfi_name : chars_ptr := New_String(Name); xxfi_version : int; xxfi_flags : unsigned_long := 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; 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; end if; if Helo /= null then Real_Helo_Handler := Helo; Definition.xxfi_helo := Helo_Relay'Access; end if; if Sender /= null then Real_Sender_Handler := Sender; Definition.xxfi_envfrom := Sender_Relay'Access; end if; if Recipient /= null then Real_Recipient_Handler := Recipient; Definition.xxfi_envrcpt := Recipient_Relay'Access; end if; if Header /= null then Real_Header_Handler := Header; Definition.xxfi_header := Header_Relay'Access; end if; if End_Of_Headers /= null then Real_End_Of_Headers_Handler := End_Of_Headers; Definition.xxfi_eoh := End_Of_Headers_Relay'Access; end if; if Body_Chunk /= null then Real_Body_Handler := Body_Chunk; Definition.xxfi_body := Body_Relay'Access; end if; if End_Of_Message /= null then Real_End_Of_Message_Handler := End_Of_Message; Definition.xxfi_eom := End_Of_Message_Relay'Access; end if; if Aborted /= null then Real_Abort_Handler := Aborted; Definition.xxfi_abort := Abort_Relay'Access; end if; if Closed /= null then Real_Close_Handler := Closed; Definition.xxfi_close := Close_Relay'Access; end if; if Unknown_Command /= null then Real_Unknown_Command_Handler := Unknown_Command; Definition.xxfi_unknown := Unknown_Command_Relay'Access; end if; if Data /= null then 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)); end Register; procedure Set_Timeout(Timeout : Natural) is function smfi_settimeout(otimeout : int) return int; pragma import(C, smfi_settimeout); begin Check_For_Error("smfi_settimeout", smfi_settimeout(int(Timeout))); end Set_Timeout; procedure Set_Connection_Queue_Length(Length : Positive) is function smfi_setbacklog(obacklog : int) return int; pragma import(C, smfi_setbacklog); begin Check_For_Error("smfi_setbacklog", smfi_setbacklog(int(Length))); end Set_Connection_Queue_Length; procedure Set_Socket(Address : String) is function smfi_setconn(oconn : char_array) return int; pragma import(C, smfi_setconn); begin Check_For_Error("smfi_setconn", smfi_setconn(To_C(Address))); end Set_Socket; procedure Open_Socket(Remove_Old_Socket : Boolean) is function smfi_opensocket(rmsocket : int) return 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; begin Check_For_Error("smfi_opensocket", smfi_opensocket(I(Remove_Old_Socket))); end Open_Socket; procedure Start_Wrapping is separate; -- If thread wrapping was enabled at compile time, then Start_Wrapping tells -- the thread wrapper to start wrapping threads. Otherwise it does nothing. pragma Inline(Start_Wrapping); procedure Main is function smfi_main return int; pragma import(C, smfi_main); begin Start_Wrapping; Check_For_Error("smfi_main", smfi_main); end Main; procedure Set_Debug_Level(Level : Natural) is function smfi_setdbg(level : int) return int; pragma import(C, smfi_setdbg); begin Check_For_Error("smfi_setdbg", smfi_setdbg(int(Level))); end Set_Debug_Level; procedure Stop is function smfi_stop return int; pragma import(C, smfi_stop); begin Check_For_Error("smfi_stop", 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))); Current : String_Arrays.Pointer := Handle.Pointer; begin for Index in Ustrings'Range loop Set_Unbounded_String(Ustrings(Index), Value(Current.all)); String_Arrays.Increment(Current); end loop; return Ustrings; end Arguments; procedure Get_Symbol_Value (Context : in SMFICTX_Pointer; Name : in String; Defined : out Boolean; Value : out Unbounded_String) is function smfi_getsymval (ctx : SMFICTX_Pointer; symname : char_array) return chars_ptr; pragma import(C, smfi_getsymval); Answer : chars_ptr; begin Answer := smfi_getsymval(Context, To_C(Name)); Defined := Answer /= Null_Ptr; if Defined then Set_Unbounded_String(Value, Strings.Value(Answer)); end if; end Get_Symbol_Value; procedure Set_Private_Data (Context : SMFICTX_Pointer; Data : Milter_Data_Pointer) is pragma Warnings(Off); -- Milter_Data doesn't correspond to any C type. function smfi_setpriv (ctx : SMFICTX_Pointer; privatedata : Milter_Data_Pointer) return int; pragma Warnings(On); pragma import(C, smfi_setpriv); -- It doesn't matter that Milter_Data doesn't correspond to any C type, -- because Libmilter only stores the pointer and doesn't care what it -- points to. begin Check_For_Error("smfi_setpriv", smfi_setpriv(Context, Data)); end Set_Private_Data; function Private_Data (Context : SMFICTX_Pointer) return Milter_Data_Pointer is pragma Warnings(Off); -- Milter_Data doesn't correspond to any C type. function smfi_getpriv(ctx : SMFICTX_Pointer) return Milter_Data_Pointer; pragma Warnings(On); pragma import(C, smfi_getpriv); begin return smfi_getpriv(Context); end Private_Data; procedure Set_Reply (Context : SMFICTX_Pointer; Reply_Code : String_Of_Three; Extended_Code : String := ""; Message : String := "") is function smfi_setreply (ctx : SMFICTX_Pointer; rcode : char_array; xcode : chars_ptr; message : chars_ptr) return int; pragma import(C, smfi_setreply); C_Extended_Code : aliased char_array := To_C(Extended_Code); C_Message : aliased char_array := To_C(Message); Extended_Code_Ptr : chars_ptr := Null_Ptr; Message_Ptr : chars_ptr := Null_Ptr; begin if Extended_Code'Length > 0 then Extended_Code_Ptr := To_Chars_Ptr(C_Extended_Code'Unchecked_Access); end if; if Message'Length > 0 then Message_Ptr := To_Chars_Ptr(C_Message'Unchecked_Access); end if; Check_For_Error("smfi_setreply", smfi_setreply(Context, To_C(Reply_Code), Extended_Code_Ptr, Message_Ptr)); end Set_Reply; procedure Set_Reply (Context : SMFICTX_Pointer; Reply_Code : String_Of_Three; Extended_Code : String := ""; Message : Reply_Lines) is separate; -- The functions Address and Port use the helper functions in -- sockaddr_functions.c to extract data from sockaddr structures. 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 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; Name : String; Value : String) is function smfi_addheader (ctx : SMFICTX_Pointer; headerf : char_array; headerv : char_array) return int; pragma import(C, smfi_addheader); begin Check_For_Error("smfi_addheader", smfi_addheader(Context, To_C(Name), To_C(Value))); end Add_Header; procedure Change_Header (Context : SMFICTX_Pointer; Name : String; Index : Positive; Value : String) is function smfi_chgheader (ctx : SMFICTX_Pointer; headerf : char_array; hdridx : int; headerv : char_array) return int; pragma import(C, smfi_chgheader); begin Check_For_Error("smfi_chgheader", smfi_chgheader(Context, To_C(Name), int(Index), To_C(Value))); end Change_Header; procedure Delete_Header (Context : SMFICTX_Pointer; Name : String; Index : Positive) is function smfi_chgheader (ctx : SMFICTX_Pointer; headerf : char_array; hdridx : int; headerv : chars_ptr) return int; pragma import(C, smfi_chgheader); begin Check_For_Error("smfi_chgheader", smfi_chgheader(Context, To_C(Name), int(Index), Null_Ptr)); end Delete_Header; procedure Insert_Header (Context : SMFICTX_Pointer; Index : Positive; Name : String; Value : String) is function smfi_insheader (ctx : SMFICTX_Pointer; hdridx : int; headerf : char_array; headerv : char_array) return int; pragma import(C, smfi_insheader); begin Check_For_Error("smfi_insheader", smfi_insheader(Context, int(Index - 1), To_C(Name), To_C(Value))); end Insert_Header; procedure Change_Sender (Context : SMFICTX_Pointer; Address : String; Parameters : String := "") is function smfi_chgfrom (ctx : SMFICTX_Pointer; mail : char_array; args : chars_ptr) return int; pragma import(C, smfi_chgfrom); 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_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 function smfi_delrcpt (ctx : SMFICTX_Pointer; rcpt : char_array) return int; pragma import(C, smfi_delrcpt); begin Check_For_Error("smfi_delrcpt", smfi_delrcpt(Context, To_C(Address))); end Delete_Recipient; procedure Replace_Body(Context : SMFICTX_Pointer; Data : String) is function smfi_replacebody (ctx : SMFICTX_Pointer; bodyp : char_array; bodylen : int) return int; pragma import(C, smfi_replacebody); begin Check_For_Error("smfi_replacebody", smfi_replacebody(Context, To_C(Item => Data, Append_Nul => False), Data'Length)); end Replace_Body; procedure Report_Progress(Context : SMFICTX_Pointer) is function smfi_progress(ctx : SMFICTX_Pointer) return int; pragma import(C, smfi_progress); begin Check_For_Error("smfi_progress", smfi_progress(Context)); end Report_Progress; procedure Quarantine_Message(Context : SMFICTX_Pointer; Reason : String) is function smfi_quarantine (ctx : SMFICTX_Pointer; reason : char_array) return int; pragma import(C, smfi_quarantine); begin Check_For_Error("smfi_quarantine", smfi_quarantine(Context, To_C(Reason))); end Quarantine_Message; end Milter_API;