From c362ad36de4002064ffbf0bd3c187c6857cc6795 Mon Sep 17 00:00:00 2001 From: Björn Persson Date: Mon, 4 Jan 2010 23:45:43 +0000 Subject: imported --- milter_api.adb | 778 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 778 insertions(+) create mode 100644 milter_api.adb (limited to 'milter_api.adb') diff --git a/milter_api.adb b/milter_api.adb new file mode 100644 index 0000000..f99235d --- /dev/null +++ b/milter_api.adb @@ -0,0 +1,778 @@ +-- Milter API for Ada, a binding to Libmilter, the Sendmail mail filtering API +-- Copyright 2009 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 Ada.Strings.Fixed; +with System_Log; use System_Log; + +package body Milter_API is + + pragma Linker_Options("-lmilter"); + pragma Linker_Options("-lpthread"); + + use Ada.Strings.Unbounded; + use type String_Arrays.Pointer; + + + Version : constant Binding_Version_Type := (1, 1, 1); + + 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; + + 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. + + + Real_Connect_Handler : Connect_Handler; + Real_Helo_Handler : Helo_Handler; + Real_Envelope_Sender_Handler : Envelope_Sender_Handler; + Real_Envelope_Recipient_Handler : Envelope_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; + + + type sfsistat is new int; + + + procedure Oops(E : Exception_Occurrence) is + begin + Log(Error, 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_Connect_Handler is access function + (ctx : SMFICTX_Pointer; + hostname : chars_ptr; + hostaddr : access Dummy_Type) + return sfsistat; + pragma convention(C, C_Connect_Handler); + + function Connect_Relay + (ctx : SMFICTX_Pointer; + hostname : chars_ptr; + hostaddr : access Dummy_Type) + return sfsistat; + pragma convention(C, Connect_Relay); + + function Connect_Relay + (ctx : SMFICTX_Pointer; + hostname : chars_ptr; + hostaddr : access Dummy_Type) + return sfsistat + is + Dummy : Sockaddr; + begin + return sfsistat(Real_Connect_Handler(ctx, Value(hostname), Dummy)); + 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_Envelope_Sender_Handler is access function + (ctx : SMFICTX_Pointer; + argv : String_Arrays.Pointer) + return sfsistat; + pragma convention(C, C_Envelope_Sender_Handler); + + function Envelope_Sender_Relay + (ctx : SMFICTX_Pointer; + argv : String_Arrays.Pointer) + return sfsistat; + pragma convention(C, Envelope_Sender_Relay); + + function Envelope_Sender_Relay + (ctx : SMFICTX_Pointer; + argv : String_Arrays.Pointer) + return sfsistat + is + begin + return sfsistat(Real_Envelope_Sender_Handler + (ctx, Value(argv.all), (Pointer => argv + 1))); + exception + when E : others => + return Oops(E); + end Envelope_Sender_Relay; + + type C_Envelope_Recipient_Handler is access function + (ctx : SMFICTX_Pointer; + argv : String_Arrays.Pointer) + return sfsistat; + pragma convention(C, C_Envelope_Recipient_Handler); + + function Envelope_Recipient_Relay + (ctx : SMFICTX_Pointer; + argv : String_Arrays.Pointer) + return sfsistat; + pragma convention(C, Envelope_Recipient_Relay); + + function Envelope_Recipient_Relay + (ctx : SMFICTX_Pointer; + argv : String_Arrays.Pointer) + return sfsistat + is + begin + return sfsistat(Real_Envelope_Recipient_Handler + (ctx, Value(argv.all), (Pointer => argv + 1))); + exception + when E : others => + return Oops(E); + end Envelope_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; + + + procedure Check_For_Error(Function_Name : String; Result_Code : int) is + MI_SUCCESS : constant := 0; + MI_FAILURE : constant := -1; + begin + case Result_Code is + when MI_SUCCESS => + return; + 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 Check_For_Error; + + + procedure Register + (Name : String; + Connected : Connect_Handler := null; + Helo : Helo_Handler := null; + Envelope_Sender : Envelope_Sender_Handler := null; + Envelope_Recipient : Envelope_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_Recepients : Boolean := False; + May_Remove_Recepients : Boolean := False; + May_Quarantine : 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_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_Recepients) + + SMFIF_DELRCPT * BI(May_Remove_Recepients) + + SMFIF_QUARANTINE * BI(May_Quarantine); + xxfi_connect : C_Connect_Handler := null; + xxfi_helo : C_Helo_Handler := null; + xxfi_envfrom : C_Envelope_Sender_Handler := null; + xxfi_envrcpt : C_Envelope_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; + end record; + pragma convention(C_Pass_By_Copy, smfiDesc); + Definition : smfiDesc; + + function smfi_register(descr : smfiDesc) return int; + pragma import(C, smfi_register); + + begin -- Register + + 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 Envelope_Sender /= null then + Real_Envelope_Sender_Handler := Envelope_Sender; + Definition.xxfi_envfrom := Envelope_Sender_Relay'Access; + end if; + if Envelope_Recipient /= null then + Real_Envelope_Recipient_Handler := Envelope_Recipient; + Definition.xxfi_envrcpt := Envelope_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; + + 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. I hope a bool is always an int. + 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 Main is + function smfi_main return int; + pragma import(C, smfi_main); + begin + 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 + procedure smfi_stop; + pragma import(C, smfi_stop); + begin + smfi_stop; + end Stop; + + 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 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 Add_Recipient(Context : SMFICTX_Pointer; Address : String) is + function smfi_addrcpt + (ctx : SMFICTX_Pointer; + rcpt : char_array) + return int; + pragma import(C, smfi_addrcpt); + begin + Check_For_Error("smfi_addrcpt", smfi_addrcpt(Context, To_C(Address))); + 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; -- cgit v1.2.3