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-2019, 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
37separate (GNAT.Sockets.Thin)
38function C_Socketpair
39  (Domain   : C.int;
40   Typ      : C.int;
41   Protocol : C.int;
42   Fds      : not null access Fd_Pair) return C.int
43is
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
78begin
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;
213end C_Socketpair;
214