packages feed

asn1-ber-syntax (empty) → 0.1.0.0

raw patch · 14 files changed

+1641/−0 lines, 14 filesdep +QuickCheckdep +array-chunksdep +asn1-ber-syntaxsetup-changed

Dependencies added: QuickCheck, array-chunks, asn1-ber-syntax, base, base16, bytebuild, byteslice, bytesmith, bytestring, contiguous, filepath, natural-arithmetic, pretty-simple, primitive, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, text-short, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for asn1-ber-syntax++## 0.1.0.0 -- 2022-??-??++* Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Andrew Martin++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Andrew Martin nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ asn1-ber-syntax.cabal view
@@ -0,0 +1,87 @@+cabal-version: 2.4+name: asn1-ber-syntax+version: 0.1.0.0+synopsis: ASN.1 BER Encode and Decode+bug-reports: https://github.com/andrewthad/asn1-ber-syntax/issues+license: BSD-3-Clause+license-file: LICENSE+author: Andrew Martin+maintainer: andrew.thaddeus@gmail.com+copyright: 2022 Andrew Martin+category: Data+build-type: Simple+extra-source-files: CHANGELOG.md++library+  exposed-modules:+      Asn.Ber+    , Asn.Ber.Encode+    , Asn.Oid+    , Asn.Resolve+    , Asn.Resolve.Category+  build-depends:+    , array-chunks >=0.1+    , base >=4.13 && <5+    , byteslice >=0.2.7 && <0.3+    , bytesmith >=0.3 && <0.4+    , bytestring >=0.10+    , contiguous >=0.5+    , natural-arithmetic >=0.1.2+    , primitive >=0.7.1 && <0.8+    , bytebuild >=0.3.7 && <0.4+    , text-short >=0.1.3+    , vector >=0.12+  hs-source-dirs: src+  default-language: Haskell2010+  ghc-options: -Wall -O2++test-suite test+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  build-depends:+    , asn1-ber-syntax+    , base+    , byteslice+    , tasty+    , tasty-hunit+    , tasty-quickcheck >=0.10+  ghc-options: -Wall -O2+  default-language: Haskell2010++test-suite asn1-ber-syntax-golden+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Golden.hs+  other-modules:+    Message+    Message.Category+  build-depends:+    , asn1-ber-syntax+    , base+    , base16+    , byteslice+    , bytestring+    , filepath+    , pretty-simple >=3.3 && <4.0+    , primitive+    , tasty+    , tasty-golden+  ghc-options: -Wall -O2+  default-language: Haskell2010++test-suite test-properties+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Properties.hs+  build-depends:+    , asn1-ber-syntax+    , base+    , byteslice+    , primitive+    , QuickCheck+    , tasty+    , tasty-quickcheck+    , text-short+  ghc-options: -Wall -O2+  default-language: Haskell2010
+ src/Asn/Ber.hs view
@@ -0,0 +1,341 @@+{-# language BangPatterns #-}+{-# language BinaryLiterals #-}+{-# language DerivingStrategies #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}+{-# language MultiWayIf #-}+{-# language NamedFieldPuns #-}+{-# language NumericUnderscores #-}+{-# language PatternSynonyms #-}+{-# language RankNTypes #-}+{-# language TypeApplications #-}+{-# language UnboxedTuples #-}++module Asn.Ber+  ( Value(..)+  , Contents(..)+  , Class(..)+  , decode+  , decodeInteger+  , decodeOctetString+  , decodeNull+  , decodeObjectId+  , decodeUtf8String+  , decodePrintableString+    -- * Constructed Patterns+  , pattern Set+  , pattern Sequence+  ) where++import Asn.Oid (Oid(..))+import Control.Monad (when)+import Data.Bits ((.&.),(.|.),testBit,unsafeShiftR,unsafeShiftL,complement)+import Data.Bytes (Bytes)+import Data.Bytes.Parser (Parser)+import Data.ByteString.Short.Internal (ShortByteString(SBS))+import Data.Int (Int64)+import Data.Primitive (SmallArray)+import Data.Word (Word8,Word32)+import GHC.Exts (Int(I#))+import GHC.ST (ST(ST))++import qualified Data.Bytes as Bytes+import qualified Data.Bytes.Parser as P+import qualified Data.Bytes.Parser.Base128 as Base128+import qualified Data.Primitive as PM+import qualified Data.Text.Short as TS+import qualified Data.Text.Short.Unsafe as TS+import qualified GHC.Exts as Exts++data Value = Value+  { tagClass :: !Class+  , tagNumber :: !Word32+  , contents :: !Contents+  }+  deriving stock (Show)+  deriving stock (Eq)++data Contents+  = Integer !Int64+    -- ^ Tag number: @0x02@+  | OctetString {-# UNPACK #-} !Bytes+    -- ^ Tag number: @0x04@+  | BitString !Word8 {-# UNPACK #-} !Bytes+    -- ^ Tag number: @0x03@. Has padding bit count and raw bytes.+  | Null+    -- ^ Tag number: @0x05@+  | ObjectIdentifier !Oid+    -- ^ Tag number: @0x06@+  | Utf8String {-# UNPACK #-} !TS.ShortText+    -- ^ Tag number: @0x0C@+  | PrintableString {-# UNPACK #-} !TS.ShortText+    -- ^ Tag number: @0x13@+  | UtcTime+    -- ^ Tag number: @0x17@+  | Constructed !(SmallArray Value)+    -- ^ Constructed value contents in concatenation order.+    -- The class and tag are held in `Value`.+  | Unresolved {-# UNPACK #-} !Bytes+    -- ^ Values that require information about interpreting application,+    -- context-specific, or private tag.+  deriving stock (Show)+  deriving stock (Eq)++pattern Sequence :: Word32+pattern Sequence = 0x10++pattern Set :: Word32+pattern Set = 0x11++data Class+  = Universal+  | Application+  | ContextSpecific+  | Private+  deriving stock (Eq,Show)++decode :: Bytes -> Either String Value+decode = P.parseBytesEither parser++decodePayload :: (forall s. Word -> Parser String s a) -> Bytes -> Either String a+decodePayload k bs =+  let len = fromIntegral @Int @Word (Bytes.length bs)+   in P.parseBytesEither (k len) bs++decodeInteger :: Bytes -> Either String Int64+decodeInteger = decodePayload integerPayload++decodeOctetString :: Bytes -> Either String Bytes+decodeOctetString = decodePayload octetStringPayload++decodeNull :: Bytes -> Either String ()+decodeNull = decodePayload nullPayload++decodeObjectId :: Bytes -> Either String Oid+decodeObjectId = decodePayload objectIdentifierPayload++decodeUtf8String :: Bytes -> Either String TS.ShortText+decodeUtf8String = decodePayload utf8StringPayload++decodePrintableString :: Bytes -> Either String TS.ShortText+decodePrintableString = decodePayload printableStringPayload++takeLength :: Parser String s Word+takeLength = do+  w <- P.any "tried to take the length"+  case testBit w 7 of+    False -> pure (fromIntegral w)+    True -> do+      let go !n !acc = case n of+            0 -> pure acc+            _ -> if acc < 16_000_000+              then do+                x <- P.any "while taking length, ran out of bytes"+                let acc' = fromIntegral @Word8 @Word x + (acc * 256)+                go (n - 1) acc'+              else P.fail "that is a giant length, bailing out"+      go (fromIntegral @Word8 @Word w .&. 0b01111111) 0++objectIdentifier :: Parser String s Contents+objectIdentifier = fmap ObjectIdentifier . objectIdentifierPayload =<< takeLength++objectIdentifierPayload :: Word -> Parser String s Oid+objectIdentifierPayload len = do+  when (len < 1) (P.fail "oid must have length of at least 1")+  P.delimit "oid not enough bytes" "oid leftovers" (fromIntegral len) $ do+    w0 <- P.any "oid expecting first byte"+    let (v1, v2) = quotRem w0 40+        initialSize = 12+    buf0 <- P.effect (PM.newPrimArray initialSize)+    P.effect $ do+      PM.writePrimArray buf0 0 (fromIntegral @Word8 @Word32 v1)+      PM.writePrimArray buf0 1 (fromIntegral @Word8 @Word32 v2)+    let go !ix !sz !buf = P.isEndOfInput >>= \case+          True -> do+            res <- P.effect $ do+              PM.shrinkMutablePrimArray buf ix+              PM.unsafeFreezePrimArray buf+            pure (Oid res)+          False -> if ix < sz+            then do+              w <- Base128.word32 "bad oid fragment"+              P.effect (PM.writePrimArray buf ix w)+              go (ix + 1) sz buf+            else do+              let newSz = sz * 2+              newBuf <- P.effect $ do+                newBuf <- PM.newPrimArray newSz+                PM.copyMutablePrimArray newBuf 0 buf 0 sz+                pure newBuf+              go ix newSz newBuf+    go 2 initialSize buf0+++unresolved :: Parser String s Contents+unresolved = do+  n <- takeLength+  bs <- P.take "while decoding unresolved contents, not enough bytes" (fromIntegral n)+  pure (Unresolved bs)++constructed :: Parser String s Contents+constructed = do+  n <- takeLength+  P.delimit "constructed not enough bytes" "constructed leftovers" (fromIntegral n) $ do+    let initialSize = 8+    buf0 <- P.effect (PM.newSmallArray initialSize errorThunk)+    let go !ix !sz !buf = P.isEndOfInput >>= \case+          True -> do+            res <- P.effect $ do+              buf' <- resizeSmallMutableArray buf ix+              PM.unsafeFreezeSmallArray buf'+            pure (Constructed res)+          False -> if ix < sz+            then do+              v <- parser+              P.effect (PM.writeSmallArray buf ix v)+              go (ix + 1) sz buf+            else do+              let newSz = sz * 2+              newBuf <- P.effect $ do+                newBuf <- PM.newSmallArray newSz errorThunk+                PM.copySmallMutableArray newBuf 0 buf 0 sz+                pure newBuf+              go ix newSz newBuf+    go 0 initialSize buf0++resizeSmallMutableArray :: PM.SmallMutableArray s a -> Int -> ST s (PM.SmallMutableArray s a)+resizeSmallMutableArray (PM.SmallMutableArray x) (I# i) =+  ST (\s -> (# Exts.shrinkSmallMutableArray# x i s, PM.SmallMutableArray x #))++errorThunk :: a+{-# noinline errorThunk #-}+errorThunk = errorWithoutStackTrace "Asn.Ber: implementation mistake"++utf8String :: Parser String s Contents+utf8String = fmap Utf8String . utf8StringPayload =<< takeLength++utf8StringPayload :: Word -> Parser String s TS.ShortText+utf8StringPayload len = do+  bs <- P.take "while decoding UTF-8 string, not enough bytes" (fromIntegral len)+  case TS.fromShortByteString (ba2sbs (Bytes.toByteArrayClone bs)) of+    Nothing -> P.fail "found non-UTF-8 byte sequences in printable string"+    Just r -> pure r+++printableString :: Parser String s Contents+printableString = fmap PrintableString . printableStringPayload =<< takeLength++printableStringPayload :: Word -> Parser String s TS.ShortText+printableStringPayload len = do+  bs <- P.take "while decoding printable string, not enough bytes" (fromIntegral len)+  if Bytes.all isPrintable bs+    then pure $! ba2stUnsafe $! Bytes.toByteArrayClone bs+    else P.fail "found non-printable characters in printable string"++isPrintable :: Word8 -> Bool+isPrintable = \case+  0x20 -> True+  0x27 -> True+  0x28 -> True+  0x29 -> True+  0x2B -> True+  0x2C -> True+  0x2D -> True+  0x2E -> True+  0x2F -> True+  0x3A -> True+  0x3D -> True+  0x3F -> True+  w | w >= 0x41 && w <= 0x5A -> True+  w | w >= 0x61 && w <= 0x7A -> True+  w | w >= 0x30 && w <= 0x39 -> True+  _ -> False++octetString :: Parser String s Contents+octetString = fmap OctetString . octetStringPayload =<< takeLength++octetStringPayload :: Word -> Parser String s Bytes+octetStringPayload len = do+  P.take "while decoding octet string, not enough bytes" (fromIntegral len)++-- The whole bit string thing is kind of janky, but SNMP does not use+-- it, so it is not terribly important.+bitString :: Parser String s Contents+bitString = do+  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)++integer :: Parser String s Contents+integer = takeLength >>= \case+  0 -> P.fail "integers must have non-zero length"+  n | n <= 8 -> Integer <$> integerPayload n+    | otherwise -> do+      -- TODO parse bignums+      P.fail (show n ++ "-octet integer is too large to store in an Int64")++integerPayload :: Word -> Parser String s Int64+integerPayload len = do+  content <- P.take "while decoding integer, not enough bytes" (fromIntegral len)+  -- There are not zero-length integer encodings in BER, and we guared+  -- against this above, so taking the head with unsafeIndex is safe.+  let isNegative = testBit (Bytes.unsafeIndex content 0) 7+      loopBody acc b = (acc `unsafeShiftL` 8) .|. fromIntegral @Word8 @Int64 b+  pure $ if isNegative+    then Bytes.foldl' loopBody (complement 0) content+    else Bytes.foldl' loopBody 0 content++-- TODO: write this+utcTime :: Parser String s Contents+utcTime = do+  n <- takeLength+  _ <- P.take "while decoding utctime, not enough bytes" (fromIntegral n)+  pure UtcTime++nullParser :: Parser String s Contents+nullParser = fmap (const Null) . nullPayload =<< takeLength++nullPayload :: Word -> Parser String s ()+nullPayload 0 = pure ()+nullPayload len = P.fail ("expecting null contents to have length zero, got " ++ show len)+++classFromUpperBits :: Word8 -> Class+classFromUpperBits w = case unsafeShiftR w 6 of+  0 -> Universal+  1 -> Application+  2 -> ContextSpecific+  _ -> Private++parser :: Parser String s Value+parser = do+  b <- P.any "expected tag byte"+  let tagClass = classFromUpperBits b+      isConstructed = testBit b 5+  tagNumber <- case b .&. 0b00011111 of+        31 -> Base128.word32 "bad big tag"+        num -> pure $ fromIntegral @Word8 @Word32 num+  contents <- if+    | Universal <- tagClass+    , not isConstructed+    -> case tagNumber of+      0x13 -> printableString+      0x02 -> integer+      0x03 -> bitString+      0x04 -> octetString+      0x05 -> nullParser+      0x06 -> objectIdentifier+      0x0C -> utf8String+      0x17 -> utcTime+      _ -> P.fail ("unrecognized universal primitive tag number " ++ show tagNumber)+    | isConstructed -> constructed+    | otherwise -> unresolved+  pure Value{tagClass, tagNumber, contents}++ba2stUnsafe :: PM.ByteArray -> TS.ShortText+ba2stUnsafe (PM.ByteArray x) = TS.fromShortByteStringUnsafe (SBS x)++ba2sbs :: PM.ByteArray -> ShortByteString+ba2sbs (PM.ByteArray x) = SBS x
+ src/Asn/Ber/Encode.hs view
@@ -0,0 +1,192 @@+{-# language BangPatterns #-}+{-# language DuplicateRecordFields #-}+{-# language LambdaCase #-}+{-# language MultiWayIf #-}+{-# language NamedFieldPuns #-}+{-# language TypeApplications #-}++module Asn.Ber.Encode+  ( encode+  ) where++import Prelude hiding (length)++import Asn.Ber (Value(..),Contents(..),Class(..))+import Asn.Oid (Oid(..))+import Control.Monad.ST (runST)+import Data.Bits ((.&.),(.|.),unsafeShiftL,unsafeShiftR,bit,testBit)+import Data.Bytes.Types (Bytes(Bytes))+import Data.ByteString.Short.Internal (ShortByteString(SBS))+import Data.Foldable (foldMap',foldlM)+import Data.Int (Int64)+import Data.Primitive (SmallArray,PrimArray)+import Data.Primitive.ByteArray (byteArrayFromList,ByteArray(ByteArray))+import Data.Word (Word8,Word32)++import qualified Data.Primitive as Prim+import qualified Data.Primitive.Contiguous as C+import qualified Data.Bytes as Bytes+import qualified Data.Bytes.Types+import qualified Data.Text.Short as TS++data Encoder+  = Leaf {-# UNPACK #-} !Bytes+  | Node+    { _length :: !Int+    , _children :: !(SmallArray Encoder)+    }+  deriving(Show)++length :: Encoder -> Int+length (Leaf bs) = Bytes.length bs+length a@(Node _ _) = _length a++instance Semigroup Encoder where+  a <> b+    | length a == 0 = b+    | length b == 0 = a+  a <> b = Node+    { _length = length a + length b+    , _children = C.doubleton a b+    }++instance Monoid Encoder where+  mempty = Node 0 mempty++append3 :: Encoder -> Encoder -> Encoder -> Encoder+append3 a b c = Node+  { _length = length a + length b + length c+  , _children = C.tripleton a b c+  }++word8 :: Word8 -> Encoder+word8 = Leaf . Bytes.singleton++singleton :: Bytes -> Encoder+singleton = Leaf++run :: Encoder -> Bytes+run (Leaf bs) = bs+run Node{_length=len0,_children=children0} = runST $ do+  dst <- Prim.newByteArray len0+  let go !ixA eA = case eA of+        Leaf bs -> do+          Bytes.unsafeCopy dst ixA bs+          pure (Bytes.length bs + ixA)+        Node{_length,_children} -> do+          foldlM (\ixB eB -> go ixB eB) ixA _children+  ixC <- foldlM (\ixA e -> go ixA e) 0 children0+  if ixC /= len0+    then errorWithoutStackTrace "Asn.Ber.Encode.run: implementation mistake"+    else do+      dst' <- Prim.unsafeFreezeByteArray dst+      pure Bytes{array=dst',offset=0,length=len0}++encode :: Value -> Bytes+encode = run . encodeValue++encodeValue :: Value -> Encoder+encodeValue v@Value{contents} =+  let theContent = encodeContents contents+   in append3 (valueHeader v) (encodeLength (length theContent)) theContent++valueHeader :: Value -> Encoder+valueHeader Value{tagClass,tagNumber,contents} = byte1 <> extTag+  where+  byte1 = word8 (clsBits .|. pcBits .|. tagBits)+  clsBits = (`unsafeShiftL` 6) $ case tagClass of+    Universal -> 0+    Application -> 1+    ContextSpecific -> 2+    Private -> 3+  pcBits = case contents of+    Constructed _ -> bit 5+    _ -> 0x00+  tagBits = fromIntegral @Word32 @Word8 $ min tagNumber 31+  extTag+    | tagNumber < 31 = mempty+    | otherwise = base128 (fromIntegral @Word32 @Int64 tagNumber) -- FIXME use an unsigned base128 encoder++encodeLength :: Int -> Encoder+encodeLength n+  | n < 128 = word8 $ fromIntegral @Int @Word8 n+  | otherwise =+    let len = base256 (fromIntegral n)+        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+  OctetString bs -> bytes bs+  BitString padBits bs -> word8 padBits <> bytes bs+  Null -> mempty+  ObjectIdentifier (Oid arr)+    | Prim.sizeofPrimArray arr < 2 -> error "Object Identifier must have at least two components"+    | otherwise -> objectIdentifier arr+  Utf8String str -> utf8String str+  PrintableString str -> printableString str+  Constructed arr -> constructed arr+  Unresolved raw -> bytes raw++------------------ Content Encoders ------------------++base128 :: Int64 -> Encoder+base128 = go False (0 :: Int) []+  where+  go !lastNeg !size acc n =+    let content = fromIntegral @Int64 @Word8 (n .&. 0x7F)+        rest = n `unsafeShiftR` 7+        thisNeg = testBit content 6+        atEnd = (content == 0 && rest == 0 && not lastNeg)+              || (content == 0x7F && rest == (-1) && lastNeg)+     in if size /= 0 && atEnd+        then stop acc+        else+          let content' = (if size == 0 then 0 else 0x80) .|. content+           in go thisNeg (size + 1) (content' : acc) rest+  stop acc = singleton . Bytes.fromByteArray . byteArrayFromList $ acc++base256 :: Int64 -> Encoder+base256 n = singleton $ Bytes.fromByteArray (byteArrayFromList minimized)+  where+  byteList =+    [ fromIntegral @Int64 @Word8 $ 0xFF .&. (n `unsafeShiftR` bits)+    | bits <- [56,48..0]+    ]+  minimized+    | n < 0 =+      case dropWhile (==0xFF) byteList of+        bs'@(hd:_) | hd `testBit` 7 -> bs'+        bs' -> 0xFF:bs'+    | otherwise =+      case dropWhile (==0x00) byteList of+        bs'@(hd:_) | not (hd `testBit` 7) -> bs'+        bs' -> 0x00:bs'++bytes :: Bytes -> Encoder+bytes = singleton++objectIdentifier :: PrimArray Word32 -> Encoder+objectIdentifier arr = firstComps <> mconcat restComps+  where+  firstComps = word8 $ fromIntegral @Word32 @Word8 $+    (40 * Prim.indexPrimArray arr 0) + (Prim.indexPrimArray arr 1)+  restComps = [base128 $ fromIntegral @Word32 @Int64 $ Prim.indexPrimArray arr i+              | i <- [2..Prim.sizeofPrimArray arr - 1]]++utf8String :: TS.ShortText -> Encoder+utf8String str = singleton $ shortTextToBytes $ str++printableString :: TS.ShortText -> Encoder+printableString str = singleton $ shortTextToBytes $ str+  -- utf8 is backwards-compatible with ascii, so just hope that the input text is actually printable ascii++constructed :: SmallArray Value -> Encoder+constructed = foldMap' encodeValue++shortTextToBytes :: TS.ShortText -> Bytes+shortTextToBytes str = case TS.toShortByteString str of+  -- ShortText is already utf8-encoded, so just re-wrap it+  SBS arr -> Bytes.fromByteArray (ByteArray arr)
+ src/Asn/Oid.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeApplications #-}++module Asn.Oid+  ( Oid(..)+  , toShortText+  , fromShortTextDot+  , size+  , index+  , take+  , isPrefixOf+  ) where++import Prelude hiding (take)++import Control.Monad.ST (runST)+import Data.Primitive (PrimArray)+import Data.Text.Short (ShortText)+import Data.Word (Word32)+import Data.ByteString.Short.Internal (ShortByteString(SBS))++import qualified Arithmetic.Nat as Nat+import qualified Data.Bytes as Bytes+import qualified Data.Bytes.Chunks as Chunks+import qualified Data.Bytes.Builder as Builder+import qualified Data.Bytes.Builder.Bounded as Bounded+import qualified Data.Primitive as Prim+import qualified Data.Primitive.Contiguous as C+import qualified Data.Text.Short as ST+import qualified Data.Text.Short.Unsafe as ST+import qualified Data.Bytes.Parser as Parser+import qualified Data.Bytes.Parser.Latin as Latin+++newtype Oid = Oid { getOid :: PrimArray Word32 }+  deriving newtype (Show)+  deriving newtype (Semigroup)+  deriving newtype (Monoid)+  deriving newtype (Eq)+  deriving newtype (Ord)++-- | Encode an OID. Encodes the empty OID as empty text even though+-- this is not a valid encoded OID.+toShortText :: Oid -> ShortText+toShortText (Oid arr) = case sz of+  0 -> ST.empty+  _ -> ba2st $ Chunks.concatU $ Builder.run 256+    ( Builder.word32Dec (Prim.indexPrimArray arr 0)+      <>+      C.foldMap+        (\w -> Builder.fromBounded Nat.constant+          (Bounded.append (Bounded.ascii '.') (Bounded.word32Dec w))+        ) (C.slice arr 1 (sz - 1))+    )+  where+  !sz = Prim.sizeofPrimArray arr++-- | Decode an OID. Returns Nothing if the text is empty.+fromShortTextDot :: ShortText -> Maybe Oid+fromShortTextDot !str =+  let !b = Bytes.fromShortByteString (ST.toShortByteString str)+      !maxPossibleParts = div (Bytes.length b) 2 + 1+   in Parser.parseBytesMaybe+        ( do w0 <- Latin.decWord32 ()+             dst <- Parser.effect $ do+               dst <- Prim.newPrimArray maxPossibleParts+               Prim.writePrimArray dst 0 w0+               pure dst+             let go !ix = Parser.isEndOfInput >>= \case+                   True -> Parser.effect $ do+                     Prim.shrinkMutablePrimArray dst ix+                     dst' <- Prim.unsafeFreezePrimArray dst+                     pure (Oid dst')+                   False -> do+                     Latin.char () '.'+                     w <- Latin.decWord32 ()+                     Parser.effect (Prim.writePrimArray dst ix w)+                     go (ix + 1)+             go 1+        ) b++size :: Oid -> Int+{-# inline size #-}+size (Oid ws) = Prim.sizeofPrimArray ws++index :: Oid -> Int -> Word32+{-# inline index #-}+index (Oid arr) = Prim.indexPrimArray arr++take :: Oid -> Int -> Oid+take (Oid !preArr) !len+  | len >= Prim.sizeofPrimArray preArr = Oid preArr+  | otherwise = runST $ do+    dst <- Prim.newPrimArray len+    Prim.copyPrimArray dst 0 preArr 0 len+    Oid <$> Prim.unsafeFreezePrimArray dst++isPrefixOf :: Oid -> Oid -> Bool+isPrefixOf (Oid preArr) (Oid arr)+  | preSize > theSize = False+  | otherwise = go 0+  where+  go !i+    | i >= preSize = True+    | Prim.indexPrimArray preArr i /= Prim.indexPrimArray arr i = False+    | otherwise = go (i + 1)+  !preSize = Prim.sizeofPrimArray preArr+  !theSize = Prim.sizeofPrimArray arr++ba2st :: Prim.ByteArray -> ShortText+{-# inline ba2st #-}+ba2st (Prim.ByteArray x) = ST.fromShortByteStringUnsafe (SBS x)
+ src/Asn/Resolve.hs view
@@ -0,0 +1,200 @@+{-# language BangPatterns #-}+{-# language DeriveFunctor #-}+{-# language DerivingStrategies #-}+{-# language LambdaCase #-}+{-# language NamedFieldPuns #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}++-- | Transform between Haskell values and the 'Value' type. The instance you+-- write for 'ToAsn' and 'FromAsn' assume a schema. I (Eric) think this is+-- reasonable because I expect each schema to be one-to-one with data types.+module Asn.Resolve+  ( Parser+  , run+  , MemberParser+  -- * Combinators+  , fail+  , integer+  -- TODO bitString+  , octetString+  , null+  , oid+  , utf8String+  , printableString+  , sequence+  , index+  , sequenceOf+  , withTag+  , chooseTag+  -- * Error Breadcrumbs+  , Path(..)+  -- * Re-Exports+  , Value+  , Contents+  , Class(..)+  ) where++import Prelude hiding (fail,null,reverse,null,sequence)++import Asn.Ber (Value(..), Contents(..), Class(..))+import Asn.Oid (Oid)+import Control.Applicative (Alternative(..))+import Control.Monad.ST (ST, runST)+import Data.Bifunctor (first)+import Data.Bytes (Bytes)+import Data.Int (Int64)+import Data.Primitive (SmallArray,SmallMutableArray)+import Data.Text.Short (ShortText)+import Data.Word (Word32)++import qualified Data.Primitive as PM+import qualified Asn.Ber as Ber+++newtype Parser a = P { unP :: Path -> Either Path a }+  deriving stock (Functor)++instance Applicative Parser where+  pure x = P $ \_ -> Right x+  a <*> b = P $ \p -> unP a p <*> unP b p++instance Monad Parser where+  a >>= k = P $ \p -> unP a p >>= \x -> unP (k x) p++instance Alternative Parser where+  empty = fail+  a <|> b = P $ \p -> case unP a p of+    Right val -> Right val+    Left err1 -> case unP b p of+      Right val -> Right val+      Left err2 -> Left $ longerPath err1 err2++run :: Parser a -> Either Path a+run r = first reverse $ unP r Nil++newtype MemberParser a = MP+  { unMP :: SmallArray Value -> Path -> Either Path a }+  deriving stock Functor++instance Applicative MemberParser where+  pure a = MP (\_ _ -> Right a)+  MP f <*> MP g = MP $ \p mbrs ->+    f p mbrs <*> g p mbrs+++fail :: Parser a+fail = P $ Left++unresolved :: (Bytes -> Either String a) -> Bytes -> Parser a+unresolved f bytes = either (const fail) pure (f bytes)++integer :: Value -> Parser Int64+integer = \case+  Value{contents=Integer n} -> pure n+  Value{contents=Unresolved bytes} -> unresolved Ber.decodeInteger bytes+  _ -> fail++octetString :: Value -> Parser Bytes+octetString = \case+  Value{contents=OctetString bs} -> pure bs+  Value{contents=Unresolved bytes} -> unresolved Ber.decodeOctetString bytes+  _ -> fail++null :: Value -> Parser ()+null = \case+  Value{contents=Null} -> pure ()+  Value{contents=Unresolved bytes} -> unresolved Ber.decodeNull bytes+  _ -> fail++oid :: Value -> Parser Oid+oid = \case+  Value{contents=ObjectIdentifier objId} -> pure objId+  Value{contents=Unresolved bytes} -> unresolved Ber.decodeObjectId bytes+  _ -> fail++utf8String :: Value -> Parser ShortText+utf8String = \case+  Value{contents=Utf8String str} -> pure str+  Value{contents=Unresolved bytes} -> unresolved Ber.decodeUtf8String bytes+  _ -> fail++printableString :: Value -> Parser ShortText+printableString = \case+  Value{contents=PrintableString str} -> pure str+  Value{contents=Unresolved bytes} -> unresolved Ber.decodePrintableString bytes+  _ -> fail++sequenceOf :: forall a. (Value -> Parser a) -> Value -> Parser (SmallArray a)+sequenceOf k = \case+  Value{tagNumber=16, contents=Constructed vals} -> P $ \p -> runST $ do+    dst <- PM.newSmallArray (PM.sizeofSmallArray vals) undefined+    go vals dst p 0+  _ -> fail+  where+  go :: forall s.+       SmallArray Value+    -> SmallMutableArray s a+    -> Path+    -> Int+    -> ST s (Either Path (SmallArray a))+  go src dst p0 ix+    | ix < PM.sizeofSmallArray src = do+      let val = PM.indexSmallArray src ix+      case unP (k val) (Index ix p0) of+        Left err -> pure $ Left err+        Right rval -> do+          PM.writeSmallArray dst ix rval+          go src dst p0 (ix + 1)+    | otherwise = Right <$> PM.unsafeFreezeSmallArray dst++sequence :: MemberParser a -> Value -> Parser a+sequence k = \case+  Value{contents=Constructed vals} -> P (unMP k vals)+  _ -> fail++index :: Int -> (Value -> Parser a) -> MemberParser a+index ix k = MP $ \vals p ->+  let p' = Index ix p in+  if ix < PM.sizeofSmallArray vals+    then unP (k $ PM.indexSmallArray vals ix) p'+    else Left p'++withTag :: Class -> Word32 -> (Value -> Parser a) -> Value -> Parser a+withTag cls num k v = case v of+  Value{tagClass,tagNumber}+    | tagClass == cls && tagNumber == num ->+      P $ \p -> unP (k v) (Tag cls num p)+  _ -> fail++chooseTag :: [(Class, Word32, Value -> Parser a)] -> Value -> Parser a+chooseTag tab0 v@Value{tagClass,tagNumber} = go tab0+  where+  go [] = fail+  go ((cls, num, k) : rest)+    | cls == tagClass && num == tagNumber+      = P $ \p -> unP (k v) (Tag cls num p)+    | otherwise = go rest++data Path+  = Nil+  | Index {-# UNPACK #-} !Int !Path+  -- ^ into the nth field of a constructed type+  | Tag !Class !Word32 !Path+  -- ^ into a specific tag+  deriving stock (Eq, Show)++longerPath :: Path -> Path -> Path+longerPath a b = if pathSize 0 a < pathSize 0 b then b else a+  where+  pathSize :: Int -> Path -> Int+  pathSize !acc Nil = acc+  pathSize !acc (Index _ rest) = pathSize (1 + acc) rest+  pathSize !acc (Tag _ _ rest) = pathSize (1 + acc) rest++reverse :: Path -> Path+reverse = go Nil+  where+  go !acc Nil = acc+  go !acc (Index ix rest) = go (Index ix acc) rest+  go !acc (Tag cls num rest) = go (Tag cls num acc) rest
+ src/Asn/Resolve/Category.hs view
@@ -0,0 +1,223 @@+{-# language BangPatterns #-}+{-# language DeriveFunctor #-}+{-# language DerivingStrategies #-}+{-# language LambdaCase #-}+{-# language NamedFieldPuns #-}+{-# language RankNTypes #-}+{-# language ScopedTypeVariables #-}+{-# language TupleSections #-}++-- | Transform between Haskell values and the 'Value' type. The instance you+-- write for 'ToAsn' and 'FromAsn' assume a schema. I (Eric) think this is+-- reasonable because I expect each schema to be one-to-one with data types.+module Asn.Resolve.Category+  ( Parser+  , run+  -- * Combinators+  , arr+  , (>->)+  , fail+  , integer+  -- TODO bitString+  , octetString+  , octetStringSingleton+  , null+  , oid+  , utf8String+  , printableString+  , sequenceOf+  , sequence+  , index+  , withTag+  , chooseTag+  -- * Error Breadcrumbs+  , Path(..)+  -- * Re-Exports+  , Value+  , Contents+  , Class(..)+  ) where++import Prelude hiding (fail,null,reverse,null,sequence)++import Asn.Ber (Value(..), Contents(..), Class(..))+import Asn.Oid (Oid)+import Control.Applicative (Alternative(..))+import Control.Monad.ST (ST, runST)+import Data.Bifunctor (bimap,second)+import Data.Bytes (Bytes)+import Data.Int (Int64)+import Data.Primitive (SmallArray,SmallMutableArray)+import Data.Text.Short (ShortText)+import Data.Word (Word32,Word8)++import qualified Data.Primitive as PM+import qualified Asn.Ber as Ber+import qualified Data.Bytes as Bytes+++newtype Parser a b = P { unP :: a -> Path -> Either Path (b, Path) }++instance Functor (Parser a) where+  fmap f (P k) = P $ \v p -> case k v p of+    Right (x, p') -> Right (f x, p')+    Left err -> Left err++instance Applicative (Parser a) where+  pure x = P $ \_ p -> Right (x, p)+  (P g) <*> (P h) = P $ \v p -> case g v p of+    Right (f, _) -> case h v p of+      Right (x, p') -> Right (f x, p')+      Left err -> Left err+    Left err -> Left err++arr :: (a -> Maybe b) -> Parser a b+arr f = P $ \v p -> case f v of+  Just v' -> Right (v', p)+  Nothing -> Left p++(>->) :: Parser a b -> Parser b c -> Parser a c+(P f) >-> (P g) = P $ \v p -> case f v p of+  Right (v', p') -> g v' p'+  Left err -> Left err++-- instance Monad Parser where+--   a >>= k = P $ \p -> unP a p >>= \x -> unP (k x) p++instance Alternative (Parser a) where+  empty = fail+  P f <|> (P g) = P $ \v p -> case f v p of+    Right r -> Right r+    Left err1 -> case g v p of+      Right r -> Right r+      Left err2 -> Left $ longerPath err1 err2++run :: Parser a b -> a -> Either Path b+run r v = bimap reverse fst $ unP r v Nil++fail :: Parser a b+fail = P $ const Left++unresolved :: (Bytes -> Either String a) -> Bytes -> Path -> Either Path (a, Path)+unresolved f bs p = bimap (const p) (,p) (f bs)++integer :: Parser Value Int64+integer = P $ \v p -> case v of+  Value{contents=Integer n} -> Right (n, p)+  Value{contents=Unresolved bytes} -> unresolved Ber.decodeInteger bytes p+  _ -> Left p++octetString :: Parser Value Bytes+octetString = P $ \v p -> case v of+  Value{contents=OctetString bs} -> Right (bs, p)+  Value{contents=Unresolved bytes} -> unresolved Ber.decodeOctetString bytes p+  _ -> Left p++-- | Variant of 'octetString' that expects the @OctetString@ to have+-- exactly one byte. Returns the value of the byte.+octetStringSingleton :: Parser Value Word8+octetStringSingleton = P $ \v p -> case v of+  Value{contents=OctetString bs} -> case Bytes.length bs of+    1 -> Right (Bytes.unsafeIndex bs 0, p)+    _ -> Left p+  Value{contents=Unresolved bytes} -> do+    (bs,p') <- unresolved Ber.decodeOctetString bytes p+    case Bytes.length bs of+      1 -> Right (Bytes.unsafeIndex bs 0, p')+      _ -> Left p'+  _ -> Left p++null :: Parser Value ()+null = P $ \v p -> case v of+  Value{contents=Null} -> Right ((), p)+  Value{contents=Unresolved bytes} -> unresolved Ber.decodeNull bytes p+  _ -> Left p++oid :: Parser Value Oid+oid = P $ \v p -> case v of+  Value{contents=ObjectIdentifier objId} -> Right (objId, p)+  Value{contents=Unresolved bytes} -> unresolved Ber.decodeObjectId bytes p+  _ -> Left p++utf8String :: Parser Value ShortText+utf8String = P $ \v p -> case v of+  Value{contents=Utf8String str} -> Right (str, p)+  Value{contents=Unresolved bytes} -> unresolved Ber.decodeUtf8String bytes p+  _ -> Left p++printableString :: Parser Value ShortText+printableString = P $ \v p -> case v of+  Value{contents=PrintableString str} -> Right (str, p)+  Value{contents=Unresolved bytes} -> unresolved Ber.decodePrintableString bytes p+  _ -> Left p++sequenceOf :: forall a. Parser Value a -> Parser Value (SmallArray a)+sequenceOf k = P $ \v p -> case v of+  Value{tagNumber=16, contents=Constructed vals} -> runST $ do+    dst <- PM.newSmallArray (PM.sizeofSmallArray vals) undefined+    second (,p) <$> go vals dst p 0+  _ -> Left p+  where+  go :: forall s.+       SmallArray Value+    -> SmallMutableArray s a+    -> Path+    -> Int+    -> ST s (Either Path (SmallArray a))+  go src dst p0 ix+    | ix < PM.sizeofSmallArray src = do+      let val = PM.indexSmallArray src ix+      case unP k val (Index ix p0) of+        Left err -> pure $ Left err+        Right (rval, _) -> do+          PM.writeSmallArray dst ix rval+          go src dst p0 (ix + 1)+    | otherwise = Right <$> PM.unsafeFreezeSmallArray dst++sequence :: Parser Value (SmallArray Value)+sequence = P $ \v p -> case v of+  Value{contents=Constructed vals} -> Right (vals, p)+  _ -> Left p++index :: Int -> Parser (SmallArray a) a+index ix = P $ \vals p ->+  let p' = Index ix p in+  if ix < PM.sizeofSmallArray vals+    then Right (PM.indexSmallArray vals ix, p')+    else Left p'++withTag :: Class -> Word32 -> Parser Value Value+withTag cls num = P $ \v p -> case v of+  Value{tagClass,tagNumber}+    | tagClass == cls && tagNumber == num ->+      Right (v, Tag cls num p)+  _ -> Left p++chooseTag :: [(Class, Word32, Parser Value a)] -> Parser Value a+chooseTag tab = foldr (<|>) fail (adapt <$> tab)+  where+  adapt (cls, num, k) = withTag cls num >-> k+++data Path+  = Nil+  | Index {-# UNPACK #-} !Int !Path+  -- ^ into the nth field of a constructed type+  | Tag !Class !Word32 !Path+  -- ^ into a specific tag+  deriving stock (Eq, Show)++longerPath :: Path -> Path -> Path+longerPath a b = if pathSize 0 a < pathSize 0 b then b else a+  where+  pathSize :: Int -> Path -> Int+  pathSize !acc Nil = acc+  pathSize !acc (Index _ rest) = pathSize (1 + acc) rest+  pathSize !acc (Tag _ _ rest) = pathSize (1 + acc) rest++reverse :: Path -> Path+reverse = go Nil+  where+  go !acc Nil = acc+  go !acc (Index ix rest) = go (Index ix acc) rest+  go !acc (Tag cls num rest) = go (Tag cls num acc) rest
+ test/Golden.hs view
@@ -0,0 +1,58 @@+import Asn.Ber (decode)+import Message (resolveMessage)+import Data.ByteString (ByteString)+import Data.ByteString.Base16 (decodeBase16)+import Data.Bytes (Bytes)+import Data.Char (isSpace)+import System.FilePath (takeBaseName, replaceExtension)+import System.IO (withFile,IOMode(WriteMode))+import Test.Tasty (defaultMain, TestTree, testGroup)+import Test.Tasty.Golden (goldenVsFile, findByExtension)+import Text.Pretty.Simple (pHPrint)++import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as BC8+import qualified GHC.Exts as Exts+import qualified Message.Category as Cat++main :: IO ()+main = defaultMain =<< goldenTests++goldenTests :: IO TestTree+goldenTests = goldenTestsSchemaless >> goldenResolveTests++goldenTestsSchemaless :: IO TestTree+goldenTestsSchemaless = do+  files <- findByExtension [".input"] "golden"+  return $ testGroup "ber" $ flip map files $ \inputName -> do+    let actualName = replaceExtension inputName ".actual"+    let expectedName = replaceExtension inputName ".expected"+    goldenVsFile (takeBaseName inputName) expectedName actualName $ do+      b16 <- ByteString.readFile inputName+      case decodeBase16 (BC8.filter (not . isSpace) b16) of+        Left _ -> fail "file contained non-hexadecimal characters"+        Right b -> case decode (bytestringToBytes b) of+          Left err -> fail ("could not decode input: " ++ err)+          Right s -> withFile actualName WriteMode (\h -> pHPrint h s)++goldenResolveTests :: IO TestTree+goldenResolveTests = do+  files <- findByExtension [".input-resolver"] "golden"+  return $ testGroup "resolve" $ flip map files $ \inputName -> do+    let actualName = replaceExtension inputName ".actual"+    let expectedName = replaceExtension inputName ".expected"+    goldenVsFile (takeBaseName inputName) expectedName actualName $ do+      b16 <- ByteString.readFile inputName+      case decodeBase16 (BC8.filter (not . isSpace) b16) of+        Left _ -> fail "file contained non-hexadecimal characters"+        Right b -> case decode (bytestringToBytes b) of+          Left err -> fail ("could not decode input: " ++ err)+          Right s -> case resolveMessage s of+            Left err -> fail ("could not resolve input: " ++ show err)+            Right _ -> case Cat.resolveMessage s of+              Left err -> fail ("could not resolve input (Category-style): " ++ show err)+              Right v -> withFile actualName WriteMode (\h -> pHPrint h v)+++bytestringToBytes :: ByteString -> Bytes+bytestringToBytes = Exts.fromList . ByteString.unpack
+ test/Main.hs view
@@ -0,0 +1,85 @@+{-# language DerivingStrategies #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language ScopedTypeVariables #-}+{-# language StandaloneDeriving #-}++import Asn.Ber (decode)+import Asn.Oid (Oid)+import Data.Bytes (Bytes)++import qualified Asn.Oid as Oid+import qualified Test.Tasty as Tasty+import qualified Test.Tasty.HUnit as HUnit+import qualified Test.Tasty.QuickCheck as QC+import qualified Asn.Ber as Ber+import qualified GHC.Exts as Exts++main :: IO ()+main = Tasty.defaultMain $ Tasty.testGroup "tests"+  [ HUnit.testCase "signed-data" $ case decode exampleSignedData of+      Left e -> fail ("Decoding signed data failed with: " ++ show e)+      Right _ -> pure ()+  , HUnit.testCase "bad-integer-zero" $ case decode badIntegerZero of+      Left _ -> pure ()+      Right _ -> fail ("Decoding bad integer zero succeeded unexpectedly.")+  , HUnit.testCase "good-integer-zero" $ case decode goodIntegerZero of+      Left _ -> fail "Decoding good integer zero failed unexpectedly."+      Right Ber.Value{Ber.contents = Ber.Integer 0} -> pure ()+      Right _ -> fail "Decoding good integer zero gave bad result."+  , QC.testProperty "oid-encode-decode" $ \oid -> case Oid.size oid of+      0 -> True+      _ -> case Oid.fromShortTextDot (Oid.toShortText oid) of+        Nothing -> False+        Just r -> r == oid+  ]++badIntegerZero :: Bytes+badIntegerZero = Exts.fromList [0x02,0x00]++goodIntegerZero :: Bytes+goodIntegerZero = Exts.fromList [0x02,0x01,0x00]++-- Taken from https://www.di-mgt.com.au/docs/examplesPKCS.txt+exampleSignedData :: Bytes+exampleSignedData = Exts.fromList+  [0x30,0x82,0x02,0x50,0x06,0x09,0x2a,0x86,0x48,0x86,0xf7,0x0d,0x01,0x07,0x02,0xa0+  ,0x82,0x02,0x41,0x30,0x82,0x02,0x3d,0x02,0x01,0x01,0x31,0x0e,0x30,0x0c,0x06,0x08+  ,0x2a,0x86,0x48,0x86,0xf7,0x0d,0x02,0x02,0x05,0x00,0x30,0x28,0x06,0x09,0x2a,0x86+  ,0x48,0x86,0xf7,0x0d,0x01,0x07,0x01,0xa0,0x1b,0x04,0x19,0x45,0x76,0x65,0x72,0x79+  ,0x6f,0x6e,0x65,0x20,0x67,0x65,0x74,0x73,0x20,0x46,0x72,0x69,0x64,0x61,0x79,0x20+  ,0x6f,0x66,0x66,0x2e,0xa0,0x82,0x01,0x5e,0x30,0x82,0x01,0x5a,0x30,0x82,0x01,0x04+  ,0x02,0x04,0x14,0x00,0x00,0x29,0x30,0x0d,0x06,0x09,0x2a,0x86,0x48,0x86,0xf7,0x0d+  ,0x01,0x01,0x02,0x05,0x00,0x30,0x2c,0x31,0x0b,0x30,0x09,0x06,0x03,0x55,0x04,0x06+  ,0x13,0x02,0x55,0x53,0x31,0x1d,0x30,0x1b,0x06,0x03,0x55,0x04,0x0a,0x13,0x14,0x45+  ,0x78,0x61,0x6d,0x70,0x6c,0x65,0x20,0x4f,0x72,0x67,0x61,0x6e,0x69,0x7a,0x61,0x74+  ,0x69,0x6f,0x6e,0x30,0x1e,0x17,0x0d,0x39,0x32,0x30,0x39,0x30,0x39,0x32,0x32,0x31+  ,0x38,0x30,0x36,0x5a,0x17,0x0d,0x39,0x34,0x30,0x39,0x30,0x39,0x32,0x32,0x31,0x38+  ,0x30,0x35,0x5a,0x30,0x42,0x31,0x0b,0x30,0x09,0x06,0x03,0x55,0x04,0x06,0x13,0x02+  ,0x55,0x53,0x31,0x1d,0x30,0x1b,0x06,0x03,0x55,0x04,0x0a,0x13,0x14,0x45,0x78,0x61+  ,0x6d,0x70,0x6c,0x65,0x20,0x4f,0x72,0x67,0x61,0x6e,0x69,0x7a,0x61,0x74,0x69,0x6f+  ,0x6e,0x31,0x14,0x30,0x12,0x06,0x03,0x55,0x04,0x03,0x13,0x0b,0x54,0x65,0x73,0x74+  ,0x20,0x55,0x73,0x65,0x72,0x20,0x31,0x30,0x5b,0x30,0x0d,0x06,0x09,0x2a,0x86,0x48+  ,0x86,0xf7,0x0d,0x01,0x01,0x01,0x05,0x00,0x03,0x4a,0x00,0x30,0x47,0x02,0x40,0x0a+  ,0x66,0x79,0x1d,0xc6,0x98,0x81,0x68,0xde,0x7a,0xb7,0x74,0x19,0xbb,0x7f,0xb0,0xc0+  ,0x01,0xc6,0x27,0x10,0x27,0x00,0x75,0x14,0x29,0x42,0xe1,0x9a,0x8d,0x8c,0x51,0xd0+  ,0x53,0xb3,0xe3,0x78,0x2a,0x1d,0xe5,0xdc,0x5a,0xf4,0xeb,0xe9,0x94,0x68,0x17,0x01+  ,0x14,0xa1,0xdf,0xe6,0x7c,0xdc,0x9a,0x9a,0xf5,0x5d,0x65,0x56,0x20,0xbb,0xab,0x02+  ,0x03,0x01,0x00,0x01,0x30,0x0d,0x06,0x09,0x2a,0x86,0x48,0x86,0xf7,0x0d,0x01,0x01+  ,0x02,0x05,0x00,0x03,0x41,0x00,0x45,0x1a,0xa1,0xe1,0xaa,0x77,0x20,0x4a,0x5f,0xcd+  ,0xf5,0x76,0x06,0x9d,0x02,0xf7,0x32,0xc2,0x6f,0x36,0x7b,0x0d,0x57,0x8a,0x6e,0x64+  ,0xf3,0x9a,0x91,0x1f,0x47,0x95,0xdf,0x09,0x94,0x34,0x05,0x11,0xa0,0xd1,0xdf,0x4a+  ,0x20,0xb2,0x6a,0x77,0x4c,0xca,0xef,0x75,0xfc,0x69,0x2e,0x54,0xc2,0xa1,0x93,0x7c+  ,0x07,0x11,0x26,0x9d,0x9b,0x16,0x31,0x81,0x9b,0x30,0x81,0x98,0x02,0x01,0x01,0x30+  ,0x34,0x30,0x2c,0x31,0x0b,0x30,0x09,0x06,0x03,0x55,0x04,0x06,0x13,0x02,0x55,0x53+  ,0x31,0x1d,0x30,0x1b,0x06,0x03,0x55,0x04,0x0a,0x13,0x14,0x45,0x78,0x61,0x6d,0x70+  ,0x6c,0x65,0x20,0x4f,0x72,0x67,0x61,0x6e,0x69,0x7a,0x61,0x74,0x69,0x6f,0x6e,0x02+  ,0x04,0x14,0x00,0x00,0x29,0x30,0x0c,0x06,0x08,0x2a,0x86,0x48,0x86,0xf7,0x0d,0x02+  ,0x02,0x05,0x00,0x30,0x0d,0x06,0x09,0x2a,0x86,0x48,0x86,0xf7,0x0d,0x01,0x01,0x01+  ,0x05,0x00,0x04,0x40,0x05,0xfa,0x6a,0x81,0x2f,0xc7,0xdf,0x8b,0xf4,0xf2,0x54,0x25+  ,0x09,0xe0,0x3e,0x84,0x6e,0x11,0xb9,0xc6,0x20,0xbe,0x20,0x09,0xef,0xb4,0x40,0xef+  ,0xbc,0xc6,0x69,0x21,0x69,0x94,0xac,0x04,0xf3,0x41,0xb5,0x7d,0x05,0x20,0x2d,0x42+  ,0x8f,0xb2,0xa2,0x7b,0x5c,0x77,0xdf,0xd9,0xb1,0x5b,0xfc,0x3d,0x55,0x93,0x53,0x50+  ,0x34,0x10,0xc1,0xe1]++instance QC.Arbitrary Oid where+  arbitrary = Oid.Oid . Exts.fromList <$> QC.arbitrary
+ test/Message.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE NamedFieldPuns #-}++module Message+  ( resolveMessage+  , Message(..)+  ) where++import Prelude hiding (sequence)++import Asn.Oid (Oid)+import Asn.Resolve++import Data.Bytes (Bytes)+import Data.Int (Int64)+import Data.Primitive (SmallArray)++data Message = Message+  { version :: Int64+  , community :: {-# UNPACK #-} !Bytes+  , pdu :: Pdu+  }+  deriving(Show)+data Pdu+  = GetRequest APdu+  | GetNextRequest APdu+  | Response APdu+  | SetRequest APdu+  | InformRequest APdu+  | SnmpV2Trap APdu+  | Report APdu+  deriving(Show)+data APdu = Pdu+  { requestId :: Int64+  , errorStatus :: Int64+  , errorIndex :: Int64+  , varBinds :: SmallArray VarBind+  }+  deriving(Show)+data VarBind = VarBind+  { name :: !Oid+  , result :: !VarBindResult+  }+  deriving(Show)+data VarBindResult+  = Value ObjectSyntax+  | Unspecified+  | NoSuchObject+  | NoSuchInstance+  | EndOfMibView+  deriving(Show)+data ObjectSyntax+  = IntegerValue Int64+  | StringValue Bytes+  | ObjectIdValue Oid+  | IpAddressValue Bytes+  | CounterValue Int64+  | TimeticksValue Int64+  | ArbitraryValue Bytes+  | BigCounterValue Int64+  | UnsignedIntegerValue Int64+  deriving(Show)++resolveMessage :: Value -> Either Path Message+resolveMessage = run . message++message :: Value -> Parser Message+message = sequence $ do+  version <- index 0 integer+  community <- index 1 octetString+  pdu <- index 2 resolvePdu+  pure Message{version,community,pdu}+  where+  resolvePdu = chooseTag+    [ (ContextSpecific, 0, fmap GetRequest . aPdu)+    , (ContextSpecific, 1, fmap GetNextRequest . aPdu)+    -- , (ContextSpecific, 2, fmap GetBulkRequest . bulkPdus) -- TODO+    , (ContextSpecific, 3, fmap Response . aPdu)+    , (ContextSpecific, 4, fmap SetRequest . aPdu)+    , (ContextSpecific, 5, fmap InformRequest . aPdu)+    , (ContextSpecific, 6, fmap SnmpV2Trap . aPdu)+    , (ContextSpecific, 7, fmap Report . aPdu)+    ]+  aPdu :: Value -> Parser APdu+  aPdu = sequence $ do+    requestId <- index 0 integer+    errorStatus <- index 1 integer+    errorIndex <- index 2 integer+    varBinds <- index 3 $ sequenceOf $ sequence $ do+      name <- index 0 oid+      result <- index 1 varBind+      pure VarBind{name,result}+    pure Pdu{requestId,errorStatus,errorIndex,varBinds}+  varBind :: Value -> Parser VarBindResult+  varBind = chooseTag+    [(Application, 1, fmap (Value . CounterValue) . integer)]+    -- TODO
+ test/Message/Category.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE NamedFieldPuns #-}++module Message.Category+  ( resolveMessage+  , Message(..)+  ) where++import Prelude hiding (sequence)++import Asn.Oid (Oid)+import Asn.Resolve.Category++import Data.Bytes (Bytes)+import Data.Int (Int64)+import Data.Primitive (SmallArray)++data Message = Message+  { version :: Int64+  , community :: {-# UNPACK #-} !Bytes+  , pdu :: Pdu+  }+  deriving(Show)+data Pdu+  = GetRequest APdu+  | GetNextRequest APdu+  | Response APdu+  | SetRequest APdu+  | InformRequest APdu+  | SnmpV2Trap APdu+  | Report APdu+  deriving(Show)+data APdu = Pdu+  { requestId :: Int64+  , errorStatus :: Int64+  , errorIndex :: Int64+  , varBinds :: SmallArray VarBind+  }+  deriving(Show)+data VarBind = VarBind+  { name :: !Oid+  , result :: VarBindResult+  }+  deriving(Show)+data VarBindResult+  = Value ObjectSyntax+  | Unspecified+  | NoSuchObject+  | NoSuchInstance+  | EndOfMibView+  deriving(Show)+data ObjectSyntax+  = IntegerValue !Int64+  | StringValue Bytes+  | ObjectIdValue !Oid+  | IpAddressValue Bytes+  | CounterValue Int64+  | TimeticksValue Int64+  | ArbitraryValue Bytes+  | BigCounterValue Int64+  | UnsignedIntegerValue Int64+  deriving(Show)++resolveMessage :: Value -> Either Path Message+resolveMessage = run message++message :: Parser Value Message+message = sequence >-> do+  version <- index 0 >-> integer+  community <- index 1 >-> octetString+  pdu <- index 2 >-> resolvePdu+  pure Message{version,community,pdu}+  where+  resolvePdu = chooseTag+    [ (ContextSpecific, 0, GetRequest <$> aPdu)+    , (ContextSpecific, 1, GetNextRequest <$> aPdu)+    -- , (ContextSpecific, 2, GetBulkRequest <$> bulkPdus) -- TODO+    , (ContextSpecific, 3, Response <$> aPdu)+    , (ContextSpecific, 4, SetRequest <$> aPdu)+    , (ContextSpecific, 5, InformRequest <$> aPdu)+    , (ContextSpecific, 6, SnmpV2Trap <$> aPdu)+    , (ContextSpecific, 7, Report <$> aPdu)+    ]+  aPdu :: Parser Value APdu+  aPdu = sequence >-> do+    requestId <- index 0 >-> integer+    errorStatus <- index 1 >-> integer+    errorIndex <- index 2 >-> integer+    varBinds <- index 3 >-> sequenceOf (sequence >-> varBind)+    pure Pdu{requestId,errorStatus,errorIndex,varBinds}+  varBind :: Parser (SmallArray Value) VarBind+  varBind = do+      name <- index 0 >-> oid+      result <- index 1 >-> varBindResult+      pure VarBind{name,result}+  varBindResult :: Parser Value VarBindResult+  varBindResult = chooseTag+    [(Application, 1, (Value . CounterValue) <$> integer)]+    -- TODO
+ test/Properties.hs view
@@ -0,0 +1,107 @@+{-# language NamedFieldPuns #-}+{-# language TypeApplications #-}++import Asn.Ber (Value(..),Class(..),Contents(..))+import Data.Word (Word32)+import Test.QuickCheck.Arbitrary (Arbitrary(..))+import Test.QuickCheck.Gen (Gen)+import Test.Tasty (TestTree,defaultMain,testGroup)+import Test.Tasty.QuickCheck ((===))+import Test.Tasty.QuickCheck (testProperty)++import qualified Asn.Ber as Ber+import qualified Asn.Oid as Oid+import qualified Asn.Ber.Encode as Ber+import qualified Data.Bytes as Bytes+import qualified Data.Primitive as Prim+import qualified Data.Primitive.SmallArray as SA+import qualified Data.Text.Short as TS+import qualified GHC.Exts as Exts+import qualified Test.QuickCheck.Gen as Gen+++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "encoder-decoder"+  [ testProperty "encoded value is decodable" $ \val ->+    let bs = Ber.encode val+        val' = Ber.decode bs+     in val' === Right val+  ]++instance Arbitrary Value where+  arbitrary = do+    Gen.oneof [aUniversal, anUnresolved] -- TODO+    where+    anUnresolved = do+      tagClass <- Gen.oneof $ pure <$> [Application, ContextSpecific, Private]+      tagNumber <- Gen.oneof $ Gen.chooseBoundedIntegral <$> [(0,30), (31,65535)]+      contents <- Unresolved <$> arbitrary+      pure Value{tagClass,tagNumber,contents}+    aUniversal = do+      let tagClass = Universal+      Gen.oneof+        [ do+            let tagNumber = 0x02+            contents <- Integer <$> arbitrary+            pure Value{tagClass,tagNumber,contents}+        , do+            contents <- OctetString <$> arbitrary+            let tagNumber = 0x04+            pure Value{tagClass,tagNumber,contents}+        , do+            let tagNumber = 0x03+            contents <- BitString <$> Gen.chooseBoundedIntegral (0,7) <*> arbitrary+            pure Value{tagClass,tagNumber,contents}+        , do+            let tagNumber = 0x05+            let contents = Null+            pure Value{tagClass,tagNumber,contents}+        , do+            let tagNumber = 0x06+            a <- Gen.chooseBoundedIntegral (0,2)+            b <- Gen.chooseBoundedIntegral (0,39)+            rest <- arbitrary @[Word32]+            let contents = ObjectIdentifier (Oid.Oid (Exts.fromList (a:b:rest)))+            pure Value{tagClass,tagNumber,contents}+        , do+            let tagNumber = 0x0C+            contents <- Utf8String <$> arbitrary+            pure Value{tagClass,tagNumber,contents}+        , do+            let tagNumber = 0x13+            chars <- Gen.listOf $ Gen.elements $ concat+              [ ['A'..'Z']+              , ['a'..'z']+              , ['0'..'9']+              , " '()+,-./:=?"+              ]+            let contents = PrintableString $ TS.fromString chars+            pure Value{tagClass,tagNumber,contents}+        -- UtcTime -- TODO+        ]+    aConstructed = do+      tagClass <- arbitrary+      tagNumber <- arbitrary+      contents <- Constructed . SA.smallArrayFromList <$> Gen.sized go+      pure Value{tagClass,tagNumber,contents}+      where+      go :: Int -> Gen [Value]+      go 0 = pure []+      go n = Gen.resize (n `div` 10) $ Gen.listOf arbitrary++instance Arbitrary Class where+  arbitrary = Gen.oneof $ pure <$>+    [ Universal+    , Application+    , ContextSpecific+    , Private+    ]++instance Arbitrary Bytes.Bytes where+  arbitrary = Bytes.fromLatinString <$> arbitrary++instance Arbitrary TS.ShortText where+  arbitrary = TS.fromString <$> arbitrary