DataMuseum.dk

top - download

    Length: 6209 (0x1841)
    Types: TextFile
    Names: »B«

└─⟦bad92a95e⟧ Bits:30000535 8mm tape, Rational 1000, RPC 1_0_2
    └─ ⟦bb34fe6e2⟧ »DATA« 
        └─⟦15d8b76c6⟧ 
            └─⟦this⟧ 

TextFile

with Io_Exceptions;
with Interchange;
with Transport_Interchange;

package body Rpc_Server is

    Supported_Versions : constant Rpc.Version_Range := (3, 5);

    procedure Begin_Response (Stream : Transport_Stream.Stream_Id;
                              Id : Rpc.Transaction_Id) is
        Response : Rpc.Message_Header (Kind => Rpc.Return_Message) :=
           (Rpc.Return_Message, Id);
    begin
        Rpc.Put_Message (Stream, Response);
    end Begin_Response;

    procedure Return_Exception (Stream : Transport_Stream.Stream_Id;
                                Id : Rpc.Transaction_Id;
                                Excep : Rpc.Exception_Number) is
        Response : Rpc.Message_Header (Kind => Rpc.Abort_Message);
    begin
        Response := (Rpc.Abort_Message, Id, Rpc.Error_Other);
        Rpc.Put_Message (Stream, Response);
    end Return_Exception;

    procedure Serve (Connection : Transport.Connection_Id) is


        Stream : Transport_Stream.Stream_Id;
        Client_Versions : Rpc.Version_Range;
        Max_Version : Rpc.Version_Number;

        procedure Process_Calls is

            Request : Rpc.Message_Header;

            function "=" (X, Y : Rpc.Message_Kind) return Boolean
                renames Rpc."=";
            function "=" (X, Y : Rpc.Program_Number) return Boolean
                renames Rpc."=";

            procedure Do_Process_Call is
                procedure Put_Abort (Error : Rpc.Error_Type) is
                begin
                    Rpc.Put_Message (Stream, (Kind => Rpc.Abort_Message,
                                              Id => Request.Id,
                                              Error => Error));
                end Put_Abort;
            begin
                if Max_Version in Rpc.Username_Versions.First ..
                                     Rpc.Username_Versions.Last then
                    declare
                        Username : constant String :=
                           Transport_Interchange.Get_String (Stream);
                        Password : constant String :=
                           Transport_Interchange.Get_String (Stream);
                    begin
                        Process_Call (Stream, Request.Id,
                                      Request.Version, Request.Proc);
                    end;
                else
                    Process_Call (Stream, Request.Id,
                                  Request.Version, Request.Proc);
                end if;
            exception
                when Interchange.Constraint_Error =>
                    raise Rpc.Invalid_Argument;
                when Standard.Constraint_Error =>
                    Put_Abort (Rpc.Error_Constraint);
                when Standard.Numeric_Error =>
                    Put_Abort (Rpc.Error_Numeric);
                when Standard.Program_Error =>
                    Put_Abort (Rpc.Error_Program);
                when Standard.Storage_Error =>
                    Put_Abort (Rpc.Error_Storage);
                when Standard.Tasking_Error =>
                    Put_Abort (Rpc.Error_Tasking);
                when Io_Exceptions.Status_Error =>
                    Put_Abort (Rpc.Status_Error);
                when Io_Exceptions.Mode_Error =>
                    Put_Abort (Rpc.Mode_Error);
                when Io_Exceptions.Name_Error =>
                    Put_Abort (Rpc.Name_Error);
                when Io_Exceptions.Use_Error =>
                    Put_Abort (Rpc.Use_Error);
                when Io_Exceptions.Device_Error =>
                    Put_Abort (Rpc.Device_Error);
                when Io_Exceptions.End_Error =>
                    Put_Abort (Rpc.End_Error);
                when Io_Exceptions.Data_Error =>
                    Put_Abort (Rpc.Data_Error);
                when Io_Exceptions.Layout_Error =>
                    Put_Abort (Rpc.Layout_Error);
                when Rpc.Username_Or_Password_Error =>
                    Put_Abort (Rpc.Error_Username_Or_Password);
                when others =>
                    Put_Abort (Rpc.Error_Other);
            end Do_Process_Call;

            procedure Put_Reject (Details : Rpc.Reject_Details) is
            begin
                Rpc.Put_Message (Stream, (Kind => Rpc.Reject_Message,
                                          Id => Request.Id,
                                          Details => Details));
            end Put_Reject;

        begin
            loop
                Transport_Stream.Flush_Transmit_Buffer (Stream);
                Request := Rpc.Get_Message (Stream);
                if Request.Kind /= Rpc.Call_Message then
                    raise Rpc.Protocol_Error;
                elsif Request.Program /= Program then
                    raise Rpc.No_Such_Program;
                elsif not (Request.Version in
                           Supported.First .. Supported.Last) then
                    raise Rpc.No_Such_Version;
                else
                    Do_Process_Call;
                end if;
            end loop;
        exception
            when Rpc.No_Such_Program =>
                Put_Reject ((Kind => Rpc.Rej_No_Such_Program));
            when Rpc.No_Such_Version =>
                Put_Reject ((Kind => Rpc.Rej_No_Such_Version,
                             Supported => Supported));
            when Rpc.No_Such_Procedure =>
                Put_Reject ((Kind => Rpc.Rej_No_Such_Procedure));
            when Rpc.Invalid_Argument =>
                Put_Reject ((Kind => Rpc.Rej_Invalid_Argument));
            when others =>
                null;
        end Process_Calls;
    begin
        begin
            Transport_Stream.Allocate (Stream, Connection);
            Rpc.Get (Stream, Client_Versions);
            Rpc.Put (Stream, Supported_Versions);
            if Rpc.Overlaps (Client_Versions, Supported_Versions) then
                Max_Version := Rpc.Max (Client_Versions, Supported_Versions);
                Process_Calls;
            end if;
            Transport_Stream.Flush_Transmit_Buffer (Stream);
        exception
            when others =>
                null;
        end;
        Transport_Stream.Deallocate (Stream);

    end Serve;

end Rpc_Server;