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;