with System; with Text_Io; with Vms; package body Transport is Debug_On : constant Boolean := False; Buffer_Size : constant := 1024; subtype Status_Code is Transport_Defs.Status_Code; Ok : constant Status_Code := Transport_Defs.Ok; subtype Host_Address is Transport_Defs.Host_Id (1 .. 4); subtype Port_Address is Transport_Defs.Socket_Id (1 .. 2); Null_Socket_Id : constant Transport_Defs.Socket_Id := Transport_Defs.Null_Socket_Id; function "=" (L, R : Transport_Defs.Socket_Id) return Boolean renames Transport_Defs."="; function "<" (L, R : Transport_Defs.Socket_Id) return Boolean renames Transport_Defs."<"; function "<" (L, R : Byte_Defs.Byte) return Boolean renames Byte_Defs."<"; function "+" (L, R : Byte_Defs.Byte) return Byte_Defs.Byte renames Byte_Defs."+"; First_Internal_Socket : constant Port_Address := (5, 0); Last_Internal_Socket : constant Port_Address := (99, 255); -- So_Acceptconn : constant := 2; So_Socket : constant := 50; So_Accept : constant := 51; So_Connect : constant := 52; So_Close : constant := 56; -- subtype Function_Code is Vms.Function_Code_Type; function "+" (L, R : Function_Code) return Function_Code renames Vms."+"; function "*" (L, R : Function_Code) return Function_Code renames Vms."*"; Mult : constant Function_Code := 256; Io_Access : constant Function_Code := Vms.Io_Access; Ex_Accept : constant Function_Code := Io_Access + (Mult * So_Accept); Ex_Close : constant Function_Code := Io_Access + (Mult * So_Close); Ex_Connect : constant Function_Code := Io_Access + (Mult * So_Connect); Ex_Read : constant Function_Code := Vms.Io_Endru1; Ex_Socket : constant Function_Code := Io_Access + (Mult * So_Socket); Ex_Write : constant Function_Code := Vms.Io_Endru2; -- type Exos_Status is new System.Unsigned_Byte; Exos_Ok : constant Exos_Status := 0; Exos_Eio : constant Exos_Status := 5; -- type Socket_Address_Type is record Internet_Family : System.Unsigned_Word := 2; Port_Number : Port_Address; Internet_Address : Host_Address; Must_Be_Zero : Byte_Defs.Byte_String (1 .. 8) := (others => 0); end record; type So_Ioctl_Type is record Address_Flag : System.Unsigned_Word; Socket_Address : Socket_Address_Type; Protocol_Flag : System.Unsigned_Word := 0; Socket_Protocol : System.Unsigned_Longword := 0; Socket_Type : System.Unsigned_Longword := 1; -- Stream Options : System.Unsigned_Longword; end record; -- Device_Name : constant String := "EX"; Tcp_Ip_Name : constant Transport_Defs.Network_Name := "TCP/IP"; Local_Host_Id : Host_Address; type Connection_State is (Closed, Pre_Connection, Connecting_Active, Connecting_Passive, Connected); type Input_Buffer is record Data : Byte_Defs.Byte_String (1 .. Buffer_Size); Cursor : Positive := 1; Limit : Natural; end record; type Connection_Type is record State : Connection_State; Channel : Vms.Channel_Type; Remote_Host : Host_Address; Remote_Socket : Port_Address; Local_Socket : Port_Address; Read_Buffer : Input_Buffer; Link : Connection_Id; end record; task Connection_Manager is entry Get_First (First : out Connection_Id); entry Allocate (Connection : out Connection_Id; Status : out Status_Code); entry Deallocate (Connection : Connection_Id); entry Test_Uniqueness (Socket : Port_Address; Is_Unique : out Boolean); end Connection_Manager; task Socket_Manager is entry Get (Input : Transport_Defs.Socket_Id; Socket : out Port_Address; Status : out Status_Code); --entry Put (Socket : Port_Address); end Socket_Manager; function Success (Status : Status_Code) return Boolean is begin return Transport_Defs."=" (Status, Ok); end Success; function Success (Status : Exos_Status) return Boolean is begin return Status = Exos_Ok; end Success; function Decode (Status : Exos_Status) return Status_Code is begin return Transport_Defs.Access_Denied; -- ** end Decode; -- procedure Trace (Message : String) is begin if Debug_On then Text_Io.Put_Line (Message); end if; end Trace; procedure Trace (Message : String; Errstat : Exos_Status) is begin if Debug_On then Text_Io.Put_Line (Message & " -- errstat was " & Exos_Status'Image (Errstat)); end if; end Trace; procedure Trace (Message : String; Cc : Vms.Cond_Value_Type) is begin if Debug_On then Text_Io.Put_Line (Message & " -- cc was " & Vms.Image (Cc)); end if; end Trace; procedure Trace (Message : String; Cc : Vms.Cond_Value_Type; Iosb : Vms.Iosb_Type) is begin if Debug_On then Text_Io.Put_Line (Message & " -- cc was " & Vms.Image (Cc) & ", iosb was " & Vms.Image (Iosb)); end if; end Trace; procedure Put_Socket_Id (Socket : Transport_Defs.Socket_Id) is begin Text_Io.Put ("("); for I in Socket'Range loop Text_Io.Put (Byte_Defs.Byte'Image (Socket (I))); if I < Socket'Last then Text_Io.Put (", "); end if; end loop; Text_Io.Put (")"); end Put_Socket_Id; procedure Put_Host_Id (Host : Transport_Defs.Host_Id) is begin Text_Io.Put ("("); for I in Host'Range loop Text_Io.Put (Byte_Defs.Byte'Image (Host (I))); if I < Host'Last then Text_Io.Put (", "); end if; end loop; Text_Io.Put (")"); end Put_Host_Id; procedure Trace (Message : String; Socket : Transport_Defs.Socket_Id) is begin if Debug_On then Text_Io.Put (Message & " -- "); Put_Socket_Id (Socket); Text_Io.New_Line; end if; end Trace; procedure Trace (Message : String; Host : Transport_Defs.Host_Id; Socket : Transport_Defs.Socket_Id) is begin if Debug_On then Text_Io.Put (Message & " -- host: "); Put_Host_Id (Host); Text_Io.Put ("; socket: "); Put_Socket_Id (Socket); Text_Io.New_Line; end if; end Trace; -- procedure Unimplemented (Message : String) is begin Text_Io.Put_Line ("Unimplemented: " & Message); raise Program_Error; end Unimplemented; -- task body Connection_Manager is Used_List : Connection_Id; Free_List : Connection_Id; Work : Connection_Id; begin loop select accept Get_First (First : out Connection_Id) do First := Used_List; end Get_First; or accept Allocate (Connection : out Connection_Id; Status : out Status_Code) do Trace ("Connection_Manager.Allocate"); if Free_List /= null then Work := Free_List; Free_List := Work.Link; else Work := new Connection_Type; Work.State := Closed; end if; Work.Link := Used_List; Used_List := Work; Connection := Work; Status := Ok; end Allocate; or accept Deallocate (Connection : Connection_Id) do Trace ("Connection_Manager.Deallocate"); if Used_List = Connection then Used_List := Connection.Link; else Work := Used_List; loop if Work.Link = Connection then Work.Link := Connection.Link; exit; end if; Work := Work.Link; end loop; end if; Connection.Link := Free_List; Free_List := Connection; end Deallocate; or accept Test_Uniqueness (Socket : Port_Address; Is_Unique : out Boolean) do Trace ("Connection_Manager.Test_Uniqueness", Socket); Work := Used_List; while Work /= null loop if Work.State /= Closed and then Socket = Work.Local_Socket then Is_Unique := False; return; end if; Work := Work.Link; end loop; Is_Unique := True; end Test_Uniqueness; end select; end loop; end Connection_Manager; -- function Normalize (Socket : Transport_Defs.Socket_Id) return Port_Address is begin case Socket'Length is when 1 => return Port_Address'(1 => 0, 2 => Socket (Socket'First)); when 2 => return Port_Address (Socket); when others => return Port_Address (Socket (Socket'Last - 1 .. Socket'Last)); end case; end Normalize; task body Socket_Manager is Internal_Socket : Port_Address := First_Internal_Socket; procedure Bump_Internal_Socket (Wraps : in out Natural) is begin if Internal_Socket < Last_Internal_Socket then if Internal_Socket (2) < 255 then Internal_Socket (2) := Internal_Socket (2) + 1; else Internal_Socket (2) := 0; Internal_Socket (1) := Internal_Socket (1) + 1; end if; else Internal_Socket := First_Internal_Socket; Wraps := Wraps + 1; end if; end Bump_Internal_Socket; procedure Generate_Unique_Socket (Socket : out Port_Address; Status : out Status_Code) is Wraps : Natural := 0; Is_Unique : Boolean; begin loop Socket := Internal_Socket; Connection_Manager.Test_Uniqueness (Internal_Socket, Is_Unique); Bump_Internal_Socket (Wraps); if Is_Unique then Status := Ok; return; elsif Wraps > 1 then Status := Transport_Defs.No_Free_Sockets; return; end if; end loop; end Generate_Unique_Socket; begin loop accept Get (Input : Transport_Defs.Socket_Id; Socket : out Port_Address; Status : out Status_Code) do Trace ("Socket_Manager.Get", Input); if Input = Null_Socket_Id then Generate_Unique_Socket (Socket, Status); else Socket := Normalize (Input); Status := Ok; end if; end Get; end loop; end Socket_Manager; -- procedure Assign_Channel (Channel : out Vms.Channel_Type; Status : out Status_Code) is Cc : Vms.Cond_Value_Type; begin Trace ("Assign_Channel"); Vms.Assign (Status => Cc, Devnam => Device_Name, Chan => Channel); if Vms.Success (Cc) then Status := Ok; Trace ("Assign_Channel: Ok"); else Status := Transport_Defs.No_Local_Resources; Trace ("Assign_Channel", Cc); end if; end Assign_Channel; procedure Deassign_Channel (Channel : in Vms.Channel_Type) is Cc : Vms.Cond_Value_Type; begin Trace ("Deassign_Channel"); Vms.Dassgn (Status => Cc, Chan => Channel); Trace ("Deassign_Channel", Cc); end Deassign_Channel; function Extract_Reply (Iosb : Vms.Iosb_Type) return Exos_Status is begin return Exos_Status (System."/" (Iosb.Dev_Info, 256)); end Extract_Reply; procedure Ex_Control (Func : Vms.Function_Code_Type; Channel : Vms.Channel_Type; So_Ioctl_Address : System.Address; Status : out Exos_Status) is Cc : Vms.Cond_Value_Type; Iosb : Vms.Iosb_Type; begin Trace ("Ex_Control: function " & Vms.Function_Code_Type'Image (Func)); Vms.Qiow (Status => Cc, Chan => Channel, Func => Func, Iosb => Iosb'Address, P3 => Vms.To_Unsigned_Longword (So_Ioctl_Address)); Trace ("Ex_Control", Cc, Iosb); if Vms.Success (Cc) then Status := Extract_Reply (Iosb); else Status := Exos_Eio; end if; end Ex_Control; procedure Ex_Io (Func : Vms.Function_Code_Type; Channel : Vms.Channel_Type; Buffer_Address : System.Address; Length : in out Natural; Status : out Exos_Status) is Cc : Vms.Cond_Value_Type; Iosb : Vms.Iosb_Type; begin Trace ("Ex_Io: function " & Vms.Function_Code_Type'Image (Func)); Vms.Qiow (Status => Cc, Chan => Channel, Func => Func, Iosb => Iosb'Address, P1 => Vms.To_Unsigned_Longword (Buffer_Address), P2 => System.Unsigned_Longword (Length)); Trace ("Ex_Io", Cc, Iosb); if Vms.Success (Cc) then Length := Natural (Iosb.Count); Status := Extract_Reply (Iosb); else Status := Exos_Eio; end if; end Ex_Io; procedure Open (Connection : out Transport.Connection_Id; Status : out Transport_Defs.Status_Code; Network : Transport_Defs.Network_Name; Local_Socket : Transport_Defs.Socket_Id := Transport_Defs.Null_Socket_Id) is Conn : Connection_Id; Stat : Transport_Defs.Status_Code; begin Trace ("Open"); if Transport_Defs."/=" (Network, Tcp_Ip_Name) then Status := Transport_Defs.No_Such_Network; return; end if; Connection_Manager.Allocate (Conn, Stat); if Success (Stat) then Socket_Manager.Get (Local_Socket, Conn.Local_Socket, Stat); end if; if Success (Stat) then Assign_Channel (Conn.Channel, Stat); end if; if Success (Stat) then Conn.State := Pre_Connection; Connection := Conn; else Connection_Manager.Deallocate (Conn); end if; Status := Stat; end Open; procedure Close (Connection : Transport.Connection_Id) is begin if Connection.State = Connected then Disconnect (Connection); end if; if Connection.State /= Closed then Deassign_Channel (Connection.Channel); Connection.State := Closed; Connection_Manager.Deallocate (Connection); end if; end Close; generic Connecting_State : Connection_State; Connect_Command : Vms.Function_Code_Type; Socket_Options : System.Unsigned_Longword; with procedure Set_Socket_Address (Socket_Addr : in out Socket_Address_Type); procedure Generic_Connect (Connection : Transport.Connection_Id; Status : out Transport_Defs.Status_Code); procedure Generic_Connect (Connection : Transport.Connection_Id; Status : out Transport_Defs.Status_Code) is So_Ioctl : So_Ioctl_Type; Socket_Addr : Socket_Address_Type renames So_Ioctl.Socket_Address; Errstat : Exos_Status; begin if not Is_Open (Connection) then Status := Transport_Defs.Not_Open; return; end if; So_Ioctl.Address_Flag := 1; Socket_Addr.Internet_Address := Local_Host_Id; Socket_Addr.Port_Number := Connection.Local_Socket; So_Ioctl.Options := Socket_Options; Ex_Control (Func => Ex_Socket, Channel => Connection.Channel, So_Ioctl_Address => So_Ioctl'Address, Status => Errstat); if Success (Errstat) then Set_Socket_Address (Socket_Addr); Connection.State := Connecting_State; Ex_Control (Func => Connect_Command, Channel => Connection.Channel, So_Ioctl_Address => So_Ioctl'Address, Status => Errstat); end if; if Success (Errstat) then Trace ("Connect", Socket_Addr.Internet_Address, Socket_Addr.Port_Number); Connection.Remote_Host := Socket_Addr.Internet_Address; Connection.Remote_Socket := Socket_Addr.Port_Number; Connection.Read_Buffer.Limit := Connection.Read_Buffer.Cursor; Connection.State := Connected; Status := Ok; else Connection.State := Pre_Connection; Status := Decode (Errstat); end if; end Generic_Connect; procedure Connect (Connection : Transport.Connection_Id; Status : out Transport_Defs.Status_Code; Remote_Host : Transport_Defs.Host_Id; Remote_Socket : Transport_Defs.Socket_Id; Max_Wait : Duration := Duration'Last) is procedure Set_Socket_Address (Socket_Addr : in out Socket_Address_Type) is begin Socket_Addr.Internet_Address := Remote_Host; Socket_Addr.Port_Number := Remote_Socket; end Set_Socket_Address; procedure Active_Connect is new Generic_Connect (Connecting_State => Connecting_Active, Connect_Command => Ex_Connect, Socket_Options => 0, Set_Socket_Address => Set_Socket_Address); begin Active_Connect (Connection, Status); end Connect; procedure Connect (Connection : Transport.Connection_Id; Status : out Transport_Defs.Status_Code; Max_Wait : Duration := Duration'Last) is procedure No_Op (Socket_Addr : in out Socket_Address_Type) is begin -- the socket address is an "out parameter" of the Ex_Accept null; end No_Op; procedure Passive_Connect is new Generic_Connect (Connecting_State => Connecting_Passive, Connect_Command => Ex_Accept, Socket_Options => So_Acceptconn, Set_Socket_Address => No_Op); begin Passive_Connect (Connection, Status); end Connect; procedure Disconnect (Connection : Transport.Connection_Id) is begin Trace ("Disconnect"); if Connection.State = Connected then Connection.State := Pre_Connection; null; -- ** for now, don't close the socket end if; end Disconnect; procedure Copy_Data (Src : in Byte_Defs.Byte_String; Dst : out Byte_Defs.Byte_String; Count : out Natural) is begin case Integer'(Src'Length) - Integer'(Dst'Length) is when 0 => Dst := Src; Count := Dst'Length; when Positive => Dst := Src (Src'First .. Src'First + Dst'Length - 1); Count := Dst'Length; when others => Dst (Dst'First .. Dst'First + Src'Length - 1) := Src; Count := Src'Length; end case; end Copy_Data; procedure Transmit (Connection : Transport.Connection_Id; Status : out Transport_Defs.Status_Code; Data : Byte_Defs.Byte_String; Count : out Natural; Max_Wait : Duration := Duration'Last; More : Boolean := False) is Length : Natural := Data'Length; Errstat : Exos_Status; begin case Connection.State is when Connected => Ex_Io (Func => Ex_Write, Channel => Connection.Channel, Buffer_Address => Data'Address, Length => Length, Status => Errstat); Trace ("Transmit", Errstat); if Success (Errstat) then Count := Length; Status := Ok; else Status := Transport_Defs.Disconnected; end if; when Closed => Count := 0; Status := Transport_Defs.Not_Open; when others => Count := 0; Status := Transport_Defs.Not_Connected; end case; end Transmit; procedure Receive_Data (Connection : Connection_Id; Status : out Status_Code; Data : out Byte_Defs.Byte_String; Count : out Natural) is Buffer : Input_Buffer renames Connection.Read_Buffer; Length : Natural; Errstat : Exos_Status; begin if Buffer.Cursor = Buffer.Limit then Buffer.Cursor := Buffer.Data'First; Length := Buffer.Data'Length; Ex_Io (Func => Ex_Read, Channel => Connection.Channel, Buffer_Address => Buffer.Data'Address, Length => Length, Status => Errstat); Trace ("Receive_Data", Errstat); if Success (Errstat) then Buffer.Limit := Buffer.Cursor + Length; if Length = 0 then Count := 0; Status := Transport_Defs.Disconnected; return; end if; else Buffer.Limit := Buffer.Cursor - 1; end if; end if; if Buffer.Cursor < Buffer.Limit then Copy_Data (Src => Buffer.Data (Buffer.Cursor .. Buffer.Limit - 1), Dst => Data, Count => Length); Buffer.Cursor := Buffer.Cursor + Length; Count := Length; Status := Ok; Trace ("Receive_Data: length " & Integer'Image (Length) & ", cursor " & Integer'Image (Buffer.Cursor)); else Count := 0; Status := Transport_Defs.Connection_Broken; end if; end Receive_Data; procedure Receive (Connection : Transport.Connection_Id; Status : out Transport_Defs.Status_Code; Data : out Byte_Defs.Byte_String; Count : out Natural; Max_Wait : Duration := Duration'Last) is begin case Connection.State is when Connected => Receive_Data (Connection, Status, Data, Count); when Closed => Count := 0; Status := Transport_Defs.Not_Open; when others => Count := 0; Status := Transport_Defs.Not_Connected; end case; end Receive; ------------------------------------------------------------------- -------- Predicates and Assorted Info ----------------------------- ------------------------------------------------------------------- function Is_Open (Connection : Transport.Connection_Id) return Boolean is begin return Connection.State /= Closed; end Is_Open; function Is_Connecting_Passive (Connection : Transport.Connection_Id) return Boolean is begin return Connection.State = Connecting_Passive; end Is_Connecting_Passive; function Is_Connecting_Active (Connection : Transport.Connection_Id) return Boolean is begin return Connection.State = Connecting_Active; end Is_Connecting_Active; function Is_Connected (Connection : Transport.Connection_Id) return Boolean is begin return Connection.State = Connected; end Is_Connected; function Hash (Connection : Transport.Connection_Id) return Natural is begin return 0; -- ** for now end Hash; function Network (Connection : Transport.Connection_Id) return Transport_Defs.Network_Name is begin return Tcp_Ip_Name; end Network; procedure Initialize_Local_Host is begin Local_Host_Id := (0, 0, 0, 0); end Initialize_Local_Host; function Local_Host (Network : Transport_Defs.Network_Name) return Transport_Defs.Host_Id is begin return Local_Host_Id; end Local_Host; function Local_Host (Connection : Transport.Connection_Id) return Transport_Defs.Host_Id is begin return Local_Host_Id; end Local_Host; function Local_Socket (Connection : Transport.Connection_Id) return Transport_Defs.Socket_Id is begin return Connection.Local_Socket; end Local_Socket; function Remote_Host (Connection : Transport.Connection_Id) return Transport_Defs.Host_Id is begin return Connection.Remote_Host; end Remote_Host; function Remote_Socket (Connection : Transport.Connection_Id) return Transport_Defs.Socket_Id is begin return Connection.Remote_Socket; end Remote_Socket; ------------------------------------------------------------------- -------- Network_Name_Iterator ------------------------------------ ------------------------------------------------------------------- procedure Init (Iter : in out Network_Name_Iterator) is begin Iter := 0; end Init; procedure Next (Iter : in out Network_Name_Iterator) is begin Iter := Iter + 1; end Next; function Done (Iter : Network_Name_Iterator) return Boolean is begin return Iter > 0; end Done; function Value (Iter : Network_Name_Iterator) return Transport_Defs.Network_Name is begin if Done (Iter) then raise Constraint_Error; else return Tcp_Ip_Name; end if; end Value; ------------------------------------------------------------------- -------- Connection_Id_Iterator ----------------------------------- ------------------------------------------------------------------- procedure Init (Iter : in out Connection_Id_Iterator) is begin Connection_Manager.Get_First (Connection_Id (Iter)); end Init; procedure Next (Iter : in out Connection_Id_Iterator) is begin Iter := Connection_Id_Iterator (Iter.Link); end Next; function Done (Iter : Connection_Id_Iterator) return Boolean is begin return Iter = null; end Done; function Value (Iter : Connection_Id_Iterator) return Connection_Id is begin if Done (Iter) then raise Constraint_Error; else return Connection_Id (Iter); end if; end Value; begin Initialize_Local_Host; end Transport;