gnoga_2.1.2_5f127c56/deps/simple_components/gnat-sockets-server-secure.adb

  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;