|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: T
Length: 8728 (0x2218)
Types: TextFile
Names: »TRANSPORT_SERVER_BODY«
└─⟦180fe333a⟧ Bits:30000405 8mm tape, Rational 1000, SW CATALOG, 10_20_0
└─⟦180fe333a⟧ Bits:30000537 8mm tape, Rational 1000, SW Catalog 10_20_0
└─⟦5cb1d1d7f⟧ »DATA«
└─⟦3b1ee7bd8⟧
└─⟦this⟧
package body Transport_Server is
Min_Backoff : constant Duration := 0.1;
Max_Backoff : constant Duration := 5 * 60.0;
task Mutex is
entry Create (Pool : out Pool_Id;
Network : Transport_Defs.Network_Name;
Local_Socket : Transport_Defs.Socket_Id;
Max_Servers : Natural);
entry Destroy (Pool : Pool_Id := null);
entry Set_Max_Servers (Pool : Pool_Id; Max_Servers : Natural);
entry Start_Server (Pool : Pool_Id;
Connection : Transport.Connection_Id);
entry Server_Terminated (Pool : Pool_Id);
entry Finalize (Abort_Servers : Boolean);
end Mutex;
task type Server is
entry Start (Pool : Pool_Id; Connection : Transport.Connection_Id);
end Server;
type Server_Id is access Server;
procedure Do_Backoff (Backoff : in out Duration) is
begin
delay Backoff;
Backoff := 2 * Backoff;
if Backoff > Max_Backoff then
Backoff := Max_Backoff;
end if;
end Do_Backoff;
task body Mutex is
All_Pools : Pool_Id := null;
type Server_Descriptor;
type Server_List is access Server_Descriptor;
type Server_Descriptor is
record
Next : Server_List;
Server : Server_Id;
Connection : Transport.Connection_Id;
end record;
All_Servers : Server_List := null;
procedure Destroy_One (Pool : Pool_Id) is
begin
abort Pool.Waiter.all;
Transport.Close (Pool.Connection);
Pool.Max_Servers := 0;
end Destroy_One;
procedure Destroy_All is
Pool : Pool_Id := All_Pools;
begin
while Pool /= null loop
Destroy_One (Pool);
Pool := Pool.Next;
end loop;
end Destroy_All;
procedure Do_Abort_Servers is
Server : Server_List := All_Servers;
begin
while Server /= null loop
begin
abort Server.Server.all;
exception
when Tasking_Error =>
null;
end;
Transport.Close (Server.Connection);
end loop;
end Do_Abort_Servers;
begin
loop
begin
select
accept Create (Pool : out Pool_Id;
Network : Transport_Defs.Network_Name;
Local_Socket : Transport_Defs.Socket_Id;
Max_Servers : Natural) do
declare
New_Pool : Pool_Id :=
new Pool_Type (Network'Length,
Local_Socket'Length);
New_Waiter : Waiter_Id := new Waiter;
begin
New_Pool.Next := All_Pools;
All_Pools := New_Pool;
New_Pool.Waiter := New_Waiter;
New_Pool.Network := Network;
New_Pool.Local_Socket := Local_Socket;
New_Pool.Max_Servers := Max_Servers;
New_Pool.Servers := 0;
New_Waiter.Start (New_Pool);
Pool := New_Pool;
end;
end Create;
or
accept Destroy (Pool : Pool_Id := null) do
if Pool = null then
Destroy_All;
else
Destroy_One (Pool);
end if;
end Destroy;
or
accept Set_Max_Servers (Pool : Pool_Id;
Max_Servers : Natural) do
Pool.Max_Servers := Max_Servers;
end Set_Max_Servers;
or
accept Start_Server
(Pool : Pool_Id;
Connection : Transport.Connection_Id) do
if Pool.Servers >= Pool.Max_Servers then
Transport.Close (Connection);
else
declare
New_Server : Server_Id := new Server;
New_List : Server_List := new Server_Descriptor;
begin
New_List.all := (Next => All_Servers,
Server => New_Server,
Connection => Connection);
All_Servers := New_List;
New_Server.Start (Pool, Connection);
Pool.Servers := Pool.Servers + 1;
end;
end if;
end Start_Server;
or
accept Server_Terminated (Pool : Pool_Id) do
Pool.Servers := Pool.Servers - 1;
end Server_Terminated;
or
accept Finalize (Abort_Servers : Boolean) do
Destroy_All;
if Abort_Servers then
Do_Abort_Servers;
end if;
end Finalize;
exit;
end select;
exception
when others =>
null;
end;
end loop;
end Mutex;
task body Server is
Pool : Pool_Id;
Connection : Transport.Connection_Id;
begin
accept Start (Pool : Pool_Id; Connection : Transport.Connection_Id) do
Server.Pool := Pool;
Server.Connection := Connection;
end Start;
begin
Serve (Connection);
exception
when others =>
null;
end;
Transport.Close (Connection);
Mutex.Server_Terminated (Pool);
end Server;
task body Waiter is
Pool : Pool_Id;
Status : Transport_Defs.Status_Code;
Backoff : Duration := Min_Backoff;
function Is_Ok (Status : Transport_Defs.Status_Code) return Boolean is
begin
return Transport_Defs."=" (Status, Transport_Defs.Ok);
end Is_Ok;
begin
accept Start (Pool : Pool_Id) do
Waiter.Pool := Pool;
end Start;
loop
Transport.Open (Pool.Connection, Status,
Pool.Network, Pool.Local_Socket);
if Is_Ok (Status) then
Transport.Connect (Pool.Connection, Status);
if Is_Ok (Status) then
Mutex.Start_Server (Pool, Pool.Connection);
Backoff := Min_Backoff;
else
Transport.Close (Pool.Connection);
Do_Backoff (Backoff);
end if;
else
Transport.Close (Pool.Connection);
Do_Backoff (Backoff);
end if;
end loop;
end Waiter;
function Create (Network : Transport_Defs.Network_Name;
Local_Socket : Transport_Defs.Socket_Id;
Max_Servers : Natural := Natural'Last) return Pool_Id is
Answer : Pool_Id;
begin
Mutex.Create (Answer, Network, Local_Socket, Max_Servers);
return Answer;
end Create;
procedure Destroy (Pool : Pool_Id) is
begin
Mutex.Destroy (Pool);
end Destroy;
procedure Set_Max_Servers (Pool : Pool_Id; Max_Servers : Natural) is
begin
Mutex.Set_Max_Servers (Pool, Max_Servers);
end Set_Max_Servers;
function Network (Pool : Pool_Id) return Transport_Defs.Network_Name is
begin
return Pool.Network;
end Network;
function Local_Socket (Pool : Pool_Id) return Transport_Defs.Socket_Id is
begin
return Pool.Local_Socket;
end Local_Socket;
function Max_Servers (Pool : Pool_Id) return Natural is
begin
return Pool.Max_Servers;
end Max_Servers;
function Servers (Pool : Pool_Id) return Natural is
begin
return Pool.Servers;
end Servers;
procedure Finalize (Abort_Servers : Boolean := False) is
begin
Mutex.Finalize (Abort_Servers);
end Finalize;
end Transport_Server;