File : net-portability.adb

with Net.Portability.Linux, System, Ada.Exceptions, Ada.Unchecked_Conversion;
use Net.Portability.Linux, System, Ada.Exceptions;
with Debug, Unchecked_Conversion;

with Interfaces.C, Interfaces.C.Strings;
use Interfaces.C, Interfaces.C.Strings;

package body Net.Portability is
   function Get_Debug return Debug_Mode;
   pragma Inline (Get_Debug);
   
   function Get_Debug return Debug_Mode is
   begin
      if do_debug /= Inherit then return do_debug;
      else                        return Net.do_debug;
      end if;
   end Get_Debug;
   
   subtype void_p is System.Address;

   type iovec is record
      iov_base : void_p;
      iov_len  : size_t;
   end record;
   pragma Pack (iovec);
   type iovec_p is access all iovec;
   pragma Convention (C, iovec_p);
   
   type msghdr is record
      msg_name    : void_p;
      msg_namelen : socklen_t;
      msg_iov     : iovec_p;
      msg_iovlen  : socklen_t;
      msg_control : void_p;
      msg_controllen : socklen_t;
      msg_flags   : int;
   end record;
   pragma Pack (msghdr);
   type msghdr_p is access all msghdr;
   pragma Convention (C, msghdr_p);
   
   type hw_addr is array (1 .. 6) of Integer_8;
   pragma Convention (C, hw_addr);
   pragma Pack (hw_addr);

   type sockaddr_ll is record
      sll_family   : unsigned_short := PF_PACKET;
      sll_protocol : unsigned_short;
      sll_ifindex  : int;
      sll_hatype   : unsigned_short;
      sll_pkttype  : unsigned_char;
      sll_halen    : unsigned_char;
      sll_addr     : hw_addr;
   end record;
   pragma Pack (sockaddr_ll);
   type sockaddr_ll_p is access all sockaddr_ll;
   pragma Convention (C, sockaddr_ll_p);
   
   function socket (domain  : int;
                    typ      : int;
                    protocol : int) return int;
   function bind (socket  : int;
                  address : sockaddr_ll_p;
                  addrlen : int) return int;
   function recvmsg (socket : int;
                     msg    : msghdr_p;
                     flags  : int) return int;
   pragma Import (C, socket, "socket");
   pragma Import (C, bind, "bind");
   pragma Import (C, recvmsg, "recvmsg");


   --  Convert tools

   function to_word (i :  Two_Int_8) return Integer_16 is
      function To_16 is new Unchecked_Conversion (Two_Int_8, Integer_16);
   begin
      if Default_Bit_Order = High_Order_First then
         return To_16 (i);
      else
         return To_16 ((i (2), i (1)));
      end if;
   end to_word;
   
   function to_dword (i : Four_Int_8) return Integer_32 is
      function To_32 is new Unchecked_Conversion (Four_Int_8, Integer_32);
   begin
      if Default_Bit_Order = High_Order_First then
         return To_32 (i);
      else
         return To_32 ((i (4), i (3), i (2), i (1)));
      end if;
   end to_dword;
   
   function from_word (i : Integer_16) return  Two_Int_8 is
      function From_16 is new Unchecked_Conversion (Integer_16, Two_Int_8);
      r : Two_Int_8 := From_16 (i);
   begin
      if Default_Bit_Order = High_Order_First then
         return r;
      else
         return (r (2), r (1));
      end if;
   end from_word;
   
   function from_dword (i : Integer_32) return Four_Int_8 is
      function From_32 is new Unchecked_Conversion (Integer_32, Four_Int_8);
      r : Four_Int_8 := From_32 (i);
   begin
      if Default_Bit_Order = High_Order_First then
         return r;
      else
         return (r (4), r (3), r (2), r (1));
      end if;
   end from_dword;
   
   --  C Error handling
 
   procedure raise_C_error (e : in Exception_Id; message : in String);
   procedure raise_C_error (e : in Exception_Id; message : in String) is
      errno : int;
      pragma Import (C, errno, "errno");
      function strerror (errnum : int) return chars_ptr;
      pragma Import (C, strerror, "strerror");
      m : String := message & ": " & To_Ada (Value (strerror (errno)));
   begin
      Raise_Exception (e, m);
   end raise_C_error;

   --  Real work starts here
   
   function open_interface (i : Natural) return Interface is
      function To_16 is new Unchecked_Conversion (Two_Int_8, Integer_16);
      itf : Interface := socket (PF_PACKET, SOCK_RAW,
              int (To_16 (from_word (Integer_16 (ETH_P_ALL)))));
   begin
      if itf = int (-1) then
         raise_C_error (Open_Error'Identity, "socket");
      end if;
      
      if i > 0 then
         declare
            adr : aliased sockaddr_ll := (sll_ifindex  => int (i),
                                          sll_family   => PF_PACKET,
                                          sll_protocol => 0,
                                          sll_hatype   => 0,
                                          sll_pkttype  => 0,
                                          sll_addr     => (others => 0),
                                          sll_halen    => 8);
            b : int := bind (itf, adr'Unchecked_Access, adr'Size / 8);
         begin
            if b = int (-1) then
               raise_C_error (Open_Error'Identity,
                              "bind" & Natural'Image (adr'Size / 8));
            end if;
         end;
      end if;
      
      return itf;
   end open_interface;

   --  should be a pointer to the network card memory
   data_buffer    : aliased System.Storage_Elements.Storage_Array (1 .. 2000);
   control_buffer : aliased System.Storage_Elements.Storage_Array (1 .. 2000);
   
   function Receive_Blob (i : Interface) return Payload_Type is
      io   : aliased iovec  := (iov_base => data_buffer'Address,
                                iov_len  => data_buffer'Size / 8);
      m    : aliased msghdr := (msg_name => Null_Address,
                                msg_namelen => 0,
                                msg_iov  => io'Unchecked_Access,
                                msg_iovlen  => 1,
                                msg_control    => control_buffer'Address,
                                msg_controllen => control_buffer'Length,
                                msg_flags => 0);
      len  : int := recvmsg (i, m'Unchecked_Access, 0);
   begin
      if int (-1) = len then
         raise_C_error (Read_Error'Identity, "recvmsg");
      end if;
      return (data => data_buffer'Address,
            length => Integer_32 (len));
   end Receive_Blob;
end Net.Portability;