1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                    G N A T . S O C K E T S . T H I N                     --
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--  This package provides a target dependent thin interface to the sockets
33--  layer for use by the GNAT.Sockets package (g-socket.ads). This package
34--  should not be directly with'ed by an applications program.
35
36--  This version is for NT
37
38with Ada.Unchecked_Conversion;
39with Interfaces.C.Strings;    use Interfaces.C.Strings;
40with System;                  use System;
41with System.Storage_Elements; use System.Storage_Elements;
42
43package body GNAT.Sockets.Thin is
44
45   use type C.unsigned;
46
47   WSAData_Dummy : array (1 .. 512) of C.int;
48
49   WS_Version : constant := 16#0202#;
50   --  Winsock 2.2
51
52   Initialized : Boolean := False;
53
54   function Standard_Connect
55     (S       : C.int;
56      Name    : System.Address;
57      Namelen : C.int) return C.int;
58   pragma Import (Stdcall, Standard_Connect, "connect");
59
60   function Standard_Select
61     (Nfds      : C.int;
62      Readfds   : access Fd_Set;
63      Writefds  : access Fd_Set;
64      Exceptfds : access Fd_Set;
65      Timeout   : Timeval_Access) return C.int;
66   pragma Import (Stdcall, Standard_Select, "select");
67
68   type Error_Type is
69     (N_EINTR,
70      N_EBADF,
71      N_EACCES,
72      N_EFAULT,
73      N_EINVAL,
74      N_EMFILE,
75      N_EWOULDBLOCK,
76      N_EINPROGRESS,
77      N_EALREADY,
78      N_ENOTSOCK,
79      N_EDESTADDRREQ,
80      N_EMSGSIZE,
81      N_EPROTOTYPE,
82      N_ENOPROTOOPT,
83      N_EPROTONOSUPPORT,
84      N_ESOCKTNOSUPPORT,
85      N_EOPNOTSUPP,
86      N_EPFNOSUPPORT,
87      N_EAFNOSUPPORT,
88      N_EADDRINUSE,
89      N_EADDRNOTAVAIL,
90      N_ENETDOWN,
91      N_ENETUNREACH,
92      N_ENETRESET,
93      N_ECONNABORTED,
94      N_ECONNRESET,
95      N_ENOBUFS,
96      N_EISCONN,
97      N_ENOTCONN,
98      N_ESHUTDOWN,
99      N_ETOOMANYREFS,
100      N_ETIMEDOUT,
101      N_ECONNREFUSED,
102      N_ELOOP,
103      N_ENAMETOOLONG,
104      N_EHOSTDOWN,
105      N_EHOSTUNREACH,
106      N_WSASYSNOTREADY,
107      N_WSAVERNOTSUPPORTED,
108      N_WSANOTINITIALISED,
109      N_WSAEDISCON,
110      N_HOST_NOT_FOUND,
111      N_TRY_AGAIN,
112      N_NO_RECOVERY,
113      N_NO_DATA,
114      N_OTHERS);
115
116   Error_Messages : constant array (Error_Type) of chars_ptr :=
117     (N_EINTR =>
118        New_String ("Interrupted system call"),
119      N_EBADF =>
120        New_String ("Bad file number"),
121      N_EACCES =>
122        New_String ("Permission denied"),
123      N_EFAULT =>
124        New_String ("Bad address"),
125      N_EINVAL =>
126        New_String ("Invalid argument"),
127      N_EMFILE =>
128        New_String ("Too many open files"),
129      N_EWOULDBLOCK =>
130        New_String ("Operation would block"),
131      N_EINPROGRESS =>
132        New_String ("Operation now in progress. This error is "
133                    & "returned if any Windows Sockets API "
134                    & "function is called while a blocking "
135                    & "function is in progress"),
136      N_EALREADY =>
137        New_String ("Operation already in progress"),
138      N_ENOTSOCK =>
139        New_String ("Socket operation on nonsocket"),
140      N_EDESTADDRREQ =>
141        New_String ("Destination address required"),
142      N_EMSGSIZE =>
143        New_String ("Message too long"),
144      N_EPROTOTYPE =>
145        New_String ("Protocol wrong type for socket"),
146      N_ENOPROTOOPT =>
147        New_String ("Protocol not available"),
148      N_EPROTONOSUPPORT =>
149        New_String ("Protocol not supported"),
150      N_ESOCKTNOSUPPORT =>
151        New_String ("Socket type not supported"),
152      N_EOPNOTSUPP =>
153        New_String ("Operation not supported on socket"),
154      N_EPFNOSUPPORT =>
155        New_String ("Protocol family not supported"),
156      N_EAFNOSUPPORT =>
157        New_String ("Address family not supported by protocol family"),
158      N_EADDRINUSE =>
159        New_String ("Address already in use"),
160      N_EADDRNOTAVAIL =>
161        New_String ("Cannot assign requested address"),
162      N_ENETDOWN =>
163        New_String ("Network is down. This error may be "
164                    & "reported at any time if the Windows "
165                    & "Sockets implementation detects an "
166                    & "underlying failure"),
167      N_ENETUNREACH =>
168        New_String ("Network is unreachable"),
169      N_ENETRESET =>
170        New_String ("Network dropped connection on reset"),
171      N_ECONNABORTED =>
172        New_String ("Software caused connection abort"),
173      N_ECONNRESET =>
174        New_String ("Connection reset by peer"),
175      N_ENOBUFS =>
176        New_String ("No buffer space available"),
177      N_EISCONN  =>
178        New_String ("Socket is already connected"),
179      N_ENOTCONN =>
180        New_String ("Socket is not connected"),
181      N_ESHUTDOWN =>
182        New_String ("Cannot send after socket shutdown"),
183      N_ETOOMANYREFS =>
184        New_String ("Too many references: cannot splice"),
185      N_ETIMEDOUT =>
186        New_String ("Connection timed out"),
187      N_ECONNREFUSED =>
188        New_String ("Connection refused"),
189      N_ELOOP =>
190        New_String ("Too many levels of symbolic links"),
191      N_ENAMETOOLONG =>
192        New_String ("File name too long"),
193      N_EHOSTDOWN =>
194        New_String ("Host is down"),
195      N_EHOSTUNREACH =>
196        New_String ("No route to host"),
197      N_WSASYSNOTREADY =>
198        New_String ("Returned by WSAStartup(), indicating that "
199                    & "the network subsystem is unusable"),
200      N_WSAVERNOTSUPPORTED =>
201        New_String ("Returned by WSAStartup(), indicating that "
202                    & "the Windows Sockets DLL cannot support "
203                    & "this application"),
204      N_WSANOTINITIALISED =>
205        New_String ("Winsock not initialized. This message is "
206                    & "returned by any function except WSAStartup(), "
207                    & "indicating that a successful WSAStartup() has "
208                    & "not yet been performed"),
209      N_WSAEDISCON =>
210        New_String ("Disconnected"),
211      N_HOST_NOT_FOUND =>
212        New_String ("Host not found. This message indicates "
213                    & "that the key (name, address, and so on) was not found"),
214      N_TRY_AGAIN =>
215        New_String ("Nonauthoritative host not found. This error may "
216                    & "suggest that the name service itself is not "
217                    & "functioning"),
218      N_NO_RECOVERY =>
219        New_String ("Nonrecoverable error. This error may suggest that the "
220                    & "name service itself is not functioning"),
221      N_NO_DATA =>
222        New_String ("Valid name, no data record of requested type. "
223                    & "This error indicates that the key (name, address, "
224                    & "and so on) was not found."),
225      N_OTHERS =>
226        New_String ("Unknown system error"));
227
228   ---------------
229   -- C_Connect --
230   ---------------
231
232   function C_Connect
233     (S       : C.int;
234      Name    : System.Address;
235      Namelen : C.int) return C.int
236   is
237      Res : C.int;
238
239   begin
240      Res := Standard_Connect (S, Name, Namelen);
241
242      if Res = -1 then
243         if Socket_Errno = SOSC.EWOULDBLOCK then
244            Set_Socket_Errno (SOSC.EINPROGRESS);
245         end if;
246      end if;
247
248      return Res;
249   end C_Connect;
250
251   ------------------
252   -- Socket_Ioctl --
253   ------------------
254
255   function Socket_Ioctl
256     (S   : C.int;
257      Req : SOSC.IOCTL_Req_T;
258      Arg : access C.int) return C.int
259   is
260   begin
261      return C_Ioctl (S, Req, Arg);
262   end Socket_Ioctl;
263
264   ---------------
265   -- C_Recvmsg --
266   ---------------
267
268   function C_Recvmsg
269     (S     : C.int;
270      Msg   : System.Address;
271      Flags : C.int) return System.CRTL.ssize_t
272   is
273      use type C.size_t;
274
275      Fill  : constant Boolean :=
276                SOSC.MSG_WAITALL /= -1
277                  and then (C.unsigned (Flags) and SOSC.MSG_WAITALL) /= 0;
278      --  Is the MSG_WAITALL flag set? If so we need to fully fill all vectors
279
280      Res   : C.int;
281      Count : C.int := 0;
282
283      MH : Msghdr;
284      for MH'Address use Msg;
285
286      Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element;
287      for Iovec'Address use MH.Msg_Iov;
288      pragma Import (Ada, Iovec);
289
290      Iov_Index     : Integer;
291      Current_Iovec : Vector_Element;
292
293      function To_Access is new Ada.Unchecked_Conversion
294                                  (System.Address, Stream_Element_Reference);
295      pragma Warnings (Off, Stream_Element_Reference);
296
297      Req : Request_Type (Name => N_Bytes_To_Read);
298
299   begin
300      --  Windows does not provide an implementation of recvmsg(). The spec for
301      --  WSARecvMsg() is incompatible with the data types we define, and is
302      --  available starting with Windows Vista and Server 2008 only. So,
303      --  we use C_Recv instead.
304
305      --  Check how much data are available
306
307      Control_Socket (Socket_Type (S), Req);
308
309      --  Fill the vectors
310
311      Iov_Index := -1;
312      Current_Iovec := (Base => null, Length => 0);
313
314      loop
315         if Current_Iovec.Length = 0 then
316            Iov_Index := Iov_Index + 1;
317            exit when Iov_Index > Integer (Iovec'Last);
318            Current_Iovec := Iovec (SOSC.Msg_Iovlen_T (Iov_Index));
319         end if;
320
321         Res :=
322           C_Recv
323            (S,
324             Current_Iovec.Base.all'Address,
325             C.int (Current_Iovec.Length),
326             Flags);
327
328         if Res < 0 then
329            return System.CRTL.ssize_t (Res);
330
331         elsif Res = 0 and then not Fill then
332            exit;
333
334         else
335            pragma Assert (Interfaces.C.size_t (Res) <= Current_Iovec.Length);
336
337            Count := Count + Res;
338            Current_Iovec.Length :=
339              Current_Iovec.Length - Interfaces.C.size_t (Res);
340            Current_Iovec.Base :=
341              To_Access (Current_Iovec.Base.all'Address
342                + Storage_Offset (Res));
343
344            --  If all the data that was initially available read, do not
345            --  attempt to receive more, since this might block, or merge data
346            --  from successive datagrams for a datagram-oriented socket. We
347            --  still try to receive more if we need to fill all vectors
348            --  (MSG_WAITALL flag is set).
349
350            exit when Natural (Count) >= Req.Size
351              and then
352
353                --  Either we are not in fill mode
354
355                (not Fill
356
357                  --  Or else last vector filled
358
359                  or else (Interfaces.C.size_t (Iov_Index) = Iovec'Last
360                            and then Current_Iovec.Length = 0));
361         end if;
362      end loop;
363
364      return System.CRTL.ssize_t (Count);
365   end C_Recvmsg;
366
367   --------------
368   -- C_Select --
369   --------------
370
371   function C_Select
372     (Nfds      : C.int;
373      Readfds   : access Fd_Set;
374      Writefds  : access Fd_Set;
375      Exceptfds : access Fd_Set;
376      Timeout   : Timeval_Access) return C.int
377   is
378      Original_WFS : aliased Fd_Set;
379      Res          : C.int;
380      S            : aliased C.int;
381      Last         : aliased C.int;
382
383   begin
384      --  Asynchronous connection failures are notified in the exception fd
385      --  set instead of the write fd set. To ensure POSIX compatibility, copy
386      --  write fd set into exception fd set. Once select() returns, check any
387      --  socket present in the exception fd set and peek at incoming
388      --  out-of-band data. If the test is not successful, and the socket is
389      --  present in the initial write fd set, then move the socket from the
390      --  exception fd set to the write fd set.
391
392      if Writefds /= null then
393         Original_WFS := Writefds.all;
394
395         --  Add any socket present in write fd set into exception fd set
396
397         declare
398            WFS : aliased Fd_Set := Writefds.all;
399         begin
400            Last := Nfds - 1;
401            loop
402               Get_Socket_From_Set
403                 (WFS'Access, S'Unchecked_Access, Last'Unchecked_Access);
404               exit when S = -1;
405               Insert_Socket_In_Set (Exceptfds, S);
406            end loop;
407         end;
408      end if;
409
410      Res := Standard_Select (Nfds, Readfds, Writefds, Exceptfds, Timeout);
411
412      if Exceptfds /= null then
413         declare
414            EFSC    : aliased Fd_Set := Exceptfds.all;
415            Flag    : constant C.int := SOSC.MSG_PEEK + SOSC.MSG_OOB;
416            Buffer  : Character;
417            Length  : C.int;
418            Fromlen : aliased C.int;
419
420         begin
421            Last := Nfds - 1;
422            loop
423               Get_Socket_From_Set
424                 (EFSC'Access, S'Unchecked_Access, Last'Unchecked_Access);
425
426               --  No more sockets in EFSC
427
428               exit when S = -1;
429
430               --  Check out-of-band data
431
432               Length :=
433                 C_Recvfrom
434                  (S, Buffer'Address, 1, Flag,
435                   From    => System.Null_Address,
436                   Fromlen => Fromlen'Unchecked_Access);
437               --  Is Fromlen necessary if From is Null_Address???
438
439               --  If the signal is not an out-of-band data, then it
440               --  is a connection failure notification.
441
442               if Length = -1 then
443                  Remove_Socket_From_Set (Exceptfds, S);
444
445                  --  If S is present in the initial write fd set, move it from
446                  --  exception fd set back to write fd set. Otherwise, ignore
447                  --  this event since the user is not watching for it.
448
449                  if Writefds /= null
450                    and then Is_Socket_In_Set (Original_WFS'Access, S) /= 0
451                  then
452                     Insert_Socket_In_Set (Writefds, S);
453                  end if;
454               end if;
455            end loop;
456         end;
457      end if;
458
459      return Res;
460   end C_Select;
461
462   ---------------
463   -- C_Sendmsg --
464   ---------------
465
466   function C_Sendmsg
467     (S     : C.int;
468      Msg   : System.Address;
469      Flags : C.int) return System.CRTL.ssize_t
470   is
471      use type C.size_t;
472
473      Res   : C.int;
474      Count : C.int := 0;
475
476      MH : Msghdr;
477      for MH'Address use Msg;
478
479      Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element;
480      for Iovec'Address use MH.Msg_Iov;
481      pragma Import (Ada, Iovec);
482
483   begin
484      --  Windows does not provide an implementation of sendmsg(). The spec for
485      --  WSASendMsg() is incompatible with the data types we define, and is
486      --  available starting with Windows Vista and Server 2008 only. So
487      --  use C_Sendto instead.
488
489      for J in Iovec'Range loop
490         Res :=
491           C_Sendto
492            (S,
493             Iovec (J).Base.all'Address,
494             C.int (Iovec (J).Length),
495             Flags => Flags,
496             To    => MH.Msg_Name,
497             Tolen => C.int (MH.Msg_Namelen));
498
499         if Res < 0 then
500            return System.CRTL.ssize_t (Res);
501         else
502            Count := Count + Res;
503         end if;
504
505         --  Exit now if the buffer is not fully transmitted
506
507         exit when Interfaces.C.size_t (Res) < Iovec (J).Length;
508      end loop;
509
510      return System.CRTL.ssize_t (Count);
511   end C_Sendmsg;
512
513   ------------------
514   -- C_Socketpair --
515   ------------------
516
517   function C_Socketpair
518     (Domain   : C.int;
519      Typ      : C.int;
520      Protocol : C.int;
521      Fds      : not null access Fd_Pair) return C.int is separate;
522
523   --------------
524   -- Finalize --
525   --------------
526
527   procedure Finalize is
528   begin
529      if Initialized then
530         WSACleanup;
531         Initialized := False;
532      end if;
533   end Finalize;
534
535   -------------------------
536   -- Host_Error_Messages --
537   -------------------------
538
539   package body Host_Error_Messages is
540
541      --  On Windows, socket and host errors share the same code space, and
542      --  error messages are provided by Socket_Error_Message, so the default
543      --  separate body for Host_Error_Messages is not used in this case.
544
545      function Host_Error_Message (H_Errno : Integer) return String
546         renames Socket_Error_Message;
547
548   end Host_Error_Messages;
549
550   ----------------
551   -- Initialize --
552   ----------------
553
554   procedure Initialize is
555      Return_Value : Interfaces.C.int;
556   begin
557      if not Initialized then
558         Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address);
559         pragma Assert (Return_Value = 0);
560         Initialized := True;
561      end if;
562   end Initialize;
563
564   --------------------
565   -- Signalling_Fds --
566   --------------------
567
568   package body Signalling_Fds is separate;
569
570   --------------------------
571   -- Socket_Error_Message --
572   --------------------------
573
574   function Socket_Error_Message (Errno : Integer) return String is
575      use GNAT.Sockets.SOSC;
576
577      Errm : C.Strings.chars_ptr;
578
579   begin
580      case Errno is
581         when EINTR              => Errm := Error_Messages (N_EINTR);
582         when EBADF              => Errm := Error_Messages (N_EBADF);
583         when EACCES             => Errm := Error_Messages (N_EACCES);
584         when EFAULT             => Errm := Error_Messages (N_EFAULT);
585         when EINVAL             => Errm := Error_Messages (N_EINVAL);
586         when EMFILE             => Errm := Error_Messages (N_EMFILE);
587         when EWOULDBLOCK        => Errm := Error_Messages (N_EWOULDBLOCK);
588         when EINPROGRESS        => Errm := Error_Messages (N_EINPROGRESS);
589         when EALREADY           => Errm := Error_Messages (N_EALREADY);
590         when ENOTSOCK           => Errm := Error_Messages (N_ENOTSOCK);
591         when EDESTADDRREQ       => Errm := Error_Messages (N_EDESTADDRREQ);
592         when EMSGSIZE           => Errm := Error_Messages (N_EMSGSIZE);
593         when EPROTOTYPE         => Errm := Error_Messages (N_EPROTOTYPE);
594         when ENOPROTOOPT        => Errm := Error_Messages (N_ENOPROTOOPT);
595         when EPROTONOSUPPORT    => Errm := Error_Messages (N_EPROTONOSUPPORT);
596         when ESOCKTNOSUPPORT    => Errm := Error_Messages (N_ESOCKTNOSUPPORT);
597         when EOPNOTSUPP         => Errm := Error_Messages (N_EOPNOTSUPP);
598         when EPFNOSUPPORT       => Errm := Error_Messages (N_EPFNOSUPPORT);
599         when EAFNOSUPPORT       => Errm := Error_Messages (N_EAFNOSUPPORT);
600         when EADDRINUSE         => Errm := Error_Messages (N_EADDRINUSE);
601         when EADDRNOTAVAIL      => Errm := Error_Messages (N_EADDRNOTAVAIL);
602         when ENETDOWN           => Errm := Error_Messages (N_ENETDOWN);
603         when ENETUNREACH        => Errm := Error_Messages (N_ENETUNREACH);
604         when ENETRESET          => Errm := Error_Messages (N_ENETRESET);
605         when ECONNABORTED       => Errm := Error_Messages (N_ECONNABORTED);
606         when ECONNRESET         => Errm := Error_Messages (N_ECONNRESET);
607         when ENOBUFS            => Errm := Error_Messages (N_ENOBUFS);
608         when EISCONN            => Errm := Error_Messages (N_EISCONN);
609         when ENOTCONN           => Errm := Error_Messages (N_ENOTCONN);
610         when ESHUTDOWN          => Errm := Error_Messages (N_ESHUTDOWN);
611         when ETOOMANYREFS       => Errm := Error_Messages (N_ETOOMANYREFS);
612         when ETIMEDOUT          => Errm := Error_Messages (N_ETIMEDOUT);
613         when ECONNREFUSED       => Errm := Error_Messages (N_ECONNREFUSED);
614         when ELOOP              => Errm := Error_Messages (N_ELOOP);
615         when ENAMETOOLONG       => Errm := Error_Messages (N_ENAMETOOLONG);
616         when EHOSTDOWN          => Errm := Error_Messages (N_EHOSTDOWN);
617         when EHOSTUNREACH       => Errm := Error_Messages (N_EHOSTUNREACH);
618
619         --  Windows-specific error codes
620
621         when WSASYSNOTREADY     => Errm := Error_Messages (N_WSASYSNOTREADY);
622         when WSAVERNOTSUPPORTED =>
623            Errm := Error_Messages (N_WSAVERNOTSUPPORTED);
624         when WSANOTINITIALISED  =>
625            Errm := Error_Messages (N_WSANOTINITIALISED);
626         when WSAEDISCON         => Errm := Error_Messages (N_WSAEDISCON);
627
628         --  h_errno values
629
630         when HOST_NOT_FOUND     => Errm := Error_Messages (N_HOST_NOT_FOUND);
631         when TRY_AGAIN          => Errm := Error_Messages (N_TRY_AGAIN);
632         when NO_RECOVERY        => Errm := Error_Messages (N_NO_RECOVERY);
633         when NO_DATA            => Errm := Error_Messages (N_NO_DATA);
634         when others             => Errm := Error_Messages (N_OTHERS);
635      end case;
636
637      return Value (Errm);
638   end Socket_Error_Message;
639
640end GNAT.Sockets.Thin;
641