sockets.adb

RTEMS (Real-Time Executive for Multiprocessor Systems) is a free open source real-time operating sys

-----------------------------------------------------------------------------
--                                                                         --
--                         ADASOCKETS COMPONENTS                           --
--                                                                         --
--                             S O C K E T S                               --
--                                                                         --
--                                B o d y                                  --
--                                                                         --
--                        $ReleaseVersion: 0.1.3 $                         --
--                                                                         --
--  Copyright (C) 1998  蒫ole Nationale Sup閞ieure des T閘閏ommunications  --
--                                                                         --
--   AdaSockets is free software; you can  redistribute it and/or modify   --
--   it  under terms of the GNU  General  Public License as published by   --
--   the Free Software Foundation; either version 2, or (at your option)   --
--   any later version.   AdaSockets is distributed  in the hope that it   --
--   will be useful, but WITHOUT ANY  WARRANTY; without even the implied   --
--   warranty of MERCHANTABILITY   or FITNESS FOR  A PARTICULAR PURPOSE.   --
--   See the GNU General Public  License  for more details.  You  should   --
--   have received a copy of the  GNU General Public License distributed   --
--   with AdaSockets; see   file COPYING.  If  not,  write  to  the Free   --
--   Software  Foundation, 59   Temple Place -   Suite  330,  Boston, MA   --
--   02111-1307, USA.                                                      --
--                                                                         --
--   As a special exception, if  other  files instantiate generics  from   --
--   this unit, or  you link this  unit with other  files to produce  an   --
--   executable,  this  unit does  not  by  itself cause  the  resulting   --
--   executable to be  covered by the  GNU General Public License.  This   --
--   exception does  not  however invalidate any  other reasons  why the   --
--   executable file might be covered by the GNU Public License.           --
--                                                                         --
--   The main repository for this software is located at:                  --
--       http://www-inf.enst.fr/ANC/                                       --
--                                                                         --
-----------------------------------------------------------------------------

with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
with Sockets.Constants;      use Sockets.Constants;
with Sockets.Link;
pragma Warnings (Off, Sockets.Link);
with Sockets.Naming;         use Sockets.Naming;
with Sockets.Thin;           use Sockets.Thin;
with Sockets.Utils;          use Sockets.Utils;

package body Sockets is

   use Ada.Streams, Interfaces.C;

   Socket_Domain_Match : constant array (Socket_Domain) of int :=
     (AF_INET => Constants.Af_Inet);

   Socket_Type_Match : constant array (Socket_Type) of int :=
     (SOCK_STREAM => Constants.Sock_Stream,
      SOCK_DGRAM  => Constants.Sock_Dgram);

   Shutdown_Type_Match : constant array (Shutdown_Type) of int :=
     (Receive => 0,
      Send    => 1,
      Both    => 2);

   Socket_Level_Match : constant array (Socket_Level) of int :=
     (SOL_SOCKET => Constants.Sol_Socket,
      IPPROTO_IP => Constants.Ipproto_Ip);

   Socket_Option_Match : constant array (Socket_Option) of int :=
     (SO_REUSEADDR       => Constants.So_Reuseaddr,
      IP_MULTICAST_TTL   => Constants.Ip_Multicast_Ttl,
      IP_ADD_MEMBERSHIP  => Constants.Ip_Add_Membership,
      IP_DROP_MEMBERSHIP => Constants.Ip_Drop_Membership,
      IP_MULTICAST_LOOP  => Constants.Ip_Multicast_Loop);

   Socket_Option_Size  : constant array (Socket_Option) of Natural :=
     (SO_REUSEADDR       => 4,
      IP_MULTICAST_TTL   => 1,
      IP_ADD_MEMBERSHIP  => 8,
      IP_DROP_MEMBERSHIP => 8,
      IP_MULTICAST_LOOP  => 1);

   function "*" (Left : String; Right : Natural) return String;
   pragma Inline ("*");

   CRLF : constant String := CR & LF;

   ---------
   -- "*" --
   ---------

   function "*" (Left : String; Right : Natural) return String is
      Result : String (1 .. Left'Length * Right);
      First  : Positive := 1;
      Last   : Natural  := First + Left'Length - 1;
   begin
      for I in 1 .. Right loop
         Result (First .. Last) := Left;
         First := First + Left'Length;
         Last  := Last + Left'Length;
      end loop;
      return Result;
   end "*";

   -------------------
   -- Accept_Socket --
   -------------------

   procedure Accept_Socket (Socket     : in Socket_FD;
                            New_Socket : out Socket_FD)
   is
      Sin  : aliased Sockaddr_In;
      Size : aliased int := Sin'Size / 8;
      Code : int;
   begin
      Code := C_Accept (Socket.FD, Sin'Address, Size'Access);
      if Code = Failure then
         Raise_With_Message ("Accept system call failed");
      else
         New_Socket := (FD => Code);
      end if;
   end Accept_Socket;

   ----------
   -- Bind --
   ----------

   procedure Bind
     (Socket : in Socket_FD;
      Port   : in Positive)
   is
      Sin : aliased Sockaddr_In;
   begin
      Sin.Sin_Family := Constants.Af_Inet;
      Sin.Sin_Port   := Port_To_Network (unsigned_short (Port));
      if C_Bind (Socket.FD, Sin'Address, Sin'Size / 8) = Failure then
         Raise_With_Message ("Bind failed");
      end if;
   end Bind;

   -------------
   -- Connect --
   -------------

   procedure Connect
     (Socket : in Socket_FD;
      Host   : in String;
      Port   : in Positive)
   is
      Sin : aliased Sockaddr_In;
   begin
      Sin.Sin_Family := Constants.Af_Inet;
      Sin.Sin_Addr   := To_In_Addr (Address_Of (Host));
      Sin.Sin_Port   := Port_To_Network (unsigned_short (Port));
      if C_Connect (Socket.FD, Sin'Address, Sin'Size / 8) = Failure then
         raise Connection_Refused;
      end if;
   end Connect;

   ---------------------------
   -- Customized_Setsockopt --
   ---------------------------

   procedure Customized_Setsockopt (Socket : in Socket_FD'Class;
                                    Optval : in Opt_Type)
   is
   begin
      pragma Assert (Optval'Size / 8 = Socket_Option_Size (Optname));
      if C_Setsockopt (Socket.FD, Socket_Level_Match (Level),
                       Socket_Option_Match (Optname),
                       Optval'Address, Optval'Size / 8) = Failure
      then
         Raise_With_Message ("Setsockopt failed");
      end if;
   end Customized_Setsockopt;

   ---------
   -- Get --
   ---------

   function Get (Socket : Socket_FD'Class) return String
   is
      Stream : constant Stream_Element_Array := Receive (Socket);
      Result : String (Positive (Stream'First) .. Positive (Stream'Last));
   begin
      for I in Stream'Range loop
         Result (Positive (I)) :=
           Character'Val (Stream_Element'Pos (Stream (I)));
      end loop;
      return Result;
   end Get;

   --------------
   -- Get_Line --
   --------------

   function Get_Line (Socket : Socket_FD'Class) return String is
      Result : String (1 .. 1024);
      Index  : Positive := Result'First;
      Byte   : Stream_Element_Array (1 .. 1);
      Char   : Character;
   begin
      loop
         Receive (Socket, Byte);
         Char := Character'Val (Stream_Element'Pos (Byte (Byte'First)));
         if Char = LF then
            return Result (1 .. Index - 1);
         elsif Char /= CR then
            Result (Index) := Char;
            Index := Index + 1;
            if Index > Result'Last then
               return Result & Get_Line (Socket);
            end if;
         end if;
      end loop;
   end Get_Line;

   ------------
   -- Listen --
   ------------

   procedure Listen
     (Socket     : in Socket_FD;
      Queue_Size : in Positive := 5)
   is
   begin
      if C_Listen (Socket.FD, int (Queue_Size)) = Failure then
         Raise_With_Message ("Listen failed");
      end if;
   end Listen;

   --------------
   -- New_Line --
   --------------

   procedure New_Line (Socket : in Socket_FD'Class;
                       Count  : in Natural := 1)
   is
   begin
      Put (Socket, CRLF * Count);
   end New_Line;

   ---------
   -- Put --
   ---------

   procedure Put (Socket : in Socket_FD'Class;
                  Str    : in String)
   is
      Stream : Stream_Element_Array (Stream_Element_Offset (Str'First) ..
                                     Stream_Element_Offset (Str'Last));
   begin
      for I in Str'Range loop
         Stream (Stream_Element_Offset (I)) :=
           Stream_Element'Val (Character'Pos (Str (I)));
      end loop;
      Send (Socket, Stream);
   end Put;

   --------------
   -- Put_Line --
   --------------

   procedure Put_Line (Socket : in Socket_FD'Class; Str : in String)
   is
   begin
      Put (Socket, Str & CRLF);
   end Put_Line;

   -------------
   -- Receive --
   -------------

   function Receive (Socket : Socket_FD; Max : Stream_Element_Count := 4096)
     return Ada.Streams.Stream_Element_Array
   is
      Buffer  : Stream_Element_Array (1 .. Max);
      Addr    : aliased In_Addr;
      Addrlen : aliased int := Addr'Size / 8;
      Count   : constant int :=
        C_Recvfrom (Socket.FD, Buffer'Address, Buffer'Length, 0,
                    Addr'Address, Addrlen'Access);
   begin
      if Count < 0 then
         Raise_With_Message ("Receive error");
      elsif Count = 0 then
         raise Connection_Closed;
      end if;
      return Buffer (1 .. Stream_Element_Offset (Count));
   end Receive;

   -------------
   -- Receive --
   -------------

   procedure Receive (Socket : in Socket_FD'Class;
                      Data   : out Ada.Streams.Stream_Element_Array)
   is
      Index : Stream_Element_Offset := Data'First;
      Rest  : Stream_Element_Count  := Data'Length;
   begin
      while Rest > 0 loop
         declare
            Sub_Buffer : constant Stream_Element_Array :=
              Receive (Socket, Rest);
            Length     : constant Stream_Element_Count := Sub_Buffer'Length;
         begin
            Data (Index .. Index + Length - 1) := Sub_Buffer;
            Index := Index + Length;
            Rest  := Rest - Length;
         end;
      end loop;
   end Receive;

   ----------
   -- Send --
   ----------

   procedure Send (Socket : in Socket_FD;
                   Data   : in Stream_Element_Array)
   is
      Index : Stream_Element_Offset  := Data'First;
      Rest  : Stream_Element_Count   := Data'Length;
      Count : int;
   begin
      while Rest > 0 loop
         Count := C_Send (Socket.FD, Data (Index) 'Address, int (Rest), 0);
         if Count < 0 then
            Raise_With_Message ("Send failed");
         elsif Count = 0 then
            raise Connection_Closed;
         end if;
         Index := Index + Stream_Element_Count (Count);
         Rest  := Rest - Stream_Element_Count (Count);
      end loop;
   end Send;

   ----------------
   -- Setsockopt --
   ----------------

   procedure Setsockopt
     (Socket  : in Socket_FD'Class;
      Level   : in Socket_Level := Sol_Socket;
      Optname : in Socket_Option;
      Optval  : in Integer)
   is
   begin
      case Socket_Option_Size (Optname) is

         when 1 =>
            declare
               C_Char_Optval : aliased char := char'Val (Optval);
            begin
               pragma Assert (C_Char_Optval'Size = 8);
               if C_Setsockopt (Socket.FD, Socket_Level_Match (Level),
                                Socket_Option_Match (Optname),
                                C_Char_Optval'Address, 1) = Failure
               then
                  Raise_With_Message ("Setsockopt failed");
               end if;
            end;

         when 4 =>
            declare
               C_Int_Optval : aliased int := int (Optval);
            begin
               pragma Assert (C_Int_Optval'Size = 32);
               if C_Setsockopt (Socket.FD, Socket_Level_Match (Level),
                                Socket_Option_Match (Optname),
                                C_Int_Optval'Address, 4) = Failure
               then
                  Raise_With_Message ("Setsockopt failed");
               end if;
            end;

         when others =>
            Raise_With_Message ("Setsockopt called with wrong arguments",
                                False);

      end case;
   end Setsockopt;

   --------------
   -- Shutdown --
   --------------

   procedure Shutdown (Socket : in Socket_FD;
                       How    : in Shutdown_Type := Both)
   is
   begin
      C_Shutdown (Socket.FD, Shutdown_Type_Match (How));
   end Shutdown;

   ------------
   -- Socket --
   ------------

   procedure Socket
     (Sock   : out Socket_FD;
      Domain : in Socket_Domain := AF_INET;
      Typ    : in Socket_Type   := SOCK_STREAM)
   is
      Result : constant int :=
        C_Socket (Socket_Domain_Match (Domain), Socket_Type_Match (Typ), 0);
   begin
      if Result = Failure then
         Raise_With_Message ("Unable to create socket");
      end if;
      Sock := (FD => Result);
   end Socket;

end Sockets;