asn1-ber-syntax 0.1.0.0 → 0.2.0.0
raw patch · 5 files changed
+158/−10 lines, 5 filesdep +chronosPVP ok
version bump matches the API change (PVP)
Dependencies added: chronos
API changes (from Hackage documentation)
+ Asn.Ber: Boolean :: !Bool -> Contents
- Asn.Ber: UtcTime :: Contents
+ Asn.Ber: UtcTime :: !Int64 -> Contents
Files
- CHANGELOG.md +5/−0
- asn1-ber-syntax.cabal +2/−1
- src/Asn/Ber.hs +98/−8
- src/Asn/Ber/Encode.hs +42/−1
- test/Properties.hs +11/−0
CHANGELOG.md view
@@ -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
asn1-ber-syntax.cabal view
@@ -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
src/Asn/Ber.hs view
@@ -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
src/Asn/Ber/Encode.hs view
@@ -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 ------------------
test/Properties.hs view
@@ -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