asn1-encoding 0.9.5 → 0.9.6

raw patch · 4 files changed

+124/−12 lines, 4 filesdep −textdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: text

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Data/ASN1/Get.hs +5/−1
• Data/ASN1/Prim.hs +96/−3
• asn1-encoding.cabal +6/−7
• tests/Tests.hs +17/−1

@@ -16,6 +16,7 @@ -- case for asn1 and augmented by a position. -- {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE CPP #-} module Data.ASN1.Get     ( Result(..)     , Input@@ -103,7 +104,10 @@         let ks' s1 b1 m1 p1 a = unGet (g a) s1 b1 m1 p1 kf ks          in unGet m s0 b0 m0 p0 kf ks' -    fail     = failDesc+#if MIN_VERSION_base(4,13,0)+instance MonadFail Get where+#endif+    fail = failDesc  instance MonadPlus Get where     mzero     = failDesc "mzero"

@@ -8,6 +8,7 @@ -- Tools to read ASN1 primitive (e.g. boolean, int) -- +{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} module Data.ASN1.Prim     (@@ -27,6 +28,7 @@     -- * marshall an ASN1 type from a val struct or a bytestring     , getBoolean     , getInteger+    , getDouble     , getBitString     , getOctetString     , getNull@@ -36,6 +38,7 @@     -- * marshall an ASN1 type to a bytestring     , putTime     , putInteger+    , putDouble     , putBitString     , putString     , putOID@@ -49,15 +52,18 @@ import Data.ASN1.Error import Data.ASN1.Serialize import Data.Bits+import Data.Monoid import Data.Word import Data.List (unfoldr) import Data.ByteString (ByteString) import Data.Char (ord, isDigit) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Unsafe as B import Data.Hourglass-import Control.Applicative import Control.Arrow (first)+import Control.Applicative+import Control.Monad  encodeHeader :: Bool -> ASN1Length -> ASN1 -> ASN1Header encodeHeader pc len (Boolean _)                = ASN1Header Universal 0x1 pc len@@ -99,7 +105,7 @@ encodePrimitiveData (OctetString b)     = putString b encodePrimitiveData Null                = B.empty encodePrimitiveData (OID oidv)          = putOID oidv-encodePrimitiveData (Real _)            = B.empty -- not implemented+encodePrimitiveData (Real d)            = putDouble d encodePrimitiveData (Enumerated i)      = putInteger $ fromIntegral i encodePrimitiveData (ASN1String cs)     = getCharacterStringRawData cs encodePrimitiveData (ASN1Time ty ti tz) = putTime ty ti tz@@ -164,7 +170,7 @@ decodePrimitive (ASN1Header Universal 0x6 _ _) p   = getOID p decodePrimitive (ASN1Header Universal 0x7 _ _) _   = Left $ TypeNotImplemented "Object Descriptor" decodePrimitive (ASN1Header Universal 0x8 _ _) _   = Left $ TypeNotImplemented "External"-decodePrimitive (ASN1Header Universal 0x9 _ _) _   = Left $ TypeNotImplemented "real"+decodePrimitive (ASN1Header Universal 0x9 _ _) p   = getDouble p decodePrimitive (ASN1Header Universal 0xa _ _) p   = getEnumerated p decodePrimitive (ASN1Header Universal 0xb _ _) _   = Left $ TypeNotImplemented "EMBEDDED PDV" decodePrimitive (ASN1Header Universal 0xc _ _) p   = getCharacterString UTF8 p@@ -219,6 +225,50 @@             v1 = s `B.index` 0             v2 = s `B.index` 1 +getDouble :: ByteString -> Either ASN1Error ASN1+getDouble s = Real <$> getDoubleRaw s++getDoubleRaw :: ByteString -> Either ASN1Error Double+getDoubleRaw s+  | B.null s  = Right 0+getDoubleRaw s@(B.unsafeHead -> h)+  | h == 0x40 = Right $! (1/0)  -- Infinity+  | h == 0x41 = Right $! (-1/0) -- -Infinity+  | h == 0x42 = Right $! (0/0)  -- NaN+  | otherwise = do+      let len = B.length s+      base <- case (h `testBit` 5, h `testBit` 4) of+                -- extract bits 5,4 for the base+                (False, False) -> return 2+                (False, True)  -> return 8+                (True,  False) -> return 16+                _              -> Left . TypeDecodingFailed $ "real: invalid base detected"+      -- check bit 6 for the sign+      let mkSigned = if h `testBit` 6 then negate else id+      -- extract bits 3,2 for the scaling factor+      let scaleFactor = (h .&. 0x0c) `shiftR` 2+      expLength <- getExponentLength len h s+      -- 1 byte for the header, expLength for the exponent, and at least 1 byte for the mantissa+      unless (len > 1 + fromIntegral expLength) $+        Left . TypeDecodingFailed $ "real: not enough input for exponent and mantissa"+      let (_, exp'') = intOfBytes $ B.unsafeTake (fromIntegral expLength) $ B.unsafeDrop 1 s+      let exp' = case base :: Int of+                   2 -> exp''+                   8 -> 3 * exp''+                   _ -> 4 * exp'' -- must be 16+          exponent = exp' - fromIntegral scaleFactor+          -- whatever is leftover is the mantissa, unsigned+          (_, mantissa) = uintOfBytes $ B.unsafeDrop (1 + fromIntegral expLength) s+      Right $! encodeFloat (mkSigned $ toInteger mantissa) (fromIntegral exponent)++getExponentLength :: Int -> Word8 -> ByteString -> Either ASN1Error Word8+getExponentLength len h s =+  case h .&. 0x03 of+    l | l == 0x03 -> do+          unless (len > 1) $ Left . TypeDecodingFailed $ "real: not enough input to decode exponent length"+          return $ B.unsafeIndex s 1+      | otherwise -> return $ l + 1+ getBitString :: ByteString -> Either ASN1Error ASN1 getBitString s =     let toSkip = B.head s in@@ -362,3 +412,46 @@   where         encode x | x == 0    = B.singleton 0                  | otherwise = putVarEncodingIntegral x++putDouble :: Double -> ByteString+putDouble d+  | d == 0 = B.pack []+  | d == (1/0) = B.pack [0x40]+  | d == negate (1/0) = B.pack [0x41]+  | isNaN d = B.pack [0x42]+  | otherwise = B.cons (header .|. (expLen - 1)) -- encode length of exponent+                (expBS <> manBS)+  where+  (mkUnsigned, header)+    | d < 0     = (negate, bINARY_NEGATIVE_NUMBER_ID)+    | otherwise = (id, bINARY_POSITIVE_NUMBER_ID)+  (man, exp) = decodeFloat d+  (mantissa, exponent) = normalize (fromIntegral $ mkUnsigned man, exp)+  expBS = putInteger (fromIntegral exponent)+  expLen = fromIntegral (B.length expBS)+  manBS = putInteger (fromIntegral mantissa)++-- | Normalize the mantissa and adjust the exponent.+--+-- DER requires the mantissa to either be 0 or odd, so we right-shift it+-- until the LSB is 1, and then add the shift amount to the exponent.+--+-- TODO: handle denormal numbers+normalize :: (Word64, Int) -> (Word64, Int)+normalize (mantissa, exponent) = (mantissa `shiftR` sh, exponent + sh)+  where+    sh = countTrailingZeros mantissa++#if !(MIN_VERSION_base(4,8,0))+    countTrailingZeros :: FiniteBits b => b -> Int+    countTrailingZeros x = go 0+      where+        go i | i >= w      = i+             | testBit x i = i+             | otherwise   = go (i+1)+        w = finiteBitSize x+#endif++bINARY_POSITIVE_NUMBER_ID, bINARY_NEGATIVE_NUMBER_ID :: Word8+bINARY_POSITIVE_NUMBER_ID = 0x80+bINARY_NEGATIVE_NUMBER_ID = 0xc0

@@ -1,5 +1,5 @@ Name:                asn1-encoding-Version:             0.9.5+Version:             0.9.6 Synopsis:            ASN1 data reader and writer in RAW, BER and DER forms Description:     ASN1 data reader and writer in raw form with supports for high level forms of ASN1 (BER, and DER).@@ -12,7 +12,7 @@ stability:           experimental Build-Type:          Simple Cabal-Version:       >=1.10-Homepage:            http://github.com/vincenthz/hs-asn1+Homepage:            https://github.com/vincenthz/hs-asn1  Library   Exposed-modules:   Data.ASN1.Error@@ -21,8 +21,8 @@                      Data.ASN1.Encoding                      Data.ASN1.Stream                      Data.ASN1.Object-  other-modules:     Data.ASN1.Prim-                     Data.ASN1.BinaryEncoding.Parse+                     Data.ASN1.Prim+  other-modules:     Data.ASN1.BinaryEncoding.Parse                      Data.ASN1.BinaryEncoding.Writer                      Data.ASN1.Internal                      Data.ASN1.Serialize@@ -40,7 +40,6 @@   Main-Is:           Tests.hs   Build-depends:     base >= 3 && < 7                    , bytestring-                   , text                    , mtl                    , tasty                    , tasty-quickcheck@@ -52,5 +51,5 @@  source-repository head   type:     git-  location: git://github.com/vincenthz/hs-asn1-  subdir:   asn1-encoding+  location: https://github.com/vincenthz/hs-asn1+  subdir:   encoding

@@ -160,7 +160,7 @@                 , liftM OctetString arbitrary                 , return Null                 , liftM OID arbitraryOID-                --, Real Double+                , liftM Real arbitrary                 -- , return Enumerated                 , ASN1String <$> arbitrary                 , ASN1Time <$> arbitrary <*> arbitrary <*> arbitrary@@ -192,15 +192,31 @@ prop_event_marshalling_id :: ASN1Events -> Bool prop_event_marshalling_id (ASN1Events e) = (parseLBS $ toLazyByteString e) == Right e +prop_asn1_der_marshalling_id :: [ASN1] -> Bool prop_asn1_der_marshalling_id v = (decodeASN1 DER . encodeASN1 DER) v `assertEq` Right v     where assertEq got expected                  | got /= expected = error ("got: " ++ show got ++ " expected: " ++ show expected)                  | otherwise       = True +prop_real_der_marshalling_id :: Double -> Bool+prop_real_der_marshalling_id v = (decodeASN1 DER . encodeASN1 DER) [Real v] `assertEq` Right [Real v]+    where assertEq got expected+                 | got /= expected = error ("got: " ++ show got ++ " expected: " ++ show expected)+                 | otherwise       = True++prop_integral_real_der_marshalling_id :: Integer -> Bool+prop_integral_real_der_marshalling_id v = (decodeASN1 DER . encodeASN1 DER) [Real (fromInteger v)]+                                          `assertEq` Right [Real (fromInteger v)]+    where assertEq got expected+                 | got /= expected = error ("got: " ++ show got ++ " expected: " ++ show expected)+                 | otherwise       = True+ marshallingTests = testGroup "Marshalling"     [ testProperty "Header" prop_header_marshalling_id     , testProperty "Event"  prop_event_marshalling_id     , testProperty "DER"    prop_asn1_der_marshalling_id+    , testProperty "Real"   prop_real_der_marshalling_id+    , testProperty "Integral Real"   prop_integral_real_der_marshalling_id     ]  main = defaultMain $ testGroup "asn1-encoding" [marshallingTests]