diff --git a/Data/ASN1/Get.hs b/Data/ASN1/Get.hs --- a/Data/ASN1/Get.hs +++ b/Data/ASN1/Get.hs @@ -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" diff --git a/Data/ASN1/Prim.hs b/Data/ASN1/Prim.hs --- a/Data/ASN1/Prim.hs +++ b/Data/ASN1/Prim.hs @@ -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 diff --git a/asn1-encoding.cabal b/asn1-encoding.cabal --- a/asn1-encoding.cabal +++ b/asn1-encoding.cabal @@ -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 diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -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]