path: root/milter_api.adb

-- Ada Milter API, a binding to Libmilter, the Sendmail mail filtering API
-- Copyright 2009 - 2012 B. Persson, Bjorn@Rombobeorn.se
--
-- This library is free software: you can redistribute it and/or modify it
-- under the terms of the GNU General Public License version 3, as published
-- by the Free Software Foundation.


with Ada.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, 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;

   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
      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;


   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;
       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 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;

   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;

   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;
       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;