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-2018, 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      pragma Warnings (Off, Exceptfds);
379
380      Original_WFS : aliased constant Fd_Set := Writefds.all;
381
382      Res  : C.int;
383      S    : aliased C.int;
384      Last : aliased C.int;
385
386   begin
387      --  Asynchronous connection failures are notified in the exception fd
388      --  set instead of the write fd set. To ensure POSIX compatibility, copy
389      --  write fd set into exception fd set. Once select() returns, check any
390      --  socket present in the exception fd set and peek at incoming
391      --  out-of-band data. If the test is not successful, and the socket is
392      --  present in the initial write fd set, then move the socket from the
393      --  exception fd set to the write fd set.
394
395      if Writefds /= No_Fd_Set_Access then
396
397         --  Add any socket present in write fd set into exception fd set
398
399         declare
400            WFS : aliased Fd_Set := Writefds.all;
401         begin
402            Last := Nfds - 1;
403            loop
404               Get_Socket_From_Set
405                 (WFS'Access, S'Unchecked_Access, Last'Unchecked_Access);
406               exit when S = -1;
407               Insert_Socket_In_Set (Exceptfds, S);
408            end loop;
409         end;
410      end if;
411
412      Res := Standard_Select (Nfds, Readfds, Writefds, Exceptfds, Timeout);
413
414      if Exceptfds /= No_Fd_Set_Access then
415         declare
416            EFSC    : aliased Fd_Set := Exceptfds.all;
417            Flag    : constant C.int := SOSC.MSG_PEEK + SOSC.MSG_OOB;
418            Buffer  : Character;
419            Length  : C.int;
420            Fromlen : aliased C.int;
421
422         begin
423            Last := Nfds - 1;
424            loop
425               Get_Socket_From_Set
426                 (EFSC'Access, S'Unchecked_Access, Last'Unchecked_Access);
427
428               --  No more sockets in EFSC
429
430               exit when S = -1;
431
432               --  Check out-of-band data
433
434               Length :=
435                 C_Recvfrom
436                  (S, Buffer'Address, 1, Flag,
437                   From    => System.Null_Address,
438                   Fromlen => Fromlen'Unchecked_Access);
439               --  Is Fromlen necessary if From is Null_Address???
440
441               --  If the signal is not an out-of-band data, then it
442               --  is a connection failure notification.
443
444               if Length = -1 then
445                  Remove_Socket_From_Set (Exceptfds, S);
446
447                  --  If S is present in the initial write fd set, move it from
448                  --  exception fd set back to write fd set. Otherwise, ignore
449                  --  this event since the user is not watching for it.
450
451                  if Writefds /= No_Fd_Set_Access
452                    and then (Is_Socket_In_Set (Original_WFS'Access, S) /= 0)
453                  then
454                     Insert_Socket_In_Set (Writefds, S);
455                  end if;
456               end if;
457            end loop;
458         end;
459      end if;
460      return Res;
461   end C_Select;
462
463   ---------------
464   -- C_Sendmsg --
465   ---------------
466
467   function C_Sendmsg
468     (S     : C.int;
469      Msg   : System.Address;
470      Flags : C.int) return System.CRTL.ssize_t
471   is
472      use type C.size_t;
473
474      Res   : C.int;
475      Count : C.int := 0;
476
477      MH : Msghdr;
478      for MH'Address use Msg;
479
480      Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element;
481      for Iovec'Address use MH.Msg_Iov;
482      pragma Import (Ada, Iovec);
483
484   begin
485      --  Windows does not provide an implementation of sendmsg(). The spec for
486      --  WSASendMsg() is incompatible with the data types we define, and is
487      --  available starting with Windows Vista and Server 2008 only. So
488      --  use C_Sendto instead.
489
490      for J in Iovec'Range loop
491         Res :=
492           C_Sendto
493            (S,
494             Iovec (J).Base.all'Address,
495             C.int (Iovec (J).Length),
496             Flags => Flags,
497             To    => MH.Msg_Name,
498             Tolen => C.int (MH.Msg_Namelen));
499
500         if Res < 0 then
501            return System.CRTL.ssize_t (Res);
502         else
503            Count := Count + Res;
504         end if;
505
506         --  Exit now if the buffer is not fully transmitted
507
508         exit when Interfaces.C.size_t (Res) < Iovec (J).Length;
509      end loop;
510
511      return System.CRTL.ssize_t (Count);
512   end C_Sendmsg;
513
514   --------------
515   -- Finalize --
516   --------------
517
518   procedure Finalize is
519   begin
520      if Initialized then
521         WSACleanup;
522         Initialized := False;
523      end if;
524   end Finalize;
525
526   -------------------------
527   -- Host_Error_Messages --
528   -------------------------
529
530   package body Host_Error_Messages is
531
532      --  On Windows, socket and host errors share the same code space, and
533      --  error messages are provided by Socket_Error_Message, so the default
534      --  separate body for Host_Error_Messages is not used in this case.
535
536      function Host_Error_Message (H_Errno : Integer) return String
537         renames Socket_Error_Message;
538
539   end Host_Error_Messages;
540
541   ----------------
542   -- Initialize --
543   ----------------
544
545   procedure Initialize is
546      Return_Value : Interfaces.C.int;
547   begin
548      if not Initialized then
549         Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address);
550         pragma Assert (Return_Value = 0);
551         Initialized := True;
552      end if;
553   end Initialize;
554
555   --------------------
556   -- Signalling_Fds --
557   --------------------
558
559   package body Signalling_Fds is separate;
560
561   --------------------------
562   -- Socket_Error_Message --
563   --------------------------
564
565   function Socket_Error_Message (Errno : Integer) return String is
566      use GNAT.Sockets.SOSC;
567
568      Errm : C.Strings.chars_ptr;
569
570   begin
571      case Errno is
572         when EINTR              => Errm := Error_Messages (N_EINTR);
573         when EBADF              => Errm := Error_Messages (N_EBADF);
574         when EACCES             => Errm := Error_Messages (N_EACCES);
575         when EFAULT             => Errm := Error_Messages (N_EFAULT);
576         when EINVAL             => Errm := Error_Messages (N_EINVAL);
577         when EMFILE             => Errm := Error_Messages (N_EMFILE);
578         when EWOULDBLOCK        => Errm := Error_Messages (N_EWOULDBLOCK);
579         when EINPROGRESS        => Errm := Error_Messages (N_EINPROGRESS);
580         when EALREADY           => Errm := Error_Messages (N_EALREADY);
581         when ENOTSOCK           => Errm := Error_Messages (N_ENOTSOCK);
582         when EDESTADDRREQ       => Errm := Error_Messages (N_EDESTADDRREQ);
583         when EMSGSIZE           => Errm := Error_Messages (N_EMSGSIZE);
584         when EPROTOTYPE         => Errm := Error_Messages (N_EPROTOTYPE);
585         when ENOPROTOOPT        => Errm := Error_Messages (N_ENOPROTOOPT);
586         when EPROTONOSUPPORT    => Errm := Error_Messages (N_EPROTONOSUPPORT);
587         when ESOCKTNOSUPPORT    => Errm := Error_Messages (N_ESOCKTNOSUPPORT);
588         when EOPNOTSUPP         => Errm := Error_Messages (N_EOPNOTSUPP);
589         when EPFNOSUPPORT       => Errm := Error_Messages (N_EPFNOSUPPORT);
590         when EAFNOSUPPORT       => Errm := Error_Messages (N_EAFNOSUPPORT);
591         when EADDRINUSE         => Errm := Error_Messages (N_EADDRINUSE);
592         when EADDRNOTAVAIL      => Errm := Error_Messages (N_EADDRNOTAVAIL);
593         when ENETDOWN           => Errm := Error_Messages (N_ENETDOWN);
594         when ENETUNREACH        => Errm := Error_Messages (N_ENETUNREACH);
595         when ENETRESET          => Errm := Error_Messages (N_ENETRESET);
596         when ECONNABORTED       => Errm := Error_Messages (N_ECONNABORTED);
597         when ECONNRESET         => Errm := Error_Messages (N_ECONNRESET);
598         when ENOBUFS            => Errm := Error_Messages (N_ENOBUFS);
599         when EISCONN            => Errm := Error_Messages (N_EISCONN);
600         when ENOTCONN           => Errm := Error_Messages (N_ENOTCONN);
601         when ESHUTDOWN          => Errm := Error_Messages (N_ESHUTDOWN);
602         when ETOOMANYREFS       => Errm := Error_Messages (N_ETOOMANYREFS);
603         when ETIMEDOUT          => Errm := Error_Messages (N_ETIMEDOUT);
604         when ECONNREFUSED       => Errm := Error_Messages (N_ECONNREFUSED);
605         when ELOOP              => Errm := Error_Messages (N_ELOOP);
606         when ENAMETOOLONG       => Errm := Error_Messages (N_ENAMETOOLONG);
607         when EHOSTDOWN          => Errm := Error_Messages (N_EHOSTDOWN);
608         when EHOSTUNREACH       => Errm := Error_Messages (N_EHOSTUNREACH);
609
610         --  Windows-specific error codes
611
612         when WSASYSNOTREADY     => Errm := Error_Messages (N_WSASYSNOTREADY);
613         when WSAVERNOTSUPPORTED =>
614            Errm := Error_Messages (N_WSAVERNOTSUPPORTED);
615         when WSANOTINITIALISED  =>
616            Errm := Error_Messages (N_WSANOTINITIALISED);
617         when WSAEDISCON         => Errm := Error_Messages (N_WSAEDISCON);
618
619         --  h_errno values
620
621         when HOST_NOT_FOUND     => Errm := Error_Messages (N_HOST_NOT_FOUND);
622         when TRY_AGAIN          => Errm := Error_Messages (N_TRY_AGAIN);
623         when NO_RECOVERY        => Errm := Error_Messages (N_NO_RECOVERY);
624         when NO_DATA            => Errm := Error_Messages (N_NO_DATA);
625         when others             => Errm := Error_Messages (N_OTHERS);
626      end case;
627
628      return Value (Errm);
629   end Socket_Error_Message;
630
631end GNAT.Sockets.Thin;
632