diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Revision history for asn1-ber-syntax +## 0.2.0.0 -- 2022-04-11 + +* Support UtcTime and Boolean. Technically a breaking + change since it adds data constructors. + ## 0.1.0.0 -- 2022-??-?? * Initial release diff --git a/asn1-ber-syntax.cabal b/asn1-ber-syntax.cabal --- a/asn1-ber-syntax.cabal +++ b/asn1-ber-syntax.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: asn1-ber-syntax -version: 0.1.0.0 +version: 0.2.0.0 synopsis: ASN.1 BER Encode and Decode bug-reports: https://github.com/andrewthad/asn1-ber-syntax/issues license: BSD-3-Clause @@ -25,6 +25,7 @@ , byteslice >=0.2.7 && <0.3 , bytesmith >=0.3 && <0.4 , bytestring >=0.10 + , chronos >=1.1.5 , contiguous >=0.5 , natural-arithmetic >=0.1.2 , primitive >=0.7.1 && <0.8 diff --git a/src/Asn/Ber.hs b/src/Asn/Ber.hs --- a/src/Asn/Ber.hs +++ b/src/Asn/Ber.hs @@ -39,8 +39,10 @@ import GHC.Exts (Int(I#)) import GHC.ST (ST(ST)) +import qualified Chronos import qualified Data.Bytes as Bytes import qualified Data.Bytes.Parser as P +import qualified Data.Bytes.Parser.Latin as Latin import qualified Data.Bytes.Parser.Base128 as Base128 import qualified Data.Primitive as PM import qualified Data.Text.Short as TS @@ -56,7 +58,9 @@ deriving stock (Eq) data Contents - = Integer !Int64 + = Boolean !Bool + -- ^ Tag number: @0x01@ + | Integer !Int64 -- ^ Tag number: @0x02@ | OctetString {-# UNPACK #-} !Bytes -- ^ Tag number: @0x04@ @@ -70,8 +74,18 @@ -- ^ Tag number: @0x0C@ | PrintableString {-# UNPACK #-} !TS.ShortText -- ^ Tag number: @0x13@ - | UtcTime - -- ^ Tag number: @0x17@ + | UtcTime !Int64 + -- ^ Tag number: @0x17@. Number of seconds since the epoch. + -- The following guidance is inspired by RFC 5280: + -- + -- * A two-digit year greater than or equal to 50 is interpreted + -- as 19XX, and a two-digit year less than 50 is intepreted + -- as 20XX. + -- * Everything is converted to Zulu time zone. Unlike RFC 5280, + -- we do not require Zulu, but we convert everything to it. + -- * When seconds are absent, we treat the timestamp as one where + -- the seconds are zero. That is, we understand 2303252359Z as + -- 2023-03-25T23:59:00Z. | Constructed !(SmallArray Value) -- ^ Constructed value contents in concatenation order. -- The class and tag are held in `Value`. @@ -265,9 +279,21 @@ n <- takeLength when (n < 1) (P.fail "bitstring must have length of at least 1") padding <- P.any "expected a padding bit count" - bs <- P.take "while decoding octet string, not enough bytes" (fromIntegral (n - 1)) - pure (BitString padding bs) + if padding >= 8 + then P.fail "bitstring has more than 7 padding bits" + else do + bs <- P.take "while decoding octet string, not enough bytes" (fromIntegral (n - 1)) + pure (BitString padding bs) +boolean :: Parser String s Contents +boolean = takeLength >>= \case + 1 -> do + w <- P.any "expected boolean payload" + pure $ Boolean $ case w of + 0 -> False + _ -> True + _ -> P.fail "boolean length must be 1 byte" + integer :: Parser String s Contents integer = takeLength >>= \case 0 -> P.fail "integers must have non-zero length" @@ -290,10 +316,73 @@ -- TODO: write this utcTime :: Parser String s Contents utcTime = do - n <- takeLength - _ <- P.take "while decoding utctime, not enough bytes" (fromIntegral n) - pure UtcTime + len <- takeLength + P.delimit "utctime not enough bytes" "utctime leftovers" (fromIntegral len) $ do + !year0 <- twoDigits "utctime year digit problem" + let !year = if year0 >= 50 then 1900 + year0 else 2000 + year0 + !month <- twoDigits "utctime month digit problem" + !day <- twoDigits "utctime day digit problem" + !hour <- twoDigits "utctime hour digit problem" + !minute <- twoDigits "utctime minute digit problem" + -- Offset must be provided in seconds. + let finishWithoutSeconds !offset = case Chronos.timeFromYmdhms year month day hour minute 0 of + Chronos.Time ns -> pure $! UtcTime (offset + div ns 1_000_000_000) + let finishWithSeconds !offset !seconds = case Chronos.timeFromYmdhms year month day hour minute seconds of + Chronos.Time ns -> pure $! UtcTime (offset + div ns 1_000_000_000) + Latin.peek >>= \case + Nothing -> finishWithoutSeconds 0 + Just c -> case c of + 'Z' -> do + _ <- P.any "utctime impossible" + finishWithoutSeconds 0 + '+' -> do + _ <- P.any "utctime impossible" + !offsetHour <- twoDigits "utctime offset hour digit problem" + !offsetMinute <- twoDigits "utctime offset minute digit problem" + let !offset = fromIntegral @Int @Int64 (negate (60 * (60 * offsetHour + offsetMinute))) + finishWithoutSeconds offset + '-' -> do + _ <- P.any "utctime impossible" + !offsetHour <- twoDigits "utctime offset hour digit problem" + !offsetMinute <- twoDigits "utctime offset minute digit problem" + let !offset = fromIntegral @Int @Int64 (60 * (60 * offsetHour + offsetMinute)) + finishWithoutSeconds offset + _ | c >= '0', c <= '9' -> do + seconds <- twoDigits "utctime seconds digit problem" + Latin.peek >>= \case + Nothing -> finishWithSeconds 0 seconds + Just d -> case d of + 'Z' -> do + _ <- P.any "utctime impossible" + finishWithSeconds 0 seconds + '+' -> do + _ <- P.any "utctime impossible" + !offsetHour <- twoDigits "utctime offset hour digit problem" + !offsetMinute <- twoDigits "utctime offset minute digit problem" + let !offset = fromIntegral @Int @Int64 (negate (60 * (60 * offsetHour + offsetMinute))) + finishWithSeconds offset seconds + '-' -> do + _ <- P.any "utctime impossible" + !offsetHour <- twoDigits "utctime offset hour digit problem" + !offsetMinute <- twoDigits "utctime offset minute digit problem" + let !offset = fromIntegral @Int @Int64 (60 * (60 * offsetHour + offsetMinute)) + finishWithSeconds offset seconds + _ -> P.fail "utctime unexpected byte after seconds" + _ -> P.fail "utctime unexpected byte after minute" +twoDigits :: e -> Parser e s Int +{-# inline twoDigits #-} +twoDigits e = do + w0 <- P.any e + w0' <- if w0 >= 0x30 && w0 <= 0x39 + then pure (fromIntegral @Word8 @Int w0 - 0x30) + else P.fail e + w1 <- P.any e + w1' <- if w1 >= 0x30 && w1 <= 0x39 + then pure (fromIntegral @Word8 @Int w1 - 0x30) + else P.fail e + pure (w0' * 10 + w1') + nullParser :: Parser String s Contents nullParser = fmap (const Null) . nullPayload =<< takeLength @@ -321,6 +410,7 @@ | Universal <- tagClass , not isConstructed -> case tagNumber of + 0x01 -> boolean 0x13 -> printableString 0x02 -> integer 0x03 -> bitString diff --git a/src/Asn/Ber/Encode.hs b/src/Asn/Ber/Encode.hs --- a/src/Asn/Ber/Encode.hs +++ b/src/Asn/Ber/Encode.hs @@ -1,8 +1,10 @@ {-# language BangPatterns #-} +{-# language DataKinds #-} {-# language DuplicateRecordFields #-} {-# language LambdaCase #-} {-# language MultiWayIf #-} {-# language NamedFieldPuns #-} +{-# language NumericUnderscores #-} {-# language TypeApplications #-} module Asn.Ber.Encode @@ -26,8 +28,11 @@ import qualified Data.Primitive as Prim import qualified Data.Primitive.Contiguous as C import qualified Data.Bytes as Bytes +import qualified Data.Bytes.Builder.Bounded as BB import qualified Data.Bytes.Types import qualified Data.Text.Short as TS +import qualified Chronos +import qualified Arithmetic.Nat as Nat data Encoder = Leaf {-# UNPACK #-} !Bytes @@ -115,10 +120,40 @@ lenHeader = word8 $ bit 7 .|. (fromIntegral @Int @Word8 (length len)) in lenHeader <> len --- Note: UtcTime is missing and will crash the program encodeContents :: Contents -> Encoder encodeContents = \case Integer n -> base256 n + Boolean b -> case b of + True -> word8 0xFF + False -> word8 0x00 + UtcTime epochSeconds -> + let t = Chronos.Time (epochSeconds * 1_000_000_000) + in case Chronos.timeToDatetime t of + Chronos.Datetime + { datetimeDate = Chronos.Date + { dateYear = Chronos.Year year + , dateMonth = Chronos.Month month + , dateDay = Chronos.DayOfMonth day + } + , datetimeTime = Chronos.TimeOfDay + { timeOfDayHour = hour + , timeOfDayMinute = minute + , timeOfDayNanoseconds = nanoseconds + } + } -> Leaf $ Bytes.fromByteArray $ BB.run Nat.constant $ + encodeTwoDigit (rem year 100) + `BB.append` + encodeTwoDigit (month + 1) + `BB.append` + encodeTwoDigit day + `BB.append` + encodeTwoDigit hour + `BB.append` + encodeTwoDigit minute + `BB.append` + encodeTwoDigit (fromIntegral @Int64 @Int (quot nanoseconds 1_000_000_000)) + `BB.append` + BB.ascii 'Z' OctetString bs -> bytes bs BitString padBits bs -> word8 padBits <> bytes bs Null -> mempty @@ -129,6 +164,12 @@ PrintableString str -> printableString str Constructed arr -> constructed arr Unresolved raw -> bytes raw + +encodeTwoDigit :: Int -> BB.Builder 2 +encodeTwoDigit !n = + BB.word8 (fromIntegral @Int @Word8 (0x30 + quot n 10)) + `BB.append` + BB.word8 (fromIntegral @Int @Word8 (0x30 + rem n 10)) ------------------ Content Encoders ------------------ diff --git a/test/Properties.hs b/test/Properties.hs --- a/test/Properties.hs +++ b/test/Properties.hs @@ -1,4 +1,5 @@ {-# language NamedFieldPuns #-} +{-# language NumericUnderscores #-} {-# language TypeApplications #-} import Asn.Ber (Value(..),Class(..),Contents(..)) @@ -18,6 +19,7 @@ import qualified Data.Text.Short as TS import qualified GHC.Exts as Exts import qualified Test.QuickCheck.Gen as Gen +import qualified Test.QuickCheck as QC main :: IO () @@ -46,6 +48,15 @@ [ do let tagNumber = 0x02 contents <- Integer <$> arbitrary + pure Value{tagClass,tagNumber,contents} + , do + let tagNumber = 0x17 + contents <- UtcTime <$> QC.choose + (-100_000_000,1_500_000_000) + pure Value{tagClass,tagNumber,contents} + , do + let tagNumber = 0x01 + contents <- Boolean <$> arbitrary pure Value{tagClass,tagNumber,contents} , do contents <- OctetString <$> arbitrary