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-2020, 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    use type C.char_array;
  45
  46    L_Sock, C_Sock, P_Sock : C.int := Failure;
  47    --  Listening socket, client socket and peer socket
  48
  49    Family : constant Family_Type :=
  50               (case Domain is
  51                   when SOSC.AF_INET  => Family_Inet,
  52                   when SOSC.AF_INET6 => Family_Inet6,
  53                   when others        => Family_Unspec);
  54
  55    Len   : aliased C.int := C.int (Lengths (Family));
  56
  57    C_Sin : aliased Sockaddr;
  58    C_Bin : aliased C.char_array (1 .. C.size_t (Len));
  59    for C_Bin'Address use C_Sin'Address;
  60    --  Address of listening and client socket and it's binary representation.
  61    --  We need binary representation because Ada does not allow to compare
  62    --  unchecked union if either of the operands lacks inferable discriminants.
  63    --  RM-B-3-3 23/2.
  64
  65    P_Sin : aliased Sockaddr;
  66    P_Bin : aliased C.char_array (1 .. C.size_t (Len));
  67    for P_Bin'Address use P_Sin'Address;
  68    --  Address of peer socket and it's binary representation
  69
  70    T_Sin : aliased Sockaddr;
  71    T_Bin : aliased C.char_array (1 .. C.size_t (Len));
  72    for T_Bin'Address use T_Sin'Address;
  73    --  Temporary address to compare and check that address and port of the
  74    --  socket equal to peer address and port of the opposite connected socket.
  75
  76    Res : C.int with Warnings => Off;
  77
  78 begin
  79    Set_Family (C_Sin.Sin_Family, Family);
  80
  81    case Family is
  82       when Family_Inet =>
  83          C_Sin.Sin_Addr.S_B1 := 127;
  84          C_Sin.Sin_Addr.S_B4 := 1;
  85
  86       when Family_Inet6 =>
  87          C_Sin.Sin6_Addr (C_Sin.Sin6_Addr'Last) := 1;
  88
  89       when others =>
  90          Set_Socket_Errno (SOSC.EAFNOSUPPORT);
  91          return Failure;
  92    end case;
  93
  94    for J in 1 .. 10 loop
  95       --  Retry loop, in case the C_Connect below fails
  96
  97       C_Sin.Sin_Port := 0;
  98
  99       --  Create a listening socket
 100
 101       L_Sock := C_Socket (Domain, Typ, Protocol);
 102       exit when L_Sock = Failure;
 103
 104       --  Bind the socket to an available port on localhost
 105
 106       Res := C_Bind (L_Sock, C_Sin'Address, Len);
 107       exit when Res = Failure;
 108
 109       --  Get assigned port
 110
 111       Res := C_Getsockname (L_Sock, C_Sin'Address, Len'Access);
 112       exit when Res = Failure;
 113
 114       --  Set socket to listen mode, with a backlog of 1 to guarantee that
 115       --  exactly one call to connect(2) succeeds.
 116
 117       Res := C_Listen (L_Sock, 1);
 118       exit when Res = Failure;
 119
 120       --  Create read end (client) socket
 121
 122       C_Sock := C_Socket (Domain, Typ, Protocol);
 123       exit when C_Sock = Failure;
 124
 125       --  Connect listening socket
 126
 127       Res := C_Connect (C_Sock, C_Sin'Address, Len);
 128
 129       if Res = Failure then
 130          --  In rare cases, the above C_Bind chooses a port that is still
 131          --  marked "in use", even though it has been closed (perhaps by some
 132          --  other process that has already exited). This causes the above
 133          --  C_Connect to fail with EADDRINUSE. In this case, we close the
 134          --  ports, and loop back to try again. This mysterious Windows
 135          --  behavior is documented. See, for example:
 136          --    http://msdn2.microsoft.com/en-us/library/ms737625.aspx
 137          --  In an experiment with 2000 calls, 21 required exactly one retry, 7
 138          --  required two, and none required three or more. Note that no delay
 139          --  is needed between retries; retrying C_Bind will typically produce
 140          --  a different port.
 141
 142          exit when Socket_Errno /= SOSC.EADDRINUSE;
 143
 144          goto Repeat;
 145       end if;
 146
 147       --  Since the call to connect(2) has succeeded and the backlog limit
 148       --  on the listening socket is 1, we know that there is now exactly
 149       --  one pending connection on L_Sock, which is the one from R_Sock.
 150
 151       P_Sin.Sun_Path := (others => C.nul);
 152
 153       P_Sock := C_Accept (L_Sock, P_Sin'Address, Len'Access);
 154       exit when P_Sock = Failure;
 155
 156       --  Address and port of the socket equal to peer address and port of the
 157       --  opposite connected socket.
 158
 159       Res := C_Getsockname (P_Sock, T_Sin'Address, Len'Access);
 160       exit when Res = Failure;
 161
 162       if T_Bin /= C_Bin then
 163          goto Repeat;
 164       end if;
 165
 166       --  Address and port of the socket equal to peer address and port of the
 167       --  opposite connected socket.
 168
 169       Res := C_Getsockname (C_Sock, T_Sin'Address, Len'Access);
 170       exit when Res = Failure;
 171
 172       if T_Bin /= P_Bin then
 173          goto Repeat;
 174       end if;
 175
 176       --  Close listening socket (ignore exit status)
 177
 178       Res := C_Close (L_Sock);
 179
 180       Fds.all := (Read_End => C_Sock, Write_End => P_Sock);
 181
 182       return Thin_Common.Success;
 183
 184       <<Repeat>>
 185       Res := C_Close (C_Sock);
 186       C_Sock := Failure;
 187       Res := C_Close (P_Sock);
 188       P_Sock := Failure;
 189       Res := C_Close (L_Sock);
 190       L_Sock := Failure;
 191    end loop;
 192
 193    declare
 194       Saved_Errno : constant Integer := Socket_Errno;
 195
 196    begin
 197       if P_Sock /= Failure then
 198          Res := C_Close (P_Sock);
 199       end if;
 200
 201       if C_Sock /= Failure then
 202          Res := C_Close (C_Sock);
 203       end if;
 204
 205       if L_Sock /= Failure then
 206          Res := C_Close (L_Sock);
 207       end if;
 208
 209       Set_Socket_Errno (Saved_Errno);
 210    end;
 211
 212    return Failure;
 213 end C_Socketpair;