1-- 2-- Copyright (C) 2011-2013 secunet Security Networks AG 3-- Copyright (C) 2011-2016 Reto Buerki <reet@codelabs.ch> 4-- Copyright (C) 2011-2016 Adrian-Ken Rueegsegger <ken@codelabs.ch> 5-- 6-- This program is free software; you can redistribute it and/or modify it 7-- under the terms of the GNU General Public License as published by the 8-- Free Software Foundation; either version 2 of the License, or (at your 9-- option) any later version. See <http://www.fsf.org/copyleft/gpl.txt>. 10-- 11-- This program is distributed in the hope that it will be useful, but 12-- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 13-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 14-- for more details. 15-- 16-- As a special exception, if other files instantiate generics from this 17-- unit, or you link this unit with other files to produce an 18-- executable this unit does not by itself cause the resulting 19-- executable to be covered by the GNU General Public License. This 20-- exception does not however invalidate any other reasons why the 21-- executable file might be covered by the GNU Public License. 22-- 23 24with GNAT.OS_Lib; 25 26with Anet.Errno; 27with Anet.OS_Constants; 28with Anet.Sockets.Thin; 29 30package body Anet.Sockets is 31 32 package C renames Interfaces.C; 33 34 use type Interfaces.C.unsigned_long; 35 use type Interfaces.C.long; 36 37 ------------------------------------------------------------------------- 38 39 function Check_Accept (Result : Interfaces.C.int) return Accept_Result_Type 40 is 41 begin 42 if Result = C_Failure then 43 if GNAT.OS_Lib.Errno = Constants.Sys.EINTR then 44 45 -- Aborted, most probably via an ATC in the receiver task. 46 47 return Accept_Op_Aborted; 48 end if; 49 50 -- Some other error occurred. 51 52 return Accept_Op_Error; 53 end if; 54 55 return Accept_Op_Ok; 56 end Check_Accept; 57 58 ------------------------------------------------------------------------- 59 60 procedure Check_Complete_Send 61 (Item : Ada.Streams.Stream_Element_Array; 62 Result : Interfaces.C.long; 63 Error_Msg : String) 64 is 65 use Ada.Streams; 66 67 Sent_Bytes : constant Stream_Element_Offset 68 := Item'First + (Stream_Element_Offset (Result) - Item'First); 69 begin 70 if Sent_Bytes /= Item'Length then 71 raise Socket_Error with Error_Msg & ", only" & Sent_Bytes'Img & " of" 72 & Item'Length'Img & " bytes sent"; 73 end if; 74 end Check_Complete_Send; 75 76 ------------------------------------------------------------------------- 77 78 function Check_Receive (Result : Interfaces.C.long) return Recv_Result_Type 79 is 80 begin 81 if Result = 0 then 82 83 -- The peer performed an orderly shutdown. 84 85 return Recv_Op_Orderly_Shutdown; 86 end if; 87 88 if Result = C_Failure then 89 if GNAT.OS_Lib.Errno = Constants.Sys.EINTR then 90 91 -- Aborted, most probably via an ATC in the receiver task. 92 93 return Recv_Op_Aborted; 94 end if; 95 96 -- Some other error occurred. 97 98 return Recv_Op_Error; 99 end if; 100 101 return Recv_Op_Ok; 102 end Check_Receive; 103 104 ------------------------------------------------------------------------- 105 106 procedure Close (Socket : in out Socket_Type) 107 is 108 Res : C.int; 109 begin 110 if Socket.Sock_FD /= -1 then 111 Res := Thin.C_Close (Socket.Sock_FD); 112 Errno.Check_Or_Raise 113 (Result => Res, 114 Message => "Unable to close socket"); 115 Socket.Sock_FD := -1; 116 Socket.Protocol := 0; 117 end if; 118 end Close; 119 120 ------------------------------------------------------------------------- 121 122 procedure Finalize (Socket : in out Socket_Type) 123 is 124 begin 125 Socket_Type'Class (Socket).Close; 126 end Finalize; 127 128 ------------------------------------------------------------------------- 129 130 procedure Init 131 (Socket : in out Socket_Type; 132 Family : Socket_Families.Family_Type; 133 Mode : Mode_Type; 134 Protocol : Double_Byte := 0) 135 is 136 Res : C.int; 137 begin 138 Res := Thin.C_Socket 139 (Domain => Socket_Families.Families (Family), 140 Typ => Modes (Mode), 141 Protocol => C.int (Protocol)); 142 Errno.Check_Or_Raise 143 (Result => Res, 144 Message => "Unable to create socket (" & Family'Img & "/" & Mode'Img & 145 ", protocol" & Protocol'Img & ")"); 146 147 Socket.Sock_FD := Res; 148 Socket.Protocol := Protocol; 149 end Init; 150 151 ------------------------------------------------------------------------- 152 153 procedure Listen 154 (Socket : Socket_Type; 155 Backlog : Positive := 1) 156 is 157 begin 158 Errno.Check_Or_Raise 159 (Result => Thin.C_Listen 160 (Socket => Socket.Sock_FD, 161 Backlog => C.int (Backlog)), 162 Message => "Unable to listen on socket with backlog" & Backlog'Img); 163 end Listen; 164 165 ------------------------------------------------------------------------- 166 167 procedure Receive 168 (Socket : Socket_Type; 169 Item : out Ada.Streams.Stream_Element_Array; 170 Last : out Ada.Streams.Stream_Element_Offset) 171 is 172 use type Ada.Streams.Stream_Element_Offset; 173 174 Res : C.long; 175 begin 176 Last := 0; 177 178 Res := Thin.C_Recv (S => Socket.Sock_FD, 179 Msg => Item'Address, 180 Len => Item'Length, 181 Flags => 0); 182 183 case Check_Receive (Result => Res) 184 is 185 when Recv_Op_Orderly_Shutdown | Recv_Op_Aborted => return; 186 when Recv_Op_Error => 187 raise Socket_Error with "Error receiving data from socket: " 188 & Errno.Get_Errno_String; 189 when Recv_Op_Ok => 190 Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1); 191 end case; 192 end Receive; 193 194 ------------------------------------------------------------------------- 195 196 procedure Send 197 (Socket : Socket_Type; 198 Item : Ada.Streams.Stream_Element_Array) 199 is 200 Res : C.long; 201 begin 202 Res := Thin.C_Send 203 (S => Socket.Sock_FD, 204 Buf => Item'Address, 205 Len => Item'Length, 206 Flags => Constants.Sys.MSG_NOSIGNAL); 207 208 Errno.Check_Or_Raise 209 (Result => C.int (Res), 210 Message => "Unable to send data on socket"); 211 Check_Complete_Send 212 (Item => Item, 213 Result => Res, 214 Error_Msg => "Incomplete send operation on socket"); 215 end Send; 216 217 ------------------------------------------------------------------------- 218 219 procedure Set_Nonblocking_Mode 220 (Socket : Socket_Type; 221 Enable : Boolean := True) 222 is 223 use Interfaces; 224 225 Flags : Unsigned_32 := Unsigned_32 226 (Thin.C_Fcntl 227 (Fd => Socket.Sock_FD, 228 Cmd => Constants.Sys.F_GETFL, 229 Arg => 0)); 230 begin 231 if Enable then 232 Flags := Flags or Unsigned_32 (OS_Constants.O_NONBLOCK); 233 else 234 Flags := Flags and not Unsigned_32 (OS_Constants.O_NONBLOCK); 235 end if; 236 237 Errno.Check_Or_Raise 238 (Result => Thin.C_Fcntl 239 (Fd => Socket.Sock_FD, 240 Cmd => Constants.Sys.F_SETFL, 241 Arg => C.int (Flags)), 242 Message => "Unable to set non-blocking mode to " & Enable'Img); 243 end Set_Nonblocking_Mode; 244 245 ------------------------------------------------------------------------- 246 247 procedure Set_Socket_Option 248 (Socket : Socket_Type; 249 Level : Level_Type := Socket_Level; 250 Option : Option_Name_Bool; 251 Value : Boolean) 252 is 253 Val : C.int := C.int (Boolean'Pos (Value)); 254 begin 255 Errno.Check_Or_Raise 256 (Result => Thin.C_Setsockopt 257 (S => Socket.Sock_FD, 258 Level => Levels (Level), 259 Optname => Options_Bool (Option), 260 Optval => Val'Address, 261 Optlen => Val'Size / 8), 262 Message => "Unable set boolean socket option " & Option'Img & " to " & 263 Value'Img); 264 end Set_Socket_Option; 265 266 ------------------------------------------------------------------------- 267 268 procedure Set_Socket_Option 269 (Socket : Socket_Type; 270 Level : Level_Type := Socket_Level; 271 Option : Option_Name_Str; 272 Value : String) 273 is 274 Val : constant C.char_array := C.To_C (Value); 275 begin 276 Errno.Check_Or_Raise 277 (Result => Thin.C_Setsockopt 278 (S => Socket.Sock_FD, 279 Level => Levels (Level), 280 Optname => Options_Str (Option), 281 Optval => Val'Address, 282 Optlen => Val'Size / 8), 283 Message => "Unable set string socket option " & Option'Img & " to '" & 284 Value & "'"); 285 end Set_Socket_Option; 286 287 ------------------------------------------------------------------------- 288 289 procedure Shutdown 290 (Socket : Socket_Type; 291 Method : Sock_Shutdown_Cmd) 292 is 293 begin 294 if Socket.Sock_FD /= -1 then 295 Errno.Check_Or_Raise 296 (Result => Thin.C_Shutdown 297 (S => Socket.Sock_FD, 298 How => Shutdown_Methods (Method)), 299 Message => "Unable to shutdown socket"); 300 end if; 301 end Shutdown; 302 303end Anet.Sockets; 304