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 | ------------------------------------------------------------------------------
-- Ada Web Server --
-- --
-- Copyright (C) 2000-2021, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify --
-- it under terms of the GNU General Public License as published by the --
-- Free Software Foundation; either version 3, 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. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are --
-- granted additional permissions described in the GCC Runtime Library --
-- Exception, version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- 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.Characters.Latin_1;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;
with Ada.Strings.Unbounded;
with Ada.Text_IO;
with AWS.Messages;
with AWS.Net.Buffered;
package body AWS.Headers is
use Ada;
use Ada.Strings.Unbounded;
use AWS.Containers;
use type Strings.Maps.Character_Set;
Printable_Set : constant Strings.Maps.Character_Set :=
Strings.Maps.To_Set
(Strings.Maps.Character_Range'
(Low => ' ',
High => Character'Val (126)));
-- This is RFC2616 CHAR except CTL
-- CHAR = <any US-ASCII character (octets 0 - 127)>
-- CTL = <any US-ASCII control character
-- (octets 0 - 31) and DEL (127)>
RFC2616_Separator_Set : constant Strings.Maps.Character_Set :=
Strings.Maps.To_Set
(" ()<>@,;:\""/[]?={}" & Characters.Latin_1.HT);
RFC2616_Token_Set : constant Strings.Maps.Character_Set :=
Printable_Set - RFC2616_Separator_Set;
Debug_Flag : Boolean := False;
-- Set to True to output debug information to the standard output
-----------
-- Debug --
-----------
procedure Debug (Activate : Boolean) is
begin
Debug_Flag := Activate;
end Debug;
-----------------
-- Debug_Print --
-----------------
procedure Debug_Print (Headers : List) is
begin
if Debug_Flag then
for J in 1 .. Headers.Count loop
Ada.Text_IO.Put_Line ('>' & Headers.Get_Line (J));
end loop;
end if;
end Debug_Print;
-----------------
-- Get_Content --
-----------------
procedure Get_Content
(Headers : List;
End_Block : Boolean := False) is
begin
for J in 1 .. Count (Headers) loop
Data (Get_Line (Headers, J) & CRLF);
end loop;
if End_Block then
Data (CRLF);
end if;
end Get_Content;
--------------
-- Get_Line --
--------------
function Get_Line (Headers : List; N : Positive) return String is
Pair : constant Element := Get (Headers, N);
begin
if Pair.Name = "" then
return "";
elsif Pair.Name = Messages.Get_Token
or else Pair.Name = Messages.Post_Token
or else Pair.Name = Messages.Put_Token
or else Pair.Name = Messages.Head_Token
or else Pair.Name = Messages.Delete_Token
or else Pair.Name = Messages.Connect_Token
or else Pair.Name = HTTP_Version
then
-- And header line
return To_String (Pair.Name & " " & Pair.Value);
else
return To_String (Pair.Name & ": " & Pair.Value);
end if;
end Get_Line;
----------------
-- Get_Values --
----------------
function Get_Values (Headers : List; Name : String) return String is
Values : constant VString_Array := Get_Values (Headers, Name);
function Get_Values (Start_From : Positive) return String;
-- Return string of header values comma separated
-- concateneted starting from Start_From index.
----------------
-- Get_Values --
----------------
function Get_Values (Start_From : Positive) return String is
Value : constant String := To_String (Values (Start_From));
begin
if Start_From = Values'Last then
return Value;
else
return Value & ", " & Get_Values (Start_From + 1);
end if;
end Get_Values;
begin
if Values'Length > 0 then
return Get_Values (Values'First);
else
return "";
end if;
end Get_Values;
------------
-- Length --
------------
function Length (Headers : AWS.Headers.List) return Natural is
L : Natural := 2; -- The ending CR+LF
begin
for J in 1 .. AWS.Headers.Count (Headers) loop
L := L
+ AWS.Headers.Get_Line
(Headers => Headers,
N => J)'Length + 2;
end loop;
return L;
end Length;
----------
-- Read --
----------
procedure Read (Headers : in out List; Socket : Net.Socket_Type'Class) is
function Get_Line return String;
-- Read a line from socket
--------------
-- Get_Line --
--------------
function Get_Line return String is
begin
return Net.Buffered.Get_Line (Socket);
end Get_Line;
procedure Read is new Read_G (Get_Line);
begin
Read (Headers);
end Read;
------------
-- Read_G --
------------
procedure Read_G (Headers : in out List) is
procedure Parse_Header_Line (Line : String);
-- Parse this line, update Headers accordingly
-----------------------
-- Parse_Header_Line --
-----------------------
procedure Parse_Header_Line (Line : String) is
use Ada.Strings;
Delimiter_Index : Natural;
begin
if Debug_Flag then
Text_IO.Put_Line ('>' & Line);
end if;
-- Put name and value to the container separately
Delimiter_Index := Fixed.Index
(Source => Line,
Set => RFC2616_Token_Set,
Test => Outside);
if Delimiter_Index = 0 -- No delimiter
or else Delimiter_Index = Line'First -- Empty name
or else Line (Delimiter_Index) /= ':' -- Wrong separator
then
-- No delimiter, this is not a valid Header Line
raise Format_Error with Line;
end if;
Add (Headers,
Name => Line (Line'First .. Delimiter_Index - 1),
Value => Fixed.Trim
(Line (Delimiter_Index + 1 .. Line'Last),
Side => Both));
end Parse_Header_Line;
End_Of_Message : constant String := "";
Line : Unbounded_String := To_Unbounded_String (Get_Line);
begin
Reset (Headers);
-- Parse the Line eventually catenated with the next line if it is a
-- continuation line see [RFC 2616 - 4.2].
loop
exit when Line = Null_Unbounded_String;
declare
Next_Line : constant String := Get_Line;
begin
if Next_Line /= End_Of_Message
and then
(Next_Line (Next_Line'First) = ' '
or else Next_Line (Next_Line'First) = ASCII.HT)
then
-- Continuing value on the next line. Header fields can be
-- extended over multiple lines by preceding each extra
-- line with at least one SP or HT.
Append (Line, Next_Line);
else
-- Handle current line
Parse_Header_Line (To_String (Line));
-- Then start another line with read content
Line := To_Unbounded_String (Next_Line);
end if;
end;
end loop;
end Read_G;
-----------
-- Reset --
-----------
overriding procedure Reset (Headers : in out List) is
begin
Tables.Reset (Tables.Table_Type (Headers));
Headers.Case_Sensitive (False);
end Reset;
-----------------
-- Send_Header --
-----------------
procedure Send_Header
(Socket : Net.Socket_Type'Class;
Headers : List;
End_Block : Boolean := False)
is
procedure Send (Value : String);
-- Send data over socket
----------
-- Send --
----------
procedure Send (Value : String) is
begin
Net.Buffered.Put (Socket, Value);
end Send;
procedure Send_Headers_Content is new Get_Content (Send);
begin
Send_Headers_Content (Headers, End_Block);
if End_Block then
Net.Buffered.Flush (Socket);
end if;
end Send_Header;
end AWS.Headers;
|