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