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-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-- 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 -- C_Socketpair -- 516 ------------------ 517 518 function C_Socketpair 519 (Domain : C.int; 520 Typ : C.int; 521 Protocol : C.int; 522 Fds : not null access Fd_Pair) return C.int is separate; 523 524 -------------- 525 -- Finalize -- 526 -------------- 527 528 procedure Finalize is 529 begin 530 if Initialized then 531 WSACleanup; 532 Initialized := False; 533 end if; 534 end Finalize; 535 536 ------------------------- 537 -- Host_Error_Messages -- 538 ------------------------- 539 540 package body Host_Error_Messages is 541 542 -- On Windows, socket and host errors share the same code space, and 543 -- error messages are provided by Socket_Error_Message, so the default 544 -- separate body for Host_Error_Messages is not used in this case. 545 546 function Host_Error_Message (H_Errno : Integer) return String 547 renames Socket_Error_Message; 548 549 end Host_Error_Messages; 550 551 ---------------- 552 -- Initialize -- 553 ---------------- 554 555 procedure Initialize is 556 Return_Value : Interfaces.C.int; 557 begin 558 if not Initialized then 559 Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address); 560 pragma Assert (Return_Value = 0); 561 Initialized := True; 562 end if; 563 end Initialize; 564 565 -------------------- 566 -- Signalling_Fds -- 567 -------------------- 568 569 package body Signalling_Fds is separate; 570 571 -------------------------- 572 -- Socket_Error_Message -- 573 -------------------------- 574 575 function Socket_Error_Message (Errno : Integer) return String is 576 use GNAT.Sockets.SOSC; 577 578 Errm : C.Strings.chars_ptr; 579 580 begin 581 case Errno is 582 when EINTR => Errm := Error_Messages (N_EINTR); 583 when EBADF => Errm := Error_Messages (N_EBADF); 584 when EACCES => Errm := Error_Messages (N_EACCES); 585 when EFAULT => Errm := Error_Messages (N_EFAULT); 586 when EINVAL => Errm := Error_Messages (N_EINVAL); 587 when EMFILE => Errm := Error_Messages (N_EMFILE); 588 when EWOULDBLOCK => Errm := Error_Messages (N_EWOULDBLOCK); 589 when EINPROGRESS => Errm := Error_Messages (N_EINPROGRESS); 590 when EALREADY => Errm := Error_Messages (N_EALREADY); 591 when ENOTSOCK => Errm := Error_Messages (N_ENOTSOCK); 592 when EDESTADDRREQ => Errm := Error_Messages (N_EDESTADDRREQ); 593 when EMSGSIZE => Errm := Error_Messages (N_EMSGSIZE); 594 when EPROTOTYPE => Errm := Error_Messages (N_EPROTOTYPE); 595 when ENOPROTOOPT => Errm := Error_Messages (N_ENOPROTOOPT); 596 when EPROTONOSUPPORT => Errm := Error_Messages (N_EPROTONOSUPPORT); 597 when ESOCKTNOSUPPORT => Errm := Error_Messages (N_ESOCKTNOSUPPORT); 598 when EOPNOTSUPP => Errm := Error_Messages (N_EOPNOTSUPP); 599 when EPFNOSUPPORT => Errm := Error_Messages (N_EPFNOSUPPORT); 600 when EAFNOSUPPORT => Errm := Error_Messages (N_EAFNOSUPPORT); 601 when EADDRINUSE => Errm := Error_Messages (N_EADDRINUSE); 602 when EADDRNOTAVAIL => Errm := Error_Messages (N_EADDRNOTAVAIL); 603 when ENETDOWN => Errm := Error_Messages (N_ENETDOWN); 604 when ENETUNREACH => Errm := Error_Messages (N_ENETUNREACH); 605 when ENETRESET => Errm := Error_Messages (N_ENETRESET); 606 when ECONNABORTED => Errm := Error_Messages (N_ECONNABORTED); 607 when ECONNRESET => Errm := Error_Messages (N_ECONNRESET); 608 when ENOBUFS => Errm := Error_Messages (N_ENOBUFS); 609 when EISCONN => Errm := Error_Messages (N_EISCONN); 610 when ENOTCONN => Errm := Error_Messages (N_ENOTCONN); 611 when ESHUTDOWN => Errm := Error_Messages (N_ESHUTDOWN); 612 when ETOOMANYREFS => Errm := Error_Messages (N_ETOOMANYREFS); 613 when ETIMEDOUT => Errm := Error_Messages (N_ETIMEDOUT); 614 when ECONNREFUSED => Errm := Error_Messages (N_ECONNREFUSED); 615 when ELOOP => Errm := Error_Messages (N_ELOOP); 616 when ENAMETOOLONG => Errm := Error_Messages (N_ENAMETOOLONG); 617 when EHOSTDOWN => Errm := Error_Messages (N_EHOSTDOWN); 618 when EHOSTUNREACH => Errm := Error_Messages (N_EHOSTUNREACH); 619 620 -- Windows-specific error codes 621 622 when WSASYSNOTREADY => Errm := Error_Messages (N_WSASYSNOTREADY); 623 when WSAVERNOTSUPPORTED => 624 Errm := Error_Messages (N_WSAVERNOTSUPPORTED); 625 when WSANOTINITIALISED => 626 Errm := Error_Messages (N_WSANOTINITIALISED); 627 when WSAEDISCON => Errm := Error_Messages (N_WSAEDISCON); 628 629 -- h_errno values 630 631 when HOST_NOT_FOUND => Errm := Error_Messages (N_HOST_NOT_FOUND); 632 when TRY_AGAIN => Errm := Error_Messages (N_TRY_AGAIN); 633 when NO_RECOVERY => Errm := Error_Messages (N_NO_RECOVERY); 634 when NO_DATA => Errm := Error_Messages (N_NO_DATA); 635 when others => Errm := Error_Messages (N_OTHERS); 636 end case; 637 638 return Value (Errm); 639 end Socket_Error_Message; 640 641end GNAT.Sockets.Thin; 642