gcc/ada/libgnat/g-sthcso.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --     G N A T . S O C K E T S . T H I N . C _ S O C K E T P A I R          --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 2001-2024, AdaCore                     --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 --  Portable sockets-based implementation of the C_Socketpair used for
  33 --  platforms that do not support UNIX socketpair system call.
  34
  35 --  Note: this code is only for non-UNIX platforms.
  36
  37 separate (GNAT.Sockets.Thin)
  38 function C_Socketpair
  39   (Domain   : C.int;
  40    Typ      : C.int;
  41    Protocol : C.int;
  42    Fds      : not null access Fd_Pair) return C.int
  43 is
  44    --  This use type clause is not required on all platforms
  45    --  using this implementation. So we suppress the warning
  46    --  for the platforms that already use this type.
  47    pragma Warnings (Off, "use clause for type *");
  48    use type C.char_array;
  49    pragma Warnings (On, "use clause for type *");
  50
  51    L_Sock, C_Sock, P_Sock : C.int := Failure;
  52    --  Listening socket, client socket and peer socket
  53
  54    Family : constant Family_Type :=
  55               (case Domain is
  56                   when SOSC.AF_INET  => Family_Inet,
  57                   when SOSC.AF_INET6 => Family_Inet6,
  58                   when others        => Family_Unspec);
  59
  60    Len   : aliased C.int := C.int (Lengths (Family));
  61
  62    C_Sin : aliased Sockaddr;
  63    C_Bin : aliased C.char_array (1 .. C.size_t (Len));
  64    for C_Bin'Address use C_Sin'Address;
  65    --  Address of listening and client socket and it's binary representation.
  66    --  We need binary representation because Ada does not allow to compare
  67    --  unchecked union if either of the operands lacks inferable discriminants.
  68    --  RM-B-3-3 23/2.
  69
  70    P_Sin : aliased Sockaddr;
  71    P_Bin : aliased C.char_array (1 .. C.size_t (Len));
  72    for P_Bin'Address use P_Sin'Address;
  73    --  Address of peer socket and it's binary representation
  74
  75    T_Sin : aliased Sockaddr;
  76    T_Bin : aliased C.char_array (1 .. C.size_t (Len));
  77    for T_Bin'Address use T_Sin'Address;
  78    --  Temporary address to compare and check that address and port of the
  79    --  socket equal to peer address and port of the opposite connected socket.
  80
  81    Res : C.int with Warnings => Off;
  82
  83 begin
  84    Set_Family (C_Sin.Sin_Family, Family);
  85
  86    case Family is
  87       when Family_Inet =>
  88          C_Sin.Sin_Addr.S_B1 := 127;
  89          C_Sin.Sin_Addr.S_B4 := 1;
  90
  91       when Family_Inet6 =>
  92          C_Sin.Sin6_Addr (C_Sin.Sin6_Addr'Last) := 1;
  93
  94       when others =>
  95          Set_Socket_Errno (SOSC.EAFNOSUPPORT);
  96          return Failure;
  97    end case;
  98
  99    for J in 1 .. 10 loop
 100       --  Retry loop, in case the C_Connect below fails
 101
 102       C_Sin.Sin_Port := 0;
 103
 104       --  Create a listening socket
 105
 106       L_Sock := C_Socket (Domain, Typ, Protocol);
 107       exit when L_Sock = Failure;
 108
 109       --  Bind the socket to an available port on localhost
 110
 111       Res := C_Bind (L_Sock, C_Sin'Address, Len);
 112       exit when Res = Failure;
 113
 114       --  Get assigned port
 115
 116       Res := C_Getsockname (L_Sock, C_Sin'Address, Len'Access);
 117       exit when Res = Failure;
 118
 119       --  Set socket to listen mode, with a backlog of 1 to guarantee that
 120       --  exactly one call to connect(2) succeeds.
 121
 122       Res := C_Listen (L_Sock, 1);
 123       exit when Res = Failure;
 124
 125       --  Create read end (client) socket
 126
 127       C_Sock := C_Socket (Domain, Typ, Protocol);
 128       exit when C_Sock = Failure;
 129
 130       --  Connect listening socket
 131
 132       Res := C_Connect (C_Sock, C_Sin'Address, Len);
 133
 134       if Res = Failure then
 135          --  In rare cases, the above C_Bind chooses a port that is still
 136          --  marked "in use", even though it has been closed (perhaps by some
 137          --  other process that has already exited). This causes the above
 138          --  C_Connect to fail with EADDRINUSE. In this case, we close the
 139          --  ports, and loop back to try again. This mysterious Windows
 140          --  behavior is documented. See, for example:
 141          --    http://msdn2.microsoft.com/en-us/library/ms737625.aspx
 142          --  In an experiment with 2000 calls, 21 required exactly one retry, 7
 143          --  required two, and none required three or more. Note that no delay
 144          --  is needed between retries; retrying C_Bind will typically produce
 145          --  a different port.
 146
 147          exit when Socket_Errno /= SOSC.EADDRINUSE;
 148
 149          goto Repeat;
 150       end if;
 151
 152       --  Since the call to connect(2) has succeeded and the backlog limit
 153       --  on the listening socket is 1, we know that there is now exactly
 154       --  one pending connection on L_Sock, which is the one from R_Sock.
 155
 156       P_Sin.Sun_Path := (others => C.nul);
 157
 158       P_Sock := C_Accept (L_Sock, P_Sin'Address, Len'Access);
 159       exit when P_Sock = Failure;
 160
 161       --  Address and port of the socket equal to peer address and port of the
 162       --  opposite connected socket.
 163
 164       Res := C_Getsockname (P_Sock, T_Sin'Address, Len'Access);
 165       exit when Res = Failure;
 166
 167       if T_Bin /= C_Bin then
 168          goto Repeat;
 169       end if;
 170
 171       --  Address and port of the socket equal to peer address and port of the
 172       --  opposite connected socket.
 173
 174       Res := C_Getsockname (C_Sock, T_Sin'Address, Len'Access);
 175       exit when Res = Failure;
 176
 177       if T_Bin /= P_Bin then
 178          goto Repeat;
 179       end if;
 180
 181       --  Close listening socket (ignore exit status)
 182
 183       Res := C_Close (L_Sock);
 184
 185       Fds.all := (Read_End => C_Sock, Write_End => P_Sock);
 186
 187       return Thin_Common.Success;
 188
 189       <<Repeat>>
 190       Res := C_Close (C_Sock);
 191       C_Sock := Failure;
 192       Res := C_Close (P_Sock);
 193       P_Sock := Failure;
 194       Res := C_Close (L_Sock);
 195       L_Sock := Failure;
 196    end loop;
 197
 198    declare
 199       Saved_Errno : constant Integer := Socket_Errno;
 200
 201    begin
 202       if P_Sock /= Failure then
 203          Res := C_Close (P_Sock);
 204       end if;
 205
 206       if C_Sock /= Failure then
 207          Res := C_Close (C_Sock);
 208       end if;
 209
 210       if L_Sock /= Failure then
 211          Res := C_Close (L_Sock);
 212       end if;
 213
 214       Set_Socket_Errno (Saved_Errno);
 215    end;
 216
 217    return Failure;
 218 end C_Socketpair;