DataMuseum.dk

top - download

    Length: 6726 (0x1a46)
    Types: TextFile
    Names: »B«

└─⟦149519bd4⟧ Bits:30000546 8mm tape, Rational 1000, !projects 93-07-13
    └─ ⟦124ff5788⟧ »DATA« 
        └─⟦this⟧ 
└─⟦f64eaa120⟧ Bits:30000752 8mm tape, Rational 1000, !projects 93 02 16
    └─ ⟦6f12a12be⟧ »DATA« 
        └─⟦this⟧ 

TextFile

WITH Io_Exceptions;
WITH Interchange;
WITH Transport_Interchange;
WITH Text_Io;
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
         Initialize;
         LOOP
            Main_Loop_Preprocess;
            Transport_Stream.Flush_Transmit_Buffer (Stream);

            DECLARE
               TASK Reader IS
                  ENTRY Get;
               END Reader;

               TASK Killer IS
                  PRAGMA Os_Task (0);
               END Killer;

               TASK BODY Reader IS
               BEGIN
                  Request := Rpc.Get_Message (Stream);
                  ACCEPT Get;
               END Reader;

               TASK BODY Killer IS
               BEGIN
                  SELECT
                     Reader.Get;  
                     Text_Io.Put_Line ("rpc_server: got it");
                     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;
                  OR
                     DELAY 0.2;
                     Text_Io.Put_Line ("rpc_server: will abort");
                     ABORT Reader;
                  END SELECT;
               END Killer;

            BEGIN
               NULL;
            END;

            Main_Loop_Postprocess;
         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;