-- -- -- package Copyright (c) Dmitry A. Kazakov -- -- GNAT.Sockets.Connection_State_Machine. Luebeck -- -- ASN1 Spring, 2019 -- -- Implementation -- -- Last revision : 10:13 29 Nov 2020 -- -- -- -- This library is free software; you can redistribute it and/or -- -- modify it under the terms of the GNU General Public License as -- -- published by the Free Software Foundation; either version 2 of -- -- the License, or (at your option) any later version. This library -- -- is distributed in the hope that it will be useful, but WITHOUT -- -- ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- -- General Public License for more details. You should have -- -- received a copy of the GNU General Public License along with -- -- this library; if not, write to the Free Software Foundation, -- -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from -- -- this unit, or you link this unit with other files to produce an -- -- executable, this unit does not by itself cause the resulting -- -- executable to be covered by the GNU General Public License. This -- -- exception does not however invalidate any other reasons why the -- -- executable file might be covered by the GNU Public License. -- --____________________________________________________________________-- with Ada.Exceptions; use Ada.Exceptions; with Ada.IO_Exceptions; use Ada.IO_Exceptions; with Ada.Tags; use Ada.Tags; with Strings_Edit; use Strings_Edit; with Strings_Edit.Integers; use Strings_Edit.Integers; package body GNAT.Sockets.Connection_State_Machine.ASN1 is function "=" (Left, Right : Tag_Type) return Boolean is begin return Left.Class = Right.Class and then Left.Value = Right.Value; end "="; function "<" (Left, Right : Tag_Type) return Boolean is begin return ( Left.Class < Right.Class or else ( Left.Class = Right.Class and then Left.Value < Right.Value ) ); end "<"; function Always_Constructed ( Item : ASN1_Data_Item ) return Boolean is begin return False; end Always_Constructed; function Always_Constructed (Tag : ASN1_Type) return Boolean is begin case Tag is when Sequence_Tag | Set_Tag => return True; when others => return False; end case; end Always_Constructed; procedure Check ( Tag : Stream_Element; Expected : ASN1_Type_Array; Primitive : Boolean := False ) is This : constant ASN1_Type := ASN1_Type (Tag and 16#1F#); begin if Primitive and then 0 /= (ASN1_Tag (Tag) and Constructed) then Raise_Exception ( Data_Error'Identity, ( "Object of ASN.1 type " & Image (This) & " must be primitive" ) ); elsif Universal_Class = (ASN1_Tag (Tag) and 2#1100_0000#) then for Index in Expected'Range loop if This = Expected (Index) then return; end if; end loop; Raise_Exception ( Data_Error'Identity, ( "ASN.1 type " & Image (This) & " does not match expected type " & Image (Expected) ) ); elsif Expected'Length = 1 then Raise_Exception ( Data_Error'Identity, "ASN.1 type " & Image (Expected) & " is expected" ); else Raise_Exception ( Data_Error'Identity, "One of ASN.1 types " & Image (Expected) & " is expected" ); end if; end Check; procedure Get ( Data : Stream_Element_Array; Pointer : in out Stream_Element_Offset; Tag : out Tag_Type; Constructed : out Boolean ) is begin if ( Pointer < Data'First or else ( Pointer > Data'Last and then Pointer - Data'Last /= 1 ) ) then Raise_Exception (Layout_Error'Identity, Out_Of_Bounds); elsif Pointer <= Data'Last then case ASN1_Tag (Data (Pointer) and 2#1100_0000#) is when Application_Class => Tag.Class := Application_Tag; when Context_Specific_Class => Tag.Class := Context_Specific_Tag; when Private_Class => Tag.Class := Private_Tag; when others => Tag.Class := Universal_Tag; end case; Tag.Optional := False; Constructed := 0 /= (ASN1_Tag (Data (Pointer)) and ASN1.Constructed); Tag.Value := ASN1_Type (Data (Pointer) and 16#1F#); if Tag.Value < 31 then Pointer := Pointer + 1; return; end if; declare Index : Stream_Element_Offset := Pointer + 1; begin Tag.Value := 0; while Index <= Data'Last loop begin Tag.Value := ( Tag.Value * 128 + ASN1_Type (Data (Index) and 16#7F#) ); exception when Constraint_Error => Raise_Exception ( Constraint_Error'Identity, Tag_Too_Large ); end; if 0 = (Data (Index) and 16#80#) then Pointer := Index + 1; return; end if; Index := Index + 1; end loop; end; Raise_Exception ( End_Error'Identity, "Non-terminated or missing ASN.1 tag" ); end if; end Get; function Image (Tag : ASN1_Type) return String is begin case Tag is when Boolean_Tag => return "BOOLEAN"; when Integer_Tag => return "INTEGER"; when Bit_String_Tag => return "BITSTRING"; when Octet_String_Tag => return "OCTET STRING"; when Null_Tag => return "NULL"; when Object_Identifier_Tag => return "OBJECT IDENTIFIER"; when Object_Descriptor_Tag => return "ObjectDescriptor"; when Instance_Tag => return "INSTANCE"; when Real_Tag => return "REAL"; when Enumerated_Tag => return "ENUMERATED"; when Embedded_Tag => return "EMBEDDED PDV"; when UTF8_String_Tag => return "UTF8String"; when Relative_OID_Tag => return "RELATIVE-OID"; when Time_Tag => return "TIME"; when Sequence_Tag => return "SEQUENCE"; when Set_Tag => return "SET"; when Numeric_String_Tag => return "NumericString"; when Printable_String_Tag => return "PrintableString"; when Teletext_String_Tag => return "TeletexString"; when Videotext_String_Tag => return "VideotexString"; when IA5_String_Tag => return "IA5String"; when UTC_Time_Tag => return "UTCTime"; when Generalized_Time_Tag => return "GeneralizedTime"; when Graphic_String_Tag => return "GraphicString"; when ISO646_String_Tag => return "ISO 646 string"; when General_String_Tag => return "GeneralString"; when Universal_String_Tag => return "UniversalString"; when Character_String_Tag => return "CHARACTER STRING"; when BMP_String_Tag => return "BMPString"; when Date_Tag => return "DATE"; when Time_Of_Day_Tag => return "TIME-OF-DAY"; when Date_Time_Tag => return "DATE-TIME"; when Duration_Tag => return "DURATION"; when others => return Image (Integer (Tag)); end case; end Image; function Image (Tags : ASN1_Type_Array) return String is Buffer : String (1..512); Pointer : Integer := 1; begin for Index in Tags'Range loop if Index > Tags'First then Put (Buffer, Pointer, ", "); end if; Put (Buffer, Pointer, Image (Tags (Index))); end loop; return Buffer (1..Pointer - 1); end Image; function Image (Value : Tag_Type) return String is Result : String (1..60); Pointer : Integer := 1; begin case Value.Class is when Application_Tag => Put (Result, Pointer, "[APPLICATION "); Put (Result, Pointer, Integer (Value.Value)); Put (Result, Pointer, "]"); when Context_Specific_Tag => Put (Result, Pointer, "["); Put (Result, Pointer, Integer (Value.Value)); Put (Result, Pointer, "]"); when Private_Tag => Put (Result, Pointer, "[PRIVATE "); Put (Result, Pointer, Integer (Value.Value)); Put (Result, Pointer, "]"); when Universal_Tag => Put (Result, Pointer, "[UNIVERSAL "); Put (Result, Pointer, Integer (Value.Value)); Put (Result, Pointer, "]"); end case; return Result (1..Pointer - 1); end Image; procedure Put ( Data : in out Stream_Element_Array; Pointer : in out Stream_Element_Offset; Tag : Tag_Type; Constructed : Boolean ) is Header : ASN1_Tag; begin if ( Pointer < Data'First or else ( Pointer > Data'Last and then Pointer - Data'Last /= 1 ) ) then Raise_Exception (Layout_Error'Identity, Out_Of_Bounds); end if; case Tag.Class is when Application_Tag => Header := Application_Class; when Context_Specific_Tag => Header := Context_Specific_Class; when Private_Tag => Header := Private_Class; when Universal_Tag => Header := Universal_Class; end case; if Constructed then Header := Header + ASN1.Constructed; end if; if Tag.Value < 31 then -- Single octet length if Pointer > Data'Last then Raise_Exception (End_Error'Identity, No_Room); end if; Data (Pointer) := Stream_Element (Header) + Stream_Element (Tag.Value); Pointer := Pointer + 1; else declare Value : ASN1_Type := Tag.Value; Length : Stream_Element_Count := 1; begin loop Value := Value / 128; exit when Value = 0; Length := Length + 1; end loop; if Data'Last - Pointer < Length then Raise_Exception (End_Error'Identity, No_Room); end if; Data (Pointer) := Stream_Element (Header) or 16#1F#; Value := Tag.Value; Data (Pointer + Length) := Stream_Element (Value mod 128); Value := Value / 128; for Octet in reverse Pointer + 1..Pointer + Length - 1 loop Data (Octet) := Stream_Element (Value mod 128) or 16#80#; Value := Value / 128; end loop; Pointer := Pointer + Length + 1; end; end if; end Put; procedure Set_Implicit_Tag ( Item : in out Abstract_ASN1_Data_Item; Tag : Tag_Type; Length : Stream_Element_Offset ) is begin if Length < 0 then Raise_Exception ( Data_Error'Identity, ( "A non-constructed object " & Expanded_Name (Abstract_ASN1_Data_Item'Class (Item)'Tag) & " has indefinite length" ) ); elsif Length = 0 then Raise_Exception ( Data_Error'Identity, ( "ASN.1 object " & Expanded_Name (Abstract_ASN1_Data_Item'Class (Item)'Tag) & " has zero length" ) ); end if; end Set_Implicit_Tag; procedure Set_Untagged (Item : in out Abstract_ASN1_Data_Item) is begin if Is_Implicit (Abstract_ASN1_Data_Item'Class (Item)) then Raise_Exception ( Data_Error'Identity, ( "ASN.1 indefinite object " & Expanded_Name (Abstract_ASN1_Data_Item'Class (Item)'Tag) & " has no tag" ) ); end if; end Set_Untagged; end GNAT.Sockets.Connection_State_Machine.ASN1;