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 | --------------------------------------------------------------------------
-- file : multidb.adb [$Revision: 110555 $]
--------------------------------------------------------------------------
-- This is a modification of "multiecho.adb", to implement instead
-- a simple database. It illustrates the use of Ada direct I/O.
-- The present version has at least one flaw. The socket input '!'
-- is supposed to shut down the server, by aborting the main task.
-- This is not working correctly, probably due to a bad interaction
-- between the "accept" operation and the task abort. I need to look
-- into this more, but you should not need this capability for your
-- projects.
-- Ted Baker
with ada.characters.latin_1;
with ada.exceptions;
with ada.task_identification;
with ada.text_io;
with sockets;
with sockets.internet;
with table;
procedure multidb is
use table;
type connection_id is range 1..4;
connections : array (connection_id) of sockets.stream_socket;
procedure shut_down (e : ada.exceptions.exception_occurrence);
main_task : constant ada.task_identification.task_id :=
ada.task_identification.current_task;
-- used to shut down the entire program
task type server_task;
servers : array (connections'range) of server_task;
lf : constant character := ada.characters.latin_1.lf;
-- line-feed
cr : constant character := ada.characters.latin_1.cr;
-- carriage-return
protected server_pool is
entry await_turn;
procedure next_turn;
private
turn : boolean := false;
end server_pool;
protected body server_pool is
entry await_turn when turn is
begin
turn := false;
end await_turn;
procedure next_turn is
begin
turn := true;
end next_turn;
end server_pool;
procedure writeln (outs : sockets.output_stream_ptr; s : string) is
begin
string'write (outs, s);
character'write (outs, cr);
character'write (outs, lf);
end writeln;
is_letter : constant array (character) of boolean :=
('a'..'z' | 'A'..'Z' => true, others => false);
procedure skipln (ins : sockets.input_stream_ptr) is
c : character := ' ';
begin
while c /= lf loop
character'read (ins, c);
end loop;
end skipln;
procedure get_string
(ins : sockets.input_stream_ptr;
outs : sockets.output_stream_ptr;
s : out string) is
i : integer := s'first -1;
c : character;
begin
string'write (outs, "enter a string of up to" &
integer'image (s'length) & " letters: ");
while i < s'last loop
character'read (ins, c);
exit when not is_letter (c);
i := i + 1; s (i) := c;
end loop;
while i < s'last loop
i := i + 1; s (i) := ' ';
end loop;
skipln (ins);
end get_string;
peer : sockets.internet.internet_socket_address;
s : sockets.server_socket;
task db_task is
entry store (key : key_string; value : value_string);
entry fetch (key : key_string; value : out value_string);
end db_task;
task body server_task is
connection : sockets.stream_socket;
ins : sockets.input_stream_ptr;
outs : sockets.output_stream_ptr;
ch : character;
key : key_string;
value : value_string;
begin
loop
begin
server_pool.await_turn;
sockets.accept_connection (s, connection, peer);
server_pool.next_turn;
ins := sockets.get_input_stream (connection);
outs := sockets.get_output_stream (connection);
writeln (outs, "Hello!");
loop
string'write (outs, "enter +, ?, ., or ! ");
character'read (ins, ch);
skipln (ins);
case ch is
when '+' =>
get_string (ins, outs, key);
get_string (ins, outs, value);
db_task.store (key, value);
writeln (outs, "ok.");
when '?' =>
get_string (ins, outs, key);
db_task.fetch (key, value);
writeln (outs, "value = " & value & '.');
when '.' =>
writeln (outs, "bye.");
exit;
when '!' =>
writeln (outs, "bye.");
sockets.close (connection);
sockets.close (s);
abort db_task;
ada.task_identification.abort_task (main_task);
when others => null;
end case;
end loop;
exception when others => null;
end;
sockets.close(connection);
end loop;
exception when e : others => shut_down (e);
end server_task;
task body db_task is
begin
loop
begin
select
accept store (key : key_string; value : value_string) do
set_value (key, value);
end store;
or accept fetch (key : key_string; value : out value_string) do
value := table.value (key);
end fetch;
or terminate;
end select;
exception when others => null;
end;
end loop;
end db_task;
procedure shut_down (e : ada.exceptions.exception_occurrence) is
begin
ada.text_io.put_line ("main: " & ada.exceptions.exception_name (e)
& ": " & ada.exceptions.exception_message (e));
sockets.close (s);
abort db_task;
ada.task_identification.abort_task (main_task);
end shut_down;
begin
sockets.open (s, sockets.internet.new_address
(sockets.internet.any_port, sockets.internet.all_local_addresses));
ada.text_io.put_line ("serving at: "
& sockets.internet.get_addressstring (
sockets.internet.get_internet_address (
sockets.internet.get_address (s)))
& " port "
& sockets.internet.port_number'image (
sockets.internet.get_port (
sockets.internet.get_address (s))));
server_pool.next_turn;
exception when e : others => shut_down (e);
end multidb;
|