imported

1 files changed, 778 insertions, 0 deletions

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;