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