1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373 | -- --
-- package Copyright (c) Dmitry A. Kazakov --
-- GNAT.Sockets.Server.Secure Luebeck --
-- Implementation Winter, 2015 --
-- --
-- Last revision : 18:41 01 Aug 2019 --
-- --
-- This library is free software; you can redistribute it and/or --
-- modify it under the terms of the GNU General Public License as --
-- published by the Free Software Foundation; either version 2 of --
-- the License, or (at your option) any later version. This library --
-- is distributed in the hope that it will be useful, but WITHOUT --
-- ANY WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --
-- General Public License for more details. You should have --
-- received a copy of the GNU General Public License along with --
-- this library; if not, write to the Free Software Foundation, --
-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from --
-- this unit, or you link this unit with other files to produce an --
-- executable, this unit does not by itself cause the resulting --
-- executable to be covered by the GNU General Public License. This --
-- exception does not however invalidate any other reasons why the --
-- executable file might be covered by the GNU Public License. --
--____________________________________________________________________--
with Ada.IO_Exceptions; use Ada.IO_Exceptions;
with System.Address_To_Access_Conversions;
package body GNAT.Sockets.Server.Secure is
package Socket_Pull is
new Transport_Set_Pull_Function
( Transport_Type => Connection'Class,
Get_Session => Get_Session,
Read => Read
);
package Socket_Push is
new Transport_Set_Push_Function
( Transport_Type => Connection'Class,
Get_Session => Get_Session,
Write => Write
);
package Conversions is
new System.Address_To_Access_Conversions (TLS_Session'Class);
function Create_Transport
( Factory : access Abstract_GNUTLS_Factory;
Listener : access Connections_Server'Class;
Client : access Connection'Class
) return Encoder_Ptr is
Result : Encoder_Ptr;
begin
if Client.Client then
Result := new TLS_Session
( Client.all'Unchecked_Access,
Factory.Decoded_Size,
Init_Client or Init_Nonblock
);
else
Result := new TLS_Session
( Client.all'Unchecked_Access,
Factory.Decoded_Size,
Init_Server or Init_Nonblock
);
end if;
declare
TLS : TLS_Session renames TLS_Session (Result.all);
Self : Abstract_GNUTLS_Factory'Class renames
Abstract_GNUTLS_Factory'Class (Factory.all);
begin
Session_Set_Ptr (TLS.Session, Client'Address);
Socket_Pull.Set (TLS.Session, Client);
Socket_Push.Set (TLS.Session, Client);
if Factory.Trace_Session then
Trace (Self, "TLS setting up session");
end if;
Prepare (Self, Client.all, TLS.Session);
if Factory.Trace_Session then
Trace (Self, "TLS handshake engaged");
end if;
end;
return Result;
end Create_Transport;
procedure Decrypt
( Transport : in out TLS_Session;
Client : in out Connection'Class;
Got_It : out Boolean
) is
Factory : Connections_Factory'Class renames
Client.Socket_Listener.Factory.all;
Buffer : Input_Buffer renames Transport.Buffer;
Last : Stream_Element_Offset;
begin
if Buffer.Free_To_Read < Buffer.First_Read then
--
-- [XXXXXXXXXXXXXX XXXXX]
-- Free_To_Read | First_Read |
--
Last := Buffer.First_Read - 2;
if Last <= Buffer.First_Read then -- Read buffer is full
Got_It := True;
return;
end if;
else
--
-- [ XXXXXXXXX ]
-- First_Read | | Free_To_Read
--
if ( Buffer.Free_To_Read - Buffer.First_Read
>= Buffer.Read'Length
)
then -- Read buffer is full
Got_It := True;
return;
elsif Buffer.Free_To_Read > Buffer.Read'Last then -- Wrap
Buffer.Free_To_Read := Buffer.Read'First;
Last := Buffer.First_Read - 2;
else
Last := Buffer.Read'Last;
end if;
end if;
Record_Recv
( Transport.Session,
Buffer.Read (Buffer.Free_To_Read..Last),
Last
);
if Last + 1 /= Buffer.Free_To_Read then -- Some data read
Got_It := True;
if Is_Trace_Received_On (Factory, Trace_Decoded) then
Trace_Received
( Factory => Factory,
Client => Client,
Data => Buffer.Read,
From => Buffer.Free_To_Read,
To => Last,
Encoded => False
);
end if;
Buffer.Expected :=
Stream_Element_Offset'Max
( Buffer.Expected - (Last - Buffer.Free_To_Read + 1),
0
);
Buffer.Free_To_Read := Last + 1;
else
Got_It := False;
end if;
exception
when End_Error =>
raise Connection_Error;
end Decrypt;
function Get_Session
( Client : Connection'Class
) return Session_Type_Ptr is
begin
return TLS_Session
( Client.Transport.all
) .Session'Unchecked_Access;
end Get_Session;
procedure Handshake_Completed
( Factory : in out Abstract_GNUTLS_Factory;
Client : in out Connection'Class;
Session : in out Session_Type
) is
begin
null;
end Handshake_Completed;
function Is_TLS_Capable
( Factory : Abstract_GNUTLS_Factory
) return Boolean is
begin
return True;
end Is_TLS_Capable;
function Is_Trace_Decoded (Factory : Abstract_GNUTLS_Factory)
return Boolean is
begin
return Factory.Trace_Decoded;
end Is_Trace_Decoded;
function Is_Trace_Session (Factory : Abstract_GNUTLS_Factory)
return Boolean is
begin
return Factory.Trace_Session;
end Is_Trace_Session;
procedure Process
( Transport : in out TLS_Session;
Listener : in out Connections_Server'Class;
Client : in out Connection'Class;
Data_Left : out Boolean
) is
begin
case Transport.State is
when TLS_Handshake =>
if Handshake (Transport.Session) then
Data_Left := Has_Data (Client);
else
declare
Factory : Abstract_GNUTLS_Factory'Class renames
Abstract_GNUTLS_Factory'Class
( Listener.Factory.all
);
begin
begin
Handshake_Completed
( Factory,
Client,
Transport.Session
);
exception
when Connection_Error =>
if Factory.Trace_Session then
Trace
( Factory,
"TLS successful handshake rejected"
);
end if;
raise;
when Error : others =>
if Factory.Trace_Session then
Trace
( Factory,
"TLS successful handshake rejected"
);
end if;
Trace_Error
( Factory,
"TLS handshake completion",
Error
);
raise Connection_Error;
end;
Transport.State := TLS_Exchange;
if Factory.Trace_Session then
if Session_Is_Resumed (Transport.Session) then
Trace
( Factory,
( "TLS handshake successful, "
& "resumed session: "
& Session_Get_Desc (Transport.Session)
) );
else
Trace
( Factory,
( "TLS handshake successful, "
& "new session: "
& Session_Get_Desc (Transport.Session)
) );
end if;
end if;
declare
Saved : constant Session_State := Client.Session;
begin
Client.Session := Session_Connected;
if Is_Opportunistic (Client) then
Elevated (Client);
else
Connected (Client);
end if;
Connected (Listener, Client);
Client.Session := Session_Active;
exception
when others =>
if Client.Session = Session_Connected then
Client.Session := Saved;
end if;
raise;
end;
end;
Data_Left := Has_Data (Client);
end if;
when TLS_Exchange =>
loop
Decrypt (Transport, Client, Data_Left);
exit when not Data_Left;
Process (Transport.Buffer, Client, Data_Left);
exit when Data_Left; -- Won't handle it right now
end loop;
end case;
end Process;
procedure Read
( Client : in out Connection'Class;
Data : in out Stream_Element_Array;
Pointer : in out Stream_Element_Offset
) is
Start : Stream_Element_Offset := Pointer;
begin
Pull (Client.Read, Data, Pointer);
exception
when Error : others =>
Trace_Error
( Client.Socket_Listener.Factory.all,
"TLS transport reading",
Error
);
raise;
end Read;
procedure Encode
( Transport : in out TLS_Session;
Client : in out Connection'Class;
Data : Stream_Element_Array;
Last : out Stream_Element_Offset
) is
begin
Record_Send (Transport.Session, Data, Last);
end Encode;
procedure Set_TLS_Tracing
( Factory : in out Abstract_GNUTLS_Factory;
Session : Boolean;
Decoded : Boolean
) is
begin
Factory.Trace_Session := Session;
Factory.Trace_Decoded := Decoded;
end Set_TLS_Tracing;
procedure Write
( Client : in out Connection'Class;
Data : Stream_Element_Array;
Pointer : in out Stream_Element_Offset
) is
Last : Stream_Element_Offset;
begin
Send_Socket
( Get_Socket (Client),
Data (Pointer..Data'Last),
Last
);
if ( Last >= Pointer
and then
Is_Trace_Sent_On
( Client.Socket_Listener.Factory.all,
Trace_Encoded
) )
then
Trace_Sent
( Factory => Client.Socket_Listener.Factory.all,
Client => Client,
Data => Data,
From => Pointer,
To => Last,
Encoded => True
);
end if;
if Last >= Pointer then
Client.Data_Sent := True;
Pointer := Last + 1;
end if;
exception
when Error : Socket_Error =>
Send_Error (Client, Error);
raise;
when Error : others =>
Trace_Error
( Client.Socket_Listener.Factory.all,
"TLS transport writing",
Error
);
raise;
end Write;
end GNAT.Sockets.Server.Secure;
|