with Log, Transport_Defs, Device_Independent_Io, Debug_Tools, Io, Io_Exceptions; with Byte_String_Io; package body Tftp_Utilities is Timeout_Wait : constant Duration := 5.0; Max_Retries : constant := 5; type Doublet is range 0 .. 65_535; Read_Packet : constant Doublet := 1; Write_Packet : constant Doublet := 2; Data_Packet : constant Doublet := 3; Ack_Packet : constant Doublet := 4; Error_Packet : constant Doublet := 5; Unknown_Transfer_Id : constant Doublet := 5; function Decode_Doublet (Item : Byte_Defs.Byte_String) return Doublet; function Decode_Doublet (Item : Byte_Defs.Byte_String) return Doublet is begin return Doublet (Byte_Defs.Byte'Pos (Item (Item'First)) * 256 + Byte_Defs.Byte'Pos (Item (Item'First + 1))); end Decode_Doublet; function Encode_Doublet (Item : Doublet) return Byte_Defs.Byte_String; function Encode_Doublet (Item : Doublet) return Byte_Defs.Byte_String is Data : Byte_Defs.Byte_String (1 .. 2); begin Data (1) := Byte_Defs.Byte'Val (Item / 256); Data (2) := Byte_Defs.Byte'Val (Item - (Item / 256) * 256); return Data; end Encode_Doublet; function Previous_Sequence_Number (Sequence : Doublet) return Doublet; function Previous_Sequence_Number (Sequence : Doublet) return Doublet is begin if Sequence = 0 then return Doublet (0); elsif Sequence = 1 then return Doublet'Last; else return Doublet'Pred (Sequence); end if; end Previous_Sequence_Number; function Next_Sequence_Number (Sequence : Doublet) return Doublet; function Next_Sequence_Number (Sequence : Doublet) return Doublet is begin if Sequence = Doublet'Last then return 1; else return Doublet'Succ (Sequence); end if; end Next_Sequence_Number; procedure Insert_String (From : String; Into : out Byte_Defs.Byte_String); procedure Insert_String (From : String; Into : out Byte_Defs.Byte_String) is Ptr : Natural := Into'First; begin for I in From'Range loop exit when Ptr = Into'Last; Into (Ptr) := Byte_Defs.Byte'Val (Character'Pos (From (I))); Ptr := Ptr + 1; end loop; Into (Ptr) := 0; end Insert_String; procedure Display_Error_Packet (Packet : Byte_Defs.Byte_String); procedure Display_Error_Packet (Packet : Byte_Defs.Byte_String) is Message : String (1 .. Packet'Length); Message_Last : Natural; begin if Decode_Doublet (Packet (1 .. 2)) = Error_Packet then case Decode_Doublet (Packet (3 .. 4)) is when Error_Class'Pos (Not_Defined) => Log.Put_Line ("'Not Defined' error packet received:"); when Error_Class'Pos (File_Not_Found) => Log.Put_Line ("'File Not Found' error packet received:"); when Error_Class'Pos (Access_Violation) => Log.Put_Line ("'Access Violation' error packet received:"); when Error_Class'Pos (Medium_Full) => Log.Put_Line ("'Disk Full/Allocation Exceeded' error packet received:"); when Error_Class'Pos (Illegal_Operation) => Log.Put_Line ("'Illegal TFTP Operation' error packet received:"); when Error_Class'Pos (Unknown_Tid) => Log.Put_Line ("'Unknown Transfer ID' error packet received:"); when others => Log.Put_Line ("Illegal error packet type =>" & Integer'Image (Integer (Decode_Doublet (Packet (3 .. 4)))) & " received:"); end case; Extract_String (Packet (5 .. Packet'Last), Message, Message_Last); Log.Put_Line (Message (1 .. Message_Last)); else Log.Put_Line ("Display_Error called with non-error packet:"); Log.Put_Line (Byte_String_Io.Image (Packet)); end if; end Display_Error_Packet; procedure Receive_Packet (From : Transport.Connection_Id; Data : out Byte_Defs.Byte_String; Count : out Natural); procedure Receive_Packet (From : Transport.Connection_Id; Data : out Byte_Defs.Byte_String; Count : out Natural) is Status : Transport_Defs.Status_Code; begin Transport.Receive (From, Status, Data, Count, Timeout_Wait); if not Transport_Defs."=" (Status, Transport_Defs.Ok) then if Transport_Defs."=" (Status, Transport_Defs.Timed_Out) then raise Timeout; else Log.Put_Line ("Error on receive => " & Transport_Defs.Image (Status)); raise Fatal_Error; end if; end if; end Receive_Packet; procedure Send_Packet (To : Transport.Connection_Id; Data : Byte_Defs.Byte_String); procedure Send_Packet (To : Transport.Connection_Id; Data : Byte_Defs.Byte_String) is Status : Transport_Defs.Status_Code; Count : Natural; begin Transport.Transmit (To, Status, Data, Count, 5.0); end Send_Packet; procedure Send_Error (To : Transport.Connection_Id; Class : Tftp_Utilities.Error_Class; Error_Text : String) is Packet : Byte_Defs.Byte_String (1 .. 1008); Length : Natural; begin Packet (1 .. 2) := Encode_Doublet (Error_Packet); Packet (3 .. 4) := Encode_Doublet (Error_Class'Pos (Class)); Insert_String (Error_Text, Packet (5 .. Packet'Last)); Send_Packet (To, Packet (1 .. Error_Text'Length + 5)); end Send_Error; function Receive_Ack (From : Transport.Connection_Id; Sequence : Doublet) return Boolean; function Receive_Ack (From : Transport.Connection_Id; Sequence : Doublet) return Boolean is Expected_Tid : constant Transport_Defs.Socket_Id := Transport.Remote_Socket (From); Packet : Byte_Defs.Byte_String (1 .. 1008); Count : Natural; begin while True loop Receive_Packet (From, Packet, Count); if Sequence = 0 or else Transport_Defs."=" (Expected_Tid, Transport.Remote_Socket (From)) then if Count >= 4 then if Decode_Doublet (Packet (1 .. 2)) = Data_Packet then return True; elsif Decode_Doublet (Packet (1 .. 2)) = Ack_Packet and then Decode_Doublet (Packet (3 .. 4)) = Sequence then return True; elsif Decode_Doublet (Packet (1 .. 2)) = Error_Packet then if Decode_Doublet (Packet (3 .. 4)) = Unknown_Transfer_Id then raise Timeout; else Display_Error_Packet (Packet (1 .. Count)); raise Fatal_Error; end if; end if; end if; else Send_Error (From, Unknown_Tid, ""); end if; end loop; end Receive_Ack; procedure Send_Ack (To : Transport.Connection_Id; Sequence : Doublet); procedure Send_Ack (To : Transport.Connection_Id; Sequence : Doublet) is Data : Byte_Defs.Byte_String (1 .. 4); begin Data (1 .. 2) := Encode_Doublet (Ack_Packet); Data (3 .. 4) := Encode_Doublet (Sequence); Send_Packet (To, Data); end Send_Ack; procedure Send_Read (To : Transport.Connection_Id; File : String; Mode : Transfer_Mode); procedure Send_Read (To : Transport.Connection_Id; File : String; Mode : Transfer_Mode) is Data : Byte_Defs.Byte_String (1 .. 12 + File'Length); Ptr : Natural := 4 + File'Length; begin Data (1 .. 2) := Encode_Doublet (Read_Packet); Insert_String (File, Data (3 .. Data'Last)); case Mode is when Binary => Insert_String ("binary", Data (3 + File'Length + 1 .. Data'Last)); Ptr := Ptr + 6; when Text => Insert_String ("netascii", Data (3 + File'Length + 1 .. Data'Last)); Ptr := Ptr + 8; when Mail => Insert_String ("mail", Data (3 + File'Length + 1 .. Data'Last)); Ptr := Ptr + 4; end case; Send_Packet (To, Data (1 .. Ptr)); end Send_Read; procedure Send_Write (To : Transport.Connection_Id; File : String; Mode : Transfer_Mode); procedure Send_Write (To : Transport.Connection_Id; File : String; Mode : Transfer_Mode) is Data : Byte_Defs.Byte_String (1 .. 12 + File'Length); Ptr : Natural := 4 + File'Length; begin Data (1 .. 2) := Encode_Doublet (Write_Packet); Insert_String (File, Data (3 .. Data'Last)); case Mode is when Binary => Insert_String ("binary", Data (3 + File'Length + 1 .. Data'Last)); Ptr := Ptr + 6; when Text => Insert_String ("netascii", Data (3 + File'Length + 1 .. Data'Last)); Ptr := Ptr + 8; when Mail => Insert_String ("mail", Data (3 + File'Length + 1 .. Data'Last)); Ptr := Ptr + 4; end case; Send_Packet (To, Data (1 .. Ptr)); end Send_Write; procedure Receive_Data (From : Transport.Connection_Id; Sequence : Doublet; Data : out Byte_Defs.Byte_String; Count : out Natural); procedure Receive_Data (From : Transport.Connection_Id; Sequence : Doublet; Data : out Byte_Defs.Byte_String; Count : out Natural) is Expected_Tid : constant Transport_Defs.Socket_Id := Transport.Remote_Socket (From); Packet : Byte_Defs.Byte_String (1 .. 516); Ptr : Natural := Data'First; Status : Transport_Defs.Status_Code; Length : Natural; Data_Received : Boolean := False; Retries : Natural := 0; begin while not Data_Received loop begin Receive_Packet (From, Packet, Length); if Sequence = 1 or else Transport_Defs."=" (Expected_Tid, Transport.Remote_Socket (From)) then if Length > 4 then if Decode_Doublet (Packet (1 .. 2)) = Data_Packet and then Decode_Doublet (Packet (3 .. 4)) = Sequence then Data_Received := True; elsif Decode_Doublet (Packet (1 .. 2)) = Error_Packet then if Decode_Doublet (Packet (3 .. 4)) = Unknown_Transfer_Id then raise Timeout; else Display_Error_Packet (Packet (1 .. Length)); raise Fatal_Error; end if; end if; end if; else Send_Error (From, Unknown_Tid, ""); end if; exception when Timeout => Retries := Retries + 1; if Retries < Max_Retries then Send_Ack (From, Previous_Sequence_Number (Sequence)); else raise Fatal_Error; end if; end; end loop; Send_Ack (From, Sequence); for I in 5 .. Length loop exit when Ptr > Data'Last; Data (Ptr) := Packet (I); Ptr := Ptr + 1; end loop; Count := Ptr - 1; end Receive_Data; procedure Send_Data (To : Transport.Connection_Id; Data : Byte_Defs.Byte_String; Sequence : Doublet); procedure Send_Data (To : Transport.Connection_Id; Data : Byte_Defs.Byte_String; Sequence : Doublet) is Packet : Byte_Defs.Byte_String (1 .. 516); Ptr : Natural := 5; Block_Acknowledged : Boolean; Retries : Natural := 0; begin Packet (1 .. 2) := Encode_Doublet (Data_Packet); Packet (3 .. 4) := Encode_Doublet (Sequence); for I in Data'Range loop exit when Ptr > Packet'Last; Packet (Ptr) := Data (I); Ptr := Ptr + 1; end loop; Block_Acknowledged := False; while not Block_Acknowledged loop Send_Packet (To, Packet (1 .. Ptr - 1)); begin Block_Acknowledged := Receive_Ack (To, Sequence); exception when Timeout => Retries := Retries + 1; if Retries = Max_Retries then raise Fatal_Error; end if; when others => raise; end; end loop; end Send_Data; procedure Receive_A_File (Remote_Pathname : String; Local_Pathname : String; Mode : Tftp_Utilities.Transfer_Mode; Requestor : Tftp_Utilities.Requestor_Type; From : in out Transport.Connection_Id) is B_File : Device_Independent_Io.File_Type; T_File : Io.File_Type; Data : Byte_Defs.Byte_String (1 .. 512); Count : Natural := 512; Block : Doublet := 1; procedure Write_Buffer (File : Io.File_Type; Data : Byte_Defs.Byte_String); procedure Write_Buffer (File : Io.File_Type; Data : Byte_Defs.Byte_String) is Buff : String (1 .. 514); Sptr : Natural := Data'First; Dptr : Natural := Buff'First; Char : Character; begin while Sptr <= Data'Last loop Char := Character'Val (Byte_Defs.Byte'Pos (Data (Sptr))); if Char = Ascii.Cr then Io.Put_Line (File, Buff (1 .. Dptr - 1)); Dptr := Buff'First; Sptr := Sptr + 2; elsif Char = Ascii.Lf then Sptr := Sptr + 1; else Buff (Dptr) := Char; Dptr := Dptr + 1; Sptr := Sptr + 1; end if; end loop; if Dptr /= Buff'First then Io.Put (File, Buff (1 .. Dptr - 1)); end if; end Write_Buffer; begin case Mode is when Binary => Device_Independent_Io.Create (B_File, Name => Local_Pathname); when Text | Mail => Io.Create (T_File, Name => Local_Pathname); end case; case Requestor is when Client => Send_Read (From, Remote_Pathname, Mode); when Server => Send_Ack (From, 0); end case; Receive_Data (From, Block, Data, Count); case Mode is when Text | Mail => Write_Buffer (T_File, Data (1 .. Count)); when Binary => Device_Independent_Io.Write (B_File, Data (1 .. Count)); end case; case Requestor is when Client => declare Remote_Socket : constant Transport_Defs.Socket_Id := Transport.Remote_Socket (From); Remote_Host : constant Transport_Defs.Host_Id := Transport.Remote_Host (From); Status : Transport_Defs.Status_Code; begin Transport.Disconnect (From); Transport.Connect (From, Status, Remote_Host, Remote_Socket, 5.0); if not Transport_Defs."=" (Transport_Defs.Ok, Status) then raise Fatal_Error; end if; end; when Server => null; end case; while Count = 512 loop Block := Next_Sequence_Number (Block); Receive_Data (From, Block, Data, Count); case Mode is when Text | Mail => Write_Buffer (T_File, Data (1 .. Count)); when Binary => Device_Independent_Io.Write (B_File, Data (1 .. Count)); end case; end loop; case Mode is when Binary => Device_Independent_Io.Close (B_File); when Text | Mail => Io.Close (T_File); end case; exception when Io_Exceptions.Name_Error => case Mode is when Binary => if Device_Independent_Io.Is_Open (B_File) then Device_Independent_Io.Delete (B_File); end if; when Text | Mail => if Io.Is_Open (T_File) then Io.Delete (T_File); end if; end case; case Requestor is when Server => Send_Error (From, Not_Defined, "Invalid file name => " & Local_Pathname); when Client => Log.Put_Line ("Create of " & Local_Pathname & " raised exception NAME_ERROR"); end case; when Io_Exceptions.Status_Error => case Mode is when Binary => if Device_Independent_Io.Is_Open (B_File) then Device_Independent_Io.Delete (B_File); end if; when Text | Mail => if Io.Is_Open (T_File) then Io.Delete (T_File); end if; end case; case Requestor is when Server => Send_Error (From, Not_Defined, "File is in use. Please try again later."); when Client => Log.Put_Line ("Create of " & Local_Pathname & " raised exception NAME_ERROR"); end case; when Io_Exceptions.Use_Error => case Mode is when Binary => if Device_Independent_Io.Is_Open (B_File) then Device_Independent_Io.Delete (B_File); end if; when Text | Mail => if Io.Is_Open (T_File) then Io.Delete (T_File); end if; end case; case Requestor is when Server => Send_Error (From, Not_Defined, "Invalid output file name => " & Local_Pathname); when Client => Log.Put_Line ("Create of " & Local_Pathname & " raised exception USE_ERROR"); end case; when others => case Mode is when Binary => if Device_Independent_Io.Is_Open (B_File) then Device_Independent_Io.Delete (B_File); end if; when Text | Mail => if Io.Is_Open (T_File) then Io.Delete (T_File); end if; end case; case Requestor is when Server => Send_Error (From, Not_Defined, "Unknown fatal error receiving file => " & Local_Pathname); when Client => Log.Put_Line ("Get of " & Local_Pathname & " raised exception " & Debug_Tools.Get_Exception_Name); end case; end Receive_A_File; procedure Send_A_File (Local_Pathname : String; Remote_Pathname : String; Mode : Tftp_Utilities.Transfer_Mode; Requestor : Tftp_Utilities.Requestor_Type; To : in out Transport.Connection_Id) is B_File : Device_Independent_Io.File_Type; T_File : Io.File_Type; Block : Doublet := 1; Data : Byte_Defs.Byte_String (1 .. 512); Length : Natural; Ack_Received : Boolean := False; Residual_Line : String (1 .. 510); Residual_Length : Integer := -1; Residual_Lf : Boolean := False; Dptr : Natural := Data'First; procedure Fill_Buffer is procedure Process_Line is Buff : constant String := Io.Get_Line (T_File); Sptr : Natural := Buff'First; begin while Dptr <= Data'Last and Sptr <= Buff'Last loop Data (Dptr) := Byte_Defs.Byte'Val (Character'Pos (Buff (Sptr))); Dptr := Dptr + 1; Sptr := Sptr + 1; end loop; if Sptr <= Buff'Last then Residual_Line (1 .. Buff'Length - (Sptr - Buff'First)) := Buff (Sptr .. Buff'Last); Residual_Length := Buff'Length - (Sptr - Buff'First); elsif Dptr < Data'Last then Data (Dptr) := Byte_Defs.Byte'Val (Character'Pos (Ascii.Cr)); Data (Dptr + 1) := Byte_Defs.Byte'Val (Character'Pos (Ascii.Lf)); Dptr := Dptr + 2; Residual_Length := -1; elsif Dptr = Data'Last then Data (Dptr) := Byte_Defs.Byte'Val (Character'Pos (Ascii.Cr)); Dptr := Dptr + 1; Residual_Length := -1; Residual_Lf := True; else Residual_Length := 0; end if; end Process_Line; begin Dptr := Data'First; if Residual_Length >= 0 then for I in Residual_Line'First .. Residual_Length loop Data (Dptr) := Byte_Defs.Byte'Val (Character'Pos (Residual_Line (I))); Dptr := Dptr + 1; end loop; Data (Dptr) := Byte_Defs.Byte'Val (Character'Pos (Ascii.Cr)); Data (Dptr + 1) := Byte_Defs.Byte'Val (Character'Pos (Ascii.Lf)); Dptr := Dptr + 2; Residual_Length := -1; elsif Residual_Lf then Data (Dptr) := Byte_Defs.Byte'Val (Character'Pos (Ascii.Lf)); Dptr := Dptr + 1; Residual_Lf := False; end if; while Dptr <= Data'Last loop Process_Line; end loop; exception when Io.End_Error => null; when others => raise; end Fill_Buffer; begin case Mode is when Binary => Device_Independent_Io.Open (B_File, Device_Independent_Io.In_File, Local_Pathname); when Text | Mail => Io.Open (T_File, Io.In_File, Local_Pathname); end case; case Requestor is when Client => Send_Write (To, Remote_Pathname, Mode); declare Retries : Natural := 0; begin while not Ack_Received loop begin while not Receive_Ack (To, 0) loop null; end loop; Ack_Received := True; declare Remote_Socket : constant Transport_Defs.Socket_Id := Transport.Remote_Socket (To); Remote_Host : constant Transport_Defs.Host_Id := Transport.Remote_Host (To); Status : Transport_Defs.Status_Code; begin Transport.Disconnect (To); Transport.Connect (To, Status, Remote_Host, Remote_Socket, 5.0); if not Transport_Defs."=" (Transport_Defs.Ok, Status) then raise Fatal_Error; end if; end; exception when Timeout => Retries := Retries + 1; if Retries = Max_Retries then raise Fatal_Error; end if; end; end loop; end; when Server => null; end case; case Mode is when Text | Mail => while not Io.End_Of_File (T_File) loop Fill_Buffer; Send_Data (To, Data (1 .. Dptr - 1), Block); Block := Next_Sequence_Number (Block); end loop; Io.Close (T_File); when Binary => while not Device_Independent_Io.End_Of_File (B_File) loop Device_Independent_Io.Read (B_File, Data, Length); Send_Data (To, Data (1 .. Length), Block); Block := Next_Sequence_Number (Block); end loop; Device_Independent_Io.Close (B_File); end case; exception when Io_Exceptions.Name_Error => case Mode is when Binary => if Device_Independent_Io.Is_Open (B_File) then Device_Independent_Io.Close (B_File); end if; when Mail | Text => if Io.Is_Open (T_File) then Io.Close (T_File); end if; end case; case Requestor is when Server => Send_Error (To, File_Not_Found, "File does not exist => " & Local_Pathname); when Client => Log.Put_Line ("Create of " & Local_Pathname & " raised exception NAME_ERROR"); end case; when Io_Exceptions.Status_Error => case Mode is when Binary => if Device_Independent_Io.Is_Open (B_File) then Device_Independent_Io.Close (B_File); end if; when Mail | Text => if Io.Is_Open (T_File) then Io.Close (T_File); end if; end case; case Requestor is when Server => Send_Error (To, Not_Defined, "File is in use. Please try again later."); when Client => Log.Put_Line ("Create of " & Local_Pathname & " raised exception STATUS_ERROR"); end case; when Io_Exceptions.Use_Error => case Mode is when Binary => if Device_Independent_Io.Is_Open (B_File) then Device_Independent_Io.Close (B_File); end if; when Mail | Text => if Io.Is_Open (T_File) then Io.Close (T_File); end if; end case; case Requestor is when Server => Send_Error (To, Not_Defined, "Invalid input file name => " & Local_Pathname); when Client => Log.Put_Line ("Create of " & Local_Pathname & " raised exception USE_ERROR"); end case; when others => case Mode is when Binary => if Device_Independent_Io.Is_Open (B_File) then Device_Independent_Io.Close (B_File); end if; when Mail | Text => if Io.Is_Open (T_File) then Io.Close (T_File); end if; end case; case Requestor is when Server => Send_Error (To, Not_Defined, "Unknown fatal error sending file => " & Local_Pathname); when Client => Log.Put_Line ("Put of " & Local_Pathname & " raised exception " & Debug_Tools.Get_Exception_Name); end case; end Send_A_File; procedure Extract_String (From : Byte_Defs.Byte_String; To : out String; Last : out Natural) is Ptr : Natural := To'First; Char : Character; begin for I in From'Range loop exit when Byte_Defs."=" (From (I), 0) or Ptr > To'Last; Char := Character'Val (Byte_Defs.Byte'Pos (From (I))); if Char in 'a' .. 'z' then Char := Character'Val (Character'Pos (Char) - Character'Pos (' ')); end if; To (Ptr) := Char; Ptr := Ptr + 1; end loop; Last := Ptr - 1; end Extract_String; end Tftp_Utilities;