(********************************************************************)
(*                                                                  *)
(*  asn1.s7i      Support for Abstract Syntax Notation One (ASN.1). *)
(*  Copyright (C) 2013, 2022, 2023  Thomas Mertes                   *)
(*                                                                  *)
(*  This file is part of the Seed7 Runtime Library.                 *)
(*                                                                  *)
(*  The Seed7 Runtime Library is free software; you can             *)
(*  redistribute it and/or modify it under the terms of the GNU     *)
(*  Lesser General Public License as published by the Free Software *)
(*  Foundation; either version 2.1 of the License, or (at your      *)
(*  option) any later version.                                      *)
(*                                                                  *)
(*  The Seed7 Runtime 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 Lesser General Public License for more    *)
(*  details.                                                        *)
(*                                                                  *)
(*  You should have received a copy of the GNU Lesser General       *)
(*  Public License along with this program; if not, write to the    *)
(*  Free Software Foundation, Inc., 51 Franklin Street,             *)
(*  Fifth Floor, Boston, MA  02110-1301, USA.                       *)
(*                                                                  *)
(********************************************************************)


include "bytedata.s7i";
include "unicode.s7i";


const array string: classTagName is [0] (
    "EOC (End-of-Content)",
    "BOOLEAN",
    "INTEGER",
    "BIT STRING",
    "OCTET STRING",
    "NULL",
    "OBJECT IDENTIFIER",
    "Object Descriptor",
    "EXTERNAL",
    "REAL (float)",
    "ENUMERATED",
    "EMBEDDED PDV",
    "UTF8String",
    "RELATIVE-OID",
    "(reserved 14)",
    "(reserved 15)",
    "SEQUENCE",
    "SET",
    "NumericString",
    "PrintableString",
    "T61String",
    "VideotexString",
    "IA5String",
    "UTCTime",
    "GeneralizedTime",
    "GraphicString",
    "VisibleString",
    "GeneralString",
    "UniversalString",
    "CHARACTER STRING",
    "BMPString",
    "(use long-form)"
  );

(**
 *  Tag type used by ASN.1/BER data elements.
 *)
const type: asn1TagType is new enum
    tagEndOfContent,
    tagBoolean,
    tagInteger,
    tagBitString,
    tagOctetString,
    tagNull,
    tagObjectIdentifier,
    tagObjectDescriptor,
    tagExternal,
    tagReal,
    tagEnumerated,
    tagEmbeddedPdv,
    tagUTF8String,
    tagRelativeOid,
    tagReserved14,
    tagReserved15,
    tagSequence,
    tagSet,
    tagNumericString,
    tagPrintableString,
    tagT61String,
    tagVideotexString,
    tagIA5String,
    tagUTCTime,
    tagGeneralizedTime,
    tagGraphicString,
    tagVisibleString,
    tagGeneralString,
    tagUniversalString,
    tagCharacterString,
    tagBMPString,
    tagUseLongForm
  end enum;

const type: asn1TagClass is new enum
    universalTagClass, applicationTagClass, contextSpecificTagClass, privateTagClass
  end enum;

(**
 *  ASN.1/BER data element.
 *  This type is used for reading ASN.1/BER data.
 *)
const type: asn1DataElement is new struct
    var asn1TagClass: tagClass is universalTagClass;
    var boolean: constructed is FALSE;
    var asn1TagType: tagType is tagEndOfContent;
    var boolean: indefinite is FALSE;
    var integer: dataStart is 0;
    var integer: length is 0;
  end struct;


# The element tagCategory is deprecated. Use tagType instead.
const func asn1TagType: (in asn1DataElement: dataElem) . tagCategory is
    return dataElem.tagType;
const varfunc asn1TagType: (inout asn1DataElement: dataElem) . tagCategory is
    return var dataElem.tagType;


const func string: encodeObjectIdentifier (in array integer: oid) is func
  result
    var string: encodedOid is "";
  local
    var integer: pos is 3;
    var integer: subId is 0;
    var string: subIdStri is "";
  begin
    encodedOid := str(chr(oid[1] * 40 + oid[2]));
    while pos <= length(oid) do
      subId := oid[pos];
      if subId < 0 then
        raise RANGE_ERROR;
      elsif subId <= 127 then
        # Encode in one byte
        encodedOid &:= chr(subId);
      else
        subIdStri := str(chr(subId mod 128));
        subId := subId mdiv 128;
        repeat
          subIdStri := str(chr(subId mod 128 + 128)) & subIdStri;
          subId := subId mdiv 128;
        until subId = 0;
        encodedOid &:= subIdStri;
      end if;
      incr(pos);
    end while;
  end func;


const func array integer: decodeObjectIdentifier (in string: encodedOid) is func
  result
    var array integer: oid is 0 times 0;
  local
    var integer: pos is 2;
    var integer: subId is 0;
    var boolean: highBitClear is FALSE;
  begin
    oid &:= ord(encodedOid[1]) mdiv 40;
    oid &:= ord(encodedOid[1]) mod 40;
    while pos <= length(encodedOid) do
      subId := 0;
      repeat
        subId *:= 128;
        subId +:= ord(encodedOid[pos]) mod 128;
        highBitClear := ord(encodedOid[pos]) <= 127;
        incr(pos);
      until highBitClear;
      oid &:= subId;
    end while;
  end func;


const func string: objectIdentifier (in string: encodedOid) is func
  result
    var string: stri is "";
  local
    var integer: pos is 2;
    var integer: subId is 0;
    var boolean: highBitClear is FALSE;
  begin
    stri := str(ord(encodedOid[1]) mdiv 40);
    stri &:= " " & str(ord(encodedOid[1]) mod 40);
    while pos <= length(encodedOid) do
      subId := 0;
      repeat
        subId *:= 128;
        subId +:= ord(encodedOid[pos]) mod 128;
        highBitClear := ord(encodedOid[pos]) <= 127;
        incr(pos);
      until highBitClear;
      stri &:= " " & str(subId);
    end while;
  end func;


(**
 *  Read the header of an ASN.1/BER data element, from ''stri''.
 *  It is assumed that the data element header starts at position ''pos''.
 *  The function advances ''pos'' beyond the header to the actual data.
 *  The actual data can be read afterwards, with the function ''getData''.
 *   dataElem := getAsn1DataElement(asn1, pos);
 *   if dataElem.tagType = tagObjectIdentifier then
 *     contentType := getData(asn1, pos, dataElem);
 *     ...
 *  @return the header of an ASN.1/BER data element.
 *)
const func asn1DataElement: getAsn1DataElement (in string: stri, inout integer: pos) is func
  result
    var asn1DataElement: dataElement is asn1DataElement.value;
  local
    var integer: classTag is 0;
    var integer: length is 0;
    var integer: eocPos is 0;
    var integer: numOctets is 0;
  begin
    classTag := ord(stri[pos]);
    incr(pos);
    length := ord(stri[pos]);
    incr(pos);
    dataElement.tagClass := asn1TagClass conv (classTag >> 6);
    dataElement.constructed := (classTag >> 5) mod 2 <> 0;
    dataElement.tagType := asn1TagType conv (classTag mod 32);
    if length <= 127 then
      # Short form
      # writeln("Short form: length=" <& length <& ", pos=" <& pos);
      dataElement.length := length;
    elsif length = 128 then
      # Indefinite form
      # writeln(" *** indefinite form ***");
      dataElement.indefinite := TRUE;
      eocPos := pos(stri, "\0;\0;", pos);
      if eocPos <> 0 then
        dataElement.length := eocPos - pos;
      else
        dataElement.length := length(stri) + 1 - pos;
      end if;
    else
      # Long form
      numOctets := length mod 128;
      dataElement.length := bytes2Int(stri[pos fixLen numOctets], UNSIGNED, BE);
      pos +:= numOctets;
    end if;
    dataElement.dataStart := pos;
  end func;


(**
 *  Read the data of a given ASN.1/BER ''dataElement'', from ''stri''.
 *  It is assumed that the actual data starts at position ''pos''.
 *  The function advances ''pos'' beyond the ''dataElement'' data.
 *  @return the data of the ASN.1/BER ''dataElement''.
 *)
const func string: getData (in string: stri, inout integer: pos,
    in asn1DataElement: dataElement) is func
  result
    var string: data is "";
  begin
    data := stri[dataElement.dataStart len dataElement.length];
    pos +:= dataElement.length;
  end func;


(**
 *  Skip the data of a given ASN.1/BER ''dataElement'', from ''stri''.
 *  It is assumed that the actual data starts at position ''pos''.
 *  The function advances ''pos'' beyond the ''dataElement'' data.
 *)
const proc: skipData (inout integer: pos, in asn1DataElement: dataElement) is func
  begin
    pos +:= dataElement.length;
  end func;


const func string: genAsn1Length (in integer: length) is func
  result
    var string: asn1 is "";
  local
    var string: lengthAsBytes is "";
  begin
    if length <= 127 then
      # Short form
      asn1 &:= chr(length);
    else
      # Long form
      lengthAsBytes := bytes(length, UNSIGNED, BE);
      asn1 &:= chr(128 + length(lengthAsBytes));
      asn1 &:= lengthAsBytes;
    end if;
  end func;


const func asn1TagType: asn1TagTypeOfString (in string: stri) is func
  result
    var asn1TagType: tagType is tagEndOfContent;
  local
    const set of char: visibleChar is {' ' .. '~'};  # ASCII without control chars
    const set of char: printableChar is
        {'A' .. 'Z'} | {'a' .. 'z'} | {'0' .. '9'} |
        {' ', ''', '(', ')', '+', ',', '-', '.', '/', ':', '=', '?'};
    var boolean: isPrintableString is TRUE;
    var boolean: isVisibleString is TRUE;
    var char: ch is ' ';
  begin
    for ch range stri until not isPrintableString do
      if ch not in printableChar then
        isPrintableString := FALSE;
      end if;
      if ch not in visibleChar then
        isVisibleString := FALSE;
      end if;
    end for;
    if isPrintableString then
      tagType := tagPrintableString;
    elsif isVisibleString then
      tagType := tagVisibleString;
    else
      tagType := tagUTF8String;
    end if;
  end func;


(**
 *  Create an ASN.1/BER data element from ''tagType'' and ''data''.
 *  @return the ASN.1/BER data element as [[string]].
 *)
const func string: genAsn1Element (in asn1TagType: tagType, in string: data) is func
  result
    var string: asn1 is "";
  begin
    asn1 &:= chr(ord(tagType));
    asn1 &:= genAsn1Length(length(data));
    asn1 &:= data;
  end func;


(**
 *  Create an integer ASN.1/BER data element from ''data''.
 *  The tag type of the generated data element is tagInteger.
 *   genAsn1Integer(bytes(123, SIGNED, BE))  returns  "\2;\1;{"
 *  @return the integer ASN.1/BER data element as [[string]].
 *)
const func string: genAsn1Integer (in string: data) is func
  result
    var string: asn1 is "";
  begin
    asn1 &:= chr(ord(tagInteger));
    asn1 &:= genAsn1Length(length(data));
    asn1 &:= data;
  end func;


(**
 *  Create a string ASN.1/BER data element from ''data''.
 *  Depending on ''data'' the tag type of the generated data element
 *  is tagPrintableString, tagVisibleString or tagUTF8String.
 *   genAsn1String("abc")  returns  "\19;\3;abc"
 *   genAsn1String("#%&")  returns  "\26;\3;#%&"
 *   genAsn1String("€")    returns  "\f\3;â\130;¬"
 *  @return the string ASN.1/BER data element as [[string]].
 *)
const func string: genAsn1String (in string: data) is func
  result
    var string: asn1 is "";
  local
    var asn1TagType: tagType is tagEndOfContent;
  begin
    tagType := asn1TagTypeOfString(data);
    if tagType = tagUTF8String then
      asn1 := genAsn1Element(tagUTF8String, toUtf8(data));
    else
      asn1 := genAsn1Element(tagType, data);
    end if;
  end func;


(**
 *  Create a sequence ASN.1/BER data element from ''data''.
 *  The tag type of the generated data element is tagSequence.
 *  @return the sequence ASN.1/BER data element as [[string]].
 *)
const func string: genAsn1Sequence (in string: data) is func
  result
    var string: asn1 is "";
  begin
    # A sequence is universal (0) and constructed (32).
    asn1 &:= chr(ord(tagSequence) + 32);
    asn1 &:= genAsn1Length(length(data));
    asn1 &:= data;
  end func;


(**
 *  Create a set ASN.1/BER data element from ''data''.
 *  The tag type of the generated data element is tagSet.
 *  @return the set ASN.1/BER data element as [[string]].
 *)
const func string: genAsn1Set (in string: data) is func
  result
    var string: asn1 is "";
  begin
    # A set is universal (0) and constructed (32).
    asn1 &:= chr(ord(tagSet) + 32);
    asn1 &:= genAsn1Length(length(data));
    asn1 &:= data;
  end func;


(**
 *  Create an explicit ASN.1/BER tag with ''tagNumber'' from ''data''.
 *  @return the explicit ASN.1/BER tag as [[string]].
 *)
const func string: genExplicitAsn1Tag (in integer: tagNumber, in string: data) is func
  result
    var string: asn1 is "";
  begin
    # A tag is context-specific (128) and constructed (32).
    asn1 &:= chr(tagNumber + 160);
    asn1 &:= genAsn1Length(length(data));
    asn1 &:= data;
  end func;


const proc: printAsn1 (in string: stri, inout integer: pos) is func
  local
    var integer: startPos is 0;
    var boolean: constructed is TRUE;
    var integer: classTag is 0;
    var asn1TagType: tagType is tagEndOfContent;
    var integer: length is 0;
    var integer: numOctets is 0;
    var string: contents is "";
    var integer: posAfterwards is 0;
    var integer: subId is 0;
  begin
    startPos := pos;
    write(pos lpad 5 <& ": ");
    classTag := ord(stri[pos]);
    incr(pos);
    length := ord(stri[pos]);
    incr(pos);
    write(classTag radix 16 lpad0 2 <& " ");
    write("UACP"[(classTag >> 6) + 1]);
    constructed := (classTag >> 5) mod 2 <> 0;
    write("PC"[succ(ord(constructed))]);
    tagType := asn1TagType conv (classTag mod 32);
    write(" " <& length radix 16 lpad0 2);
    if classTag mod 32 = 31 then
      writeln(" *** long form *** ");
    end if;
    if length <= 127 then
      # Short form
      # writeln("Short form: length=" <& length <& ", pos=" <& pos);
      contents := stri[pos len length];
      posAfterwards := pos + length;
    elsif length = 128 then
      # Indefinite form
      writeln(" *** indefinite form ***");
      posAfterwards := pos;
      contents := getAsciiz(stri, posAfterwards);
      if pos <= length(stri) and stri[pos] = '\0;' then
        incr(pos);
      else
        writeln(" *** Second byte of EOC (End-of-Content) not 0");
      end if;
    else
      # Long form
      numOctets := length mod 128;
      if numOctets <= 7 then
        length := bytes2Int(stri[pos fixLen numOctets], UNSIGNED, BE);
        # writeln("Long form: numOctets=" <& numOctets <& ", length=" <& length);
      else
        writeln(" *** numOctets (" <& numOctets <& ") too big.");
        length := 0;
      end if;
      pos +:= numOctets;
      contents := stri[pos len length];
      posAfterwards := pos + length;
    end if;
    write(" " <& length lpad 4);
    if (classTag >> 6) = 2 then
      write(" EXPLICIT TAG [" <& ord(tagType) <& "]");
    else
      write(" " <& classTagName[ord(tagType)]);
    end if;
    if tagType = tagObjectIdentifier then
      write(":");
      for subId range decodeObjectIdentifier(contents) do
        write(" " <& subId);
      end for;
      writeln(" (" <& literal(contents) <& ")");
    else
      writeln(": " <& literal(contents));
    end if;
    if constructed then
      while pos < posAfterwards do
        printAsn1(stri, pos);
      end while;
      if pos <> posAfterwards then
        writeln("strange things happen " <& pos <& " " <& posAfterwards);
      end if;
      writeln("Leaving construct started at " <& startPos);
    else
      if posAfterwards > succ(length(stri)) then
        writeln("strange things happen " <& posAfterwards <& " " <& succ(length(stri)));
      end if;
      pos := posAfterwards;
    end if;
  end func;


const proc: printAsn1 (in string: stri) is func
  local
    var integer: pos is 1;
  begin
    while pos < length(stri) do
      printAsn1(stri, pos);
    end while;
  end func;


const proc: searchLengthByte (in string: stri, in integer: pos) is func
  local
    var integer: testPos is 0;
    var integer: printPos is 0;
  begin
    for testPos range pred(pos) downto 2 do
      if ord(stri[testPos]) = pred(pos - testPos) then
        printPos := pred(testPos);
        printAsn1(stri, printPos);
      end if;
    end for;
  end func;