diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,15 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## 0.9.7 + +* Move library modules to directory `src`. +* Drop support for GHC < 8.8. +* Use `LANAGUAGE RankNTypes`, rather than `LANGUAGE Rank2Types`. +* Use the `other-extensions` field in the Cabal file. +* Module `Data.ASN1.Stream` spun out to dependency package + `crypton-asn1-types-0.3.6`. + ## 0.9.6 * Rename `asn1-encoding-0.9.6` package as `crypton-asn1-encoding-0.9.6`. diff --git a/Data/ASN1/BinaryEncoding.hs b/Data/ASN1/BinaryEncoding.hs deleted file mode 100644 --- a/Data/ASN1/BinaryEncoding.hs +++ /dev/null @@ -1,99 +0,0 @@ --- | --- Module : Data.ASN1.BinaryEncoding --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- A module containing ASN1 BER and DER specification encoding/decoding. --- -{-# LANGUAGE EmptyDataDecls #-} -module Data.ASN1.BinaryEncoding - ( BER(..) - , DER(..) - ) where - -import Data.ASN1.Stream -import Data.ASN1.Types -import Data.ASN1.Types.Lowlevel -import Data.ASN1.Error -import Data.ASN1.Encoding -import Data.ASN1.BinaryEncoding.Parse -import Data.ASN1.BinaryEncoding.Writer -import Data.ASN1.Prim -import qualified Control.Exception as E - --- | Basic Encoding Rules (BER) -data BER = BER - --- | Distinguished Encoding Rules (DER) -data DER = DER - -instance ASN1DecodingRepr BER where - decodeASN1Repr _ lbs = decodeEventASN1Repr (const Nothing) `fmap` parseLBS lbs - -instance ASN1Decoding BER where - decodeASN1 _ lbs = (map fst . decodeEventASN1Repr (const Nothing)) `fmap` parseLBS lbs - -instance ASN1DecodingRepr DER where - decodeASN1Repr _ lbs = decodeEventASN1Repr checkDER `fmap` parseLBS lbs - -instance ASN1Decoding DER where - decodeASN1 _ lbs = (map fst . decodeEventASN1Repr checkDER) `fmap` parseLBS lbs - -instance ASN1Encoding DER where - encodeASN1 _ l = toLazyByteString $ encodeToRaw l - -decodeConstruction :: ASN1Header -> ASN1ConstructionType -decodeConstruction (ASN1Header Universal 0x10 _ _) = Sequence -decodeConstruction (ASN1Header Universal 0x11 _ _) = Set -decodeConstruction (ASN1Header c t _ _) = Container c t - -decodeEventASN1Repr :: (ASN1Header -> Maybe ASN1Error) -> [ASN1Event] -> [ASN1Repr] -decodeEventASN1Repr checkHeader l = loop [] l - where loop _ [] = [] - loop acc (h@(Header hdr@(ASN1Header _ _ True _)):ConstructionBegin:xs) = - let ctype = decodeConstruction hdr in - case checkHeader hdr of - Nothing -> (Start ctype,[h,ConstructionBegin]) : loop (ctype:acc) xs - Just err -> E.throw err - loop acc (h@(Header hdr@(ASN1Header _ _ False _)):p@(Primitive prim):xs) = - case checkHeader hdr of - Nothing -> case decodePrimitive hdr prim of - Left err -> E.throw err - Right obj -> (obj, [h,p]) : loop acc xs - Just err -> E.throw err - loop (ctype:acc) (ConstructionEnd:xs) = (End ctype, [ConstructionEnd]) : loop acc xs - loop _ (x:_) = E.throw $ StreamUnexpectedSituation (show x) - --- | DER header need to be all of finite size and of minimum possible size. -checkDER :: ASN1Header -> Maybe ASN1Error -checkDER (ASN1Header _ _ _ len) = checkLength len - where checkLength :: ASN1Length -> Maybe ASN1Error - checkLength LenIndefinite = Just $ PolicyFailed "DER" "indefinite length not allowed" - checkLength (LenShort _) = Nothing - checkLength (LenLong n i) - | n == 1 && i < 0x80 = Just $ PolicyFailed "DER" "long length should be a short length" - | n == 1 && i >= 0x80 = Nothing - | otherwise = if i >= 2^((n-1)*8) && i < 2^(n*8) - then Nothing - else Just $ PolicyFailed "DER" "long length is not shortest" - -encodeToRaw :: [ASN1] -> [ASN1Event] -encodeToRaw = concatMap writeTree . mkTree - where writeTree (p@(Start _),children) = snd $ encodeConstructed p children - writeTree (p,_) = snd $ encodePrimitive p - - mkTree [] = [] - mkTree (x@(Start _):xs) = - let (tree, r) = spanEnd 0 xs - in (x,tree):mkTree r - mkTree (p:xs) = (p,[]) : mkTree xs - - spanEnd :: Int -> [ASN1] -> ([ASN1], [ASN1]) - spanEnd _ [] = ([], []) - spanEnd 0 (x@(End _):xs) = ([x], xs) - spanEnd lvl (x:xs) = case x of - Start _ -> let (ys, zs) = spanEnd (lvl+1) xs in (x:ys, zs) - End _ -> let (ys, zs) = spanEnd (lvl-1) xs in (x:ys, zs) - _ -> let (ys, zs) = spanEnd lvl xs in (x:ys, zs) diff --git a/Data/ASN1/BinaryEncoding/Parse.hs b/Data/ASN1/BinaryEncoding/Parse.hs deleted file mode 100644 --- a/Data/ASN1/BinaryEncoding/Parse.hs +++ /dev/null @@ -1,163 +0,0 @@ --- | --- Module : Data.ASN1.BinaryEncoding.Parse --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- Generic parsing facility for ASN1. --- -module Data.ASN1.BinaryEncoding.Parse - ( - -- * incremental parsing interfaces - runParseState - , isParseDone - , newParseState - , ParseState - , ParseCursor - -- * simple parsing interfaces - , parseLBS - , parseBS - ) where - -import Control.Arrow (first) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.ASN1.Error -import Data.ASN1.Types -import Data.ASN1.Types.Lowlevel -import Data.ASN1.Get -import Data.ASN1.Serialize -import Data.Word -import Data.Maybe (fromJust) - --- | nothing means the parser stop this construction on --- an ASN1 end tag, otherwise specify the position --- where the construction terminate. -type ConstructionEndAt = Maybe Word64 - -data ParseExpect = ExpectHeader (Maybe (B.ByteString -> Result ASN1Header)) - | ExpectPrimitive Word64 (Maybe (B.ByteString -> Result ByteString)) - -type ParsePosition = Word64 - --- | represent the parsing state of an ASN1 stream. --- --- * the stack of constructed elements. --- * the next expected type. --- * the position in the stream. --- -data ParseState = ParseState [ConstructionEndAt] ParseExpect ParsePosition - --- | create a new empty parse state. position is 0 -newParseState :: ParseState -newParseState = ParseState [] (ExpectHeader Nothing) 0 - -isEOC :: ASN1Header -> Bool -isEOC (ASN1Header cl t _ _) = cl == Universal && t == 0 - -asn1LengthToConst :: ASN1Length -> Maybe Word64 -asn1LengthToConst (LenShort n) = Just $ fromIntegral n -asn1LengthToConst (LenLong _ n) = Just $ fromIntegral n -asn1LengthToConst LenIndefinite = Nothing - --- in the future, drop this for the `mplus` with Either. -mplusEither :: Either b a -> (a -> Either b c) -> Either b c -mplusEither (Left e) _ = Left e -mplusEither (Right e) f = f e - --- | Represent the events and state thus far. -type ParseCursor = ([ASN1Event], ParseState) - --- | run incrementally the ASN1 parser on a bytestring. --- the result can be either an error, or on success a list --- of events, and the new parsing state. -runParseState :: ParseState -- ^ parser state - -> ByteString -- ^ input data as bytes - -> Either ASN1Error ParseCursor -runParseState = loop - where - loop iniState bs - | B.null bs = terminateAugment (([], iniState), bs) `mplusEither` (Right . fst) - | otherwise = go iniState bs `mplusEither` terminateAugment - `mplusEither` \((evs, newState), nbs) -> loop newState nbs - `mplusEither` (Right . first (evs ++)) - - terminateAugment ret@((evs, ParseState stackEnd pe pos), r) = - case stackEnd of - Just endPos:xs - | pos > endPos -> Left StreamConstructionWrongSize - | pos == endPos -> terminateAugment ((evs ++ [ConstructionEnd], ParseState xs pe pos), r) - | otherwise -> Right ret - _ -> Right ret - - -- go get one element (either a primitive or a header) from the bytes - -- and returns the new cursor and the remaining byte. - go :: ParseState -> ByteString -> Either ASN1Error (ParseCursor, ByteString) - go (ParseState stackEnd (ExpectHeader cont) pos) bs = - case runGetHeader cont pos bs of - Fail s -> Left $ ParsingHeaderFail s - Partial f -> Right (([], ParseState stackEnd (ExpectHeader $ Just f) pos), B.empty) - Done hdr nPos remBytes - | isEOC hdr -> case stackEnd of - [] -> Right (([], ParseState [] (ExpectHeader Nothing) nPos), remBytes) - Just _:_ -> Left StreamUnexpectedEOC - Nothing:newStackEnd -> Right ( ( [ConstructionEnd] - , ParseState newStackEnd (ExpectHeader Nothing) nPos) - , remBytes) - | otherwise -> case hdr of - (ASN1Header _ _ True len) -> - let nEnd = (nPos +) `fmap` asn1LengthToConst len - in Right ( ( [Header hdr,ConstructionBegin] - , ParseState (nEnd:stackEnd) (ExpectHeader Nothing) nPos) - , remBytes) - (ASN1Header _ _ False LenIndefinite) -> Left StreamInfinitePrimitive - (ASN1Header _ _ False len) -> - let pLength = fromJust $ asn1LengthToConst len - in if pLength == 0 - then Right ( ( [Header hdr,Primitive B.empty] - , ParseState stackEnd (ExpectHeader Nothing) nPos) - , remBytes) - else Right ( ( [Header hdr] - , ParseState stackEnd (ExpectPrimitive pLength Nothing) nPos) - , remBytes) - go (ParseState stackEnd (ExpectPrimitive len cont) pos) bs = - case runGetPrimitive cont len pos bs of - Fail _ -> Left ParsingPartial - Partial f -> Right (([], ParseState stackEnd (ExpectPrimitive len $ Just f) pos), B.empty) - Done p nPos remBytes -> Right (([Primitive p], ParseState stackEnd (ExpectHeader Nothing) nPos), remBytes) - - runGetHeader Nothing = \pos -> runGetPos pos getHeader - runGetHeader (Just f) = const f - - runGetPrimitive Nothing n = \pos -> runGetPos pos (getBytes $ fromIntegral n) - runGetPrimitive (Just f) _ = const f - --- | when no more input is available, it's important to check that the parser is --- in a finish state too. -isParseDone :: ParseState -> Bool -isParseDone (ParseState [] (ExpectHeader Nothing) _) = True -isParseDone _ = False - --- | Parse one lazy bytestring and returns on success all ASN1 events associated. -parseLBS :: L.ByteString -> Either ASN1Error [ASN1Event] -parseLBS lbs = foldrEither process ([], newParseState) (L.toChunks lbs) `mplusEither` onSuccess - where - onSuccess (allEvs, finalState) - | isParseDone finalState = Right $ concat $ reverse allEvs - | otherwise = Left ParsingPartial - - process :: ([[ASN1Event]], ParseState) -> ByteString -> Either ASN1Error ([[ASN1Event]], ParseState) - process (pevs, cState) bs = runParseState cState bs `mplusEither` \(es, cState') -> Right (es : pevs, cState') - - foldrEither :: (a -> ByteString -> Either ASN1Error a) -> a -> [ByteString] -> Either ASN1Error a - foldrEither _ acc [] = Right acc - foldrEither f acc (x:xs) = f acc x `mplusEither` \nacc -> foldrEither f nacc xs - --- | Parse one strict bytestring and returns on success all ASN1 events associated. -parseBS :: ByteString -> Either ASN1Error [ASN1Event] -parseBS bs = runParseState newParseState bs `mplusEither` onSuccess - where onSuccess (evs, pstate) - | isParseDone pstate = Right evs - | otherwise = Left ParsingPartial diff --git a/Data/ASN1/BinaryEncoding/Raw.hs b/Data/ASN1/BinaryEncoding/Raw.hs deleted file mode 100644 --- a/Data/ASN1/BinaryEncoding/Raw.hs +++ /dev/null @@ -1,32 +0,0 @@ --- | --- Module : Data.ASN1.BinaryEncoding.Raw --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- Raw encoding of binary format (BER/DER/CER) --- -module Data.ASN1.BinaryEncoding.Raw - ( - -- * types - ASN1Header(..) - , ASN1Class(..) - , ASN1Tag - , ASN1Length(..) - , ASN1Event(..) - - -- * parser - , parseLBS - , parseBS - - -- * writer - , toLazyByteString - , toByteString - - ) where - -import Data.ASN1.BinaryEncoding.Parse -import Data.ASN1.BinaryEncoding.Writer -import Data.ASN1.Types -import Data.ASN1.Types.Lowlevel diff --git a/Data/ASN1/BinaryEncoding/Writer.hs b/Data/ASN1/BinaryEncoding/Writer.hs deleted file mode 100644 --- a/Data/ASN1/BinaryEncoding/Writer.hs +++ /dev/null @@ -1,39 +0,0 @@ --- | --- Module : Data.ASN1.BinaryEncoding.Writer --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- Serialize events for streaming. --- -module Data.ASN1.BinaryEncoding.Writer - ( toByteString - , toLazyByteString - ) where - -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.ASN1.Types.Lowlevel -import Data.ASN1.Serialize - --- | transform a list of ASN1 Events into a strict bytestring -toByteString :: [ASN1Event] -> ByteString -toByteString = B.concat . L.toChunks . toLazyByteString - --- | transform a list of ASN1 Events into a lazy bytestring -toLazyByteString :: [ASN1Event] -> L.ByteString -toLazyByteString evs = L.fromChunks $ loop [] evs - where loop _ [] = [] - loop acc (x@(Header (ASN1Header _ _ pc len)):xs) = toBs x : loop (if pc then (len == LenIndefinite):acc else acc) xs - loop acc (ConstructionEnd:xs) = case acc of - [] -> error "malformed stream: end before construction" - (True:r) -> toBs ConstructionEnd : loop r xs - (False:r) -> loop r xs - loop acc (x:xs) = toBs x : loop acc xs - - toBs (Header hdr) = putHeader hdr - toBs (Primitive bs) = bs - toBs ConstructionBegin = B.empty - toBs ConstructionEnd = B.empty diff --git a/Data/ASN1/Encoding.hs b/Data/ASN1/Encoding.hs deleted file mode 100644 --- a/Data/ASN1/Encoding.hs +++ /dev/null @@ -1,51 +0,0 @@ --- | --- Module : Data.ASN1.Encoding --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Data.ASN1.Encoding - ( - -- * generic class for decoding and encoding stream - ASN1Decoding(..) - , ASN1DecodingRepr(..) - , ASN1Encoding(..) - -- * strict bytestring version - , decodeASN1' - , decodeASN1Repr' - , encodeASN1' - ) where - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.ASN1.Stream -import Data.ASN1.Types -import Data.ASN1.Error - --- | Describe an ASN1 decoding, that transform a bytestream into an asn1stream -class ASN1Decoding a where - -- | decode a lazy bytestring into an ASN1 stream - decodeASN1 :: a -> L.ByteString -> Either ASN1Error [ASN1] - --- | transition class. -class ASN1DecodingRepr a where - -- | decode a lazy bytestring into an ASN1 stream - decodeASN1Repr :: a -> L.ByteString -> Either ASN1Error [ASN1Repr] - --- | Describe an ASN1 encoding, that transform an asn1stream into a bytestream -class ASN1Encoding a where - -- | encode a stream into a lazy bytestring - encodeASN1 :: a -> [ASN1] -> L.ByteString - --- | decode a strict bytestring into an ASN1 stream -decodeASN1' :: ASN1Decoding a => a -> B.ByteString -> Either ASN1Error [ASN1] -decodeASN1' encoding bs = decodeASN1 encoding $ L.fromChunks [bs] - --- | decode a strict bytestring into an ASN1Repr stream -decodeASN1Repr' :: ASN1DecodingRepr a => a -> B.ByteString -> Either ASN1Error [ASN1Repr] -decodeASN1Repr' encoding bs = decodeASN1Repr encoding $ L.fromChunks [bs] - --- | encode a stream into a strict bytestring -encodeASN1' :: ASN1Encoding a => a -> [ASN1] -> B.ByteString -encodeASN1' encoding = B.concat . L.toChunks . encodeASN1 encoding diff --git a/Data/ASN1/Error.hs b/Data/ASN1/Error.hs deleted file mode 100644 --- a/Data/ASN1/Error.hs +++ /dev/null @@ -1,32 +0,0 @@ --- | --- Module : Data.ASN1.Error --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE BangPatterns #-} -module Data.ASN1.Error - ( - -- * Errors types - ASN1Error(..) - ) where - -import Control.Exception (Exception) -import Data.Typeable - --- | Possible errors during parsing operations -data ASN1Error = StreamUnexpectedEOC -- ^ Unexpected EOC in the stream. - | StreamInfinitePrimitive -- ^ Invalid primitive with infinite length in a stream. - | StreamConstructionWrongSize -- ^ A construction goes over the size specified in the header. - | StreamUnexpectedSituation String -- ^ An unexpected situation has come up parsing an ASN1 event stream. - | ParsingHeaderFail String -- ^ Parsing an invalid header. - | ParsingPartial -- ^ Parsing is not finished, there is construction unended. - | TypeNotImplemented String -- ^ Decoding of a type that is not implemented. Contribution welcome. - | TypeDecodingFailed String -- ^ Decoding of a knowed type failed. - | TypePrimitiveInvalid String -- ^ Invalid primitive type - | PolicyFailed String String -- ^ Policy failed including the name of the policy and the reason. - deriving (Typeable, Show, Eq) - -instance Exception ASN1Error diff --git a/Data/ASN1/Get.hs b/Data/ASN1/Get.hs deleted file mode 100644 --- a/Data/ASN1/Get.hs +++ /dev/null @@ -1,204 +0,0 @@ --- | --- Module : Data.ASN1.Get --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- Simple get module with really simple accessor for ASN1. --- --- Original code is pulled from the Get module from cereal --- which is covered by: --- Copyright : Lennart Kolmodin, Galois Inc. 2009 --- License : BSD3-style (see LICENSE) --- --- The original code has been tailored and reduced to only cover the useful --- case for asn1 and augmented by a position. --- -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE CPP #-} -module Data.ASN1.Get - ( Result(..) - , Input - , Get - , runGetPos - , runGet - , getBytes - , getBytesCopy - , getWord8 - ) where - -import Control.Applicative (Applicative(..),Alternative(..)) -import Control.Monad (ap,MonadPlus(..)) -import Data.Maybe (fromMaybe) -import Foreign - -import qualified Data.ByteString as B - --- | The result of a parse. -data Result r = Fail String - -- ^ The parse failed. The 'String' is the - -- message describing the error, if any. - | Partial (B.ByteString -> Result r) - -- ^ Supply this continuation with more input so that - -- the parser can resume. To indicate that no more - -- input is available, use an 'B.empty' string. - | Done r Position B.ByteString - -- ^ The parse succeeded. The 'B.ByteString' is the - -- input that had not yet been consumed (if any) when - -- the parse succeeded. - -instance Show r => Show (Result r) where - show (Fail msg) = "Fail " ++ show msg - show (Partial _) = "Partial _" - show (Done r pos bs) = "Done " ++ show r ++ " " ++ show pos ++ " " ++ show bs - -instance Functor Result where - fmap _ (Fail msg) = Fail msg - fmap f (Partial k) = Partial (fmap f . k) - fmap f (Done r p bs) = Done (f r) p bs - -type Input = B.ByteString -type Buffer = Maybe B.ByteString - -type Failure r = Input -> Buffer -> More -> Position -> String -> Result r -type Success a r = Input -> Buffer -> More -> Position -> a -> Result r -type Position = Word64 - --- | Have we read all available input? -data More = Complete - | Incomplete (Maybe Int) - deriving (Eq) - --- | The Get monad is an Exception and State monad. -newtype Get a = Get - { unGet :: forall r. Input -> Buffer -> More -> Position -> Failure r -> Success a r -> Result r } - -append :: Buffer -> Buffer -> Buffer -append l r = B.append `fmap` l <*> r -{-# INLINE append #-} - -bufferBytes :: Buffer -> B.ByteString -bufferBytes = fromMaybe B.empty -{-# INLINE bufferBytes #-} - -instance Functor Get where - fmap p m = - Get $ \s0 b0 m0 p0 kf ks -> - let ks' s1 b1 m1 p1 a = ks s1 b1 m1 p1 (p a) - in unGet m s0 b0 m0 p0 kf ks' - -instance Applicative Get where - pure = return - (<*>) = ap - -instance Alternative Get where - empty = failDesc "empty" - (<|>) = mplus - --- Definition directly from Control.Monad.State.Strict -instance Monad Get where - return a = Get $ \ s0 b0 m0 p0 _ ks -> ks s0 b0 m0 p0 a - - m >>= g = Get $ \s0 b0 m0 p0 kf ks -> - 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' - -#if MIN_VERSION_base(4,13,0) -instance MonadFail Get where -#endif - fail = failDesc - -instance MonadPlus Get where - mzero = failDesc "mzero" - mplus a b = - Get $ \s0 b0 m0 p0 kf ks -> - let kf' _ b1 m1 p1 _ = unGet b (s0 `B.append` bufferBytes b1) - (b0 `append` b1) m1 p1 kf ks - in unGet a s0 (Just B.empty) m0 p0 kf' ks - ------------------------------------------------------------------------- - -put :: Position -> B.ByteString -> Get () -put pos s = Get (\_ b0 m p0 _ k -> k s b0 m (p0+pos) ()) -{-# INLINE put #-} - -finalK :: B.ByteString -> t -> t1 -> Position -> r -> Result r -finalK s _ _ p a = Done a p s - -failK :: Failure a -failK _ _ _ p s = Fail (show p ++ ":" ++ s) - --- | Run the Get monad applies a 'get'-based parser on the input ByteString -runGetPos :: Position -> Get a -> B.ByteString -> Result a -runGetPos pos m str = unGet m str Nothing (Incomplete Nothing) pos failK finalK -{-# INLINE runGetPos #-} - -runGet :: Get a -> B.ByteString -> Result a -runGet = runGetPos 0 -{-# INLINE runGet #-} - --- | If at least @n@ bytes of input are available, return the current --- input, otherwise fail. -ensure :: Int -> Get B.ByteString -ensure n = n `seq` Get $ \ s0 b0 m0 p0 kf ks -> - if B.length s0 >= n - then ks s0 b0 m0 p0 s0 - else unGet (demandInput >> ensureRec n) s0 b0 m0 p0 kf ks -{-# INLINE ensure #-} - --- | If at least @n@ bytes of input are available, return the current --- input, otherwise fail. -ensureRec :: Int -> Get B.ByteString -ensureRec n = Get $ \s0 b0 m0 p0 kf ks -> - if B.length s0 >= n - then ks s0 b0 m0 p0 s0 - else unGet (demandInput >> ensureRec n) s0 b0 m0 p0 kf ks - --- | Immediately demand more input via a 'Partial' continuation --- result. -demandInput :: Get () -demandInput = Get $ \s0 b0 m0 p0 kf ks -> - case m0 of - Complete -> kf s0 b0 m0 p0 "too few bytes" - Incomplete mb -> Partial $ \s -> - if B.null s - then kf s0 b0 m0 p0 "too few bytes" - else let update l = l - B.length s - s1 = s0 `B.append` s - b1 = b0 `append` Just s - in ks s1 b1 (Incomplete (update `fmap` mb)) p0 () - -failDesc :: String -> Get a -failDesc err = Get (\s0 b0 m0 p0 kf _ -> kf s0 b0 m0 p0 ("Failed reading: " ++ err)) - ------------------------------------------------------------------------- --- Utility with ByteStrings - --- | An efficient 'get' method for strict ByteStrings. Fails if fewer --- than @n@ bytes are left in the input. This function creates a fresh --- copy of the underlying bytes. -getBytesCopy :: Int -> Get B.ByteString -getBytesCopy n = do - bs <- getBytes n - return $! B.copy bs - ------------------------------------------------------------------------- --- Helpers - --- | Pull @n@ bytes from the input, as a strict ByteString. -getBytes :: Int -> Get B.ByteString -getBytes n - | n <= 0 = return B.empty - | otherwise = do - s <- ensure n - let (b1, b2) = B.splitAt n s - put (fromIntegral n) b2 - return b1 - -getWord8 :: Get Word8 -getWord8 = do - s <- ensure 1 - case B.uncons s of - Nothing -> error "getWord8: ensure internal error" - Just (h,b2) -> put 1 b2 >> return h diff --git a/Data/ASN1/Internal.hs b/Data/ASN1/Internal.hs deleted file mode 100644 --- a/Data/ASN1/Internal.hs +++ /dev/null @@ -1,70 +0,0 @@ --- | --- Module : Data.ASN1.Internal --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Data.ASN1.Internal - ( uintOfBytes - , intOfBytes - , bytesOfUInt - , bytesOfInt - , putVarEncodingIntegral - ) where - -import Data.Word -import Data.Bits -import Data.ByteString (ByteString) -import qualified Data.ByteString as B - -{- | uintOfBytes returns the number of bytes and the unsigned integer represented by the bytes -} -uintOfBytes :: ByteString -> (Int, Integer) -uintOfBytes b = (B.length b, B.foldl (\acc n -> (acc `shiftL` 8) + fromIntegral n) 0 b) - ---bytesOfUInt i = B.unfoldr (\x -> if x == 0 then Nothing else Just (fromIntegral (x .&. 0xff), x `shiftR` 8)) i -bytesOfUInt :: Integer -> [Word8] -bytesOfUInt x = reverse (list x) - where list i = if i <= 0xff then [fromIntegral i] else (fromIntegral i .&. 0xff) : list (i `shiftR` 8) - -{- | intOfBytes returns the number of bytes in the list and - the represented integer by a two's completement list of bytes -} -intOfBytes :: ByteString -> (Int, Integer) -intOfBytes b - | B.length b == 0 = (0, 0) - | otherwise = (len, if isNeg then -(maxIntLen - v + 1) else v) - where - (len, v) = uintOfBytes b - maxIntLen = 2 ^ (8 * len) - 1 - isNeg = testBit (B.head b) 7 - -{- | bytesOfInt convert an integer into a two's completemented list of bytes -} -bytesOfInt :: Integer -> [Word8] -bytesOfInt i - | i > 0 = if testBit (head uints) 7 then 0 : uints else uints - | i == 0 = [0] - | otherwise = if testBit (head nints) 7 then nints else 0xff : nints - where - uints = bytesOfUInt (abs i) - nints = reverse $ plusOne $ reverse $ map complement $ uints - plusOne [] = [1] - plusOne (x:xs) = if x == 0xff then 0 : plusOne xs else (x+1) : xs - -{- ASN1 often uses a particular kind of 7-bit encoding of integers like - in the case of long tags or encoding of integer component of OID's. - Use this function for such an encoding. Assumes a positive integer. - - Here is the description of the algorithm of the above encoding: - - 1. The integer is chunked up into 7-bit groups. Each of these 7bit - chunks are encoded as a single octet. - - 2. All the octets except the last one has its 8th bit set. --} -putVarEncodingIntegral :: (Bits i, Integral i) => i -> ByteString -putVarEncodingIntegral i = B.reverse $ B.unfoldr genOctets (i,True) - where genOctets (x,first) - | x > 0 = - let out = fromIntegral (x .&. 0x7F) .|. (if first then 0 else 0x80) in - Just (out, (shiftR x 7, False)) - | otherwise = Nothing diff --git a/Data/ASN1/Object.hs b/Data/ASN1/Object.hs deleted file mode 100644 --- a/Data/ASN1/Object.hs +++ /dev/null @@ -1,12 +0,0 @@ --- | --- Module : Data.ASN1.Object --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Data.ASN1.Object {-# DEPRECATED "Use Data.ASN1.Types instead" #-} - ( ASN1Object(..) - ) where - -import Data.ASN1.Types diff --git a/Data/ASN1/Prim.hs b/Data/ASN1/Prim.hs deleted file mode 100644 --- a/Data/ASN1/Prim.hs +++ /dev/null @@ -1,457 +0,0 @@ --- | --- Module : Data.ASN1.Prim --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- Tools to read ASN1 primitive (e.g. boolean, int) --- - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} -module Data.ASN1.Prim - ( - -- * ASN1 high level algebraic type - ASN1(..) - , ASN1ConstructionType(..) - - , encodeHeader - , encodePrimitiveHeader - , encodePrimitive - , decodePrimitive - , encodeConstructed - , encodeList - , encodeOne - , mkSmallestLength - - -- * marshall an ASN1 type from a val struct or a bytestring - , getBoolean - , getInteger - , getDouble - , getBitString - , getOctetString - , getNull - , getOID - , getTime - - -- * marshall an ASN1 type to a bytestring - , putTime - , putInteger - , putDouble - , putBitString - , putString - , putOID - ) where - -import Data.ASN1.Internal -import Data.ASN1.Stream -import Data.ASN1.BitArray -import Data.ASN1.Types -import Data.ASN1.Types.Lowlevel -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.Arrow (first) -import Control.Applicative -import Control.Monad - -encodeHeader :: Bool -> ASN1Length -> ASN1 -> ASN1Header -encodeHeader pc len (Boolean _) = ASN1Header Universal 0x1 pc len -encodeHeader pc len (IntVal _) = ASN1Header Universal 0x2 pc len -encodeHeader pc len (BitString _) = ASN1Header Universal 0x3 pc len -encodeHeader pc len (OctetString _) = ASN1Header Universal 0x4 pc len -encodeHeader pc len Null = ASN1Header Universal 0x5 pc len -encodeHeader pc len (OID _) = ASN1Header Universal 0x6 pc len -encodeHeader pc len (Real _) = ASN1Header Universal 0x9 pc len -encodeHeader pc len (Enumerated _) = ASN1Header Universal 0xa pc len -encodeHeader pc len (ASN1String cs) = ASN1Header Universal (characterStringType $ characterEncoding cs) pc len - where characterStringType UTF8 = 0xc - characterStringType Numeric = 0x12 - characterStringType Printable = 0x13 - characterStringType T61 = 0x14 - characterStringType VideoTex = 0x15 - characterStringType IA5 = 0x16 - characterStringType Graphic = 0x19 - characterStringType Visible = 0x1a - characterStringType General = 0x1b - characterStringType UTF32 = 0x1c - characterStringType Character = 0x1d - characterStringType BMP = 0x1e -encodeHeader pc len (ASN1Time TimeUTC _ _) = ASN1Header Universal 0x17 pc len -encodeHeader pc len (ASN1Time TimeGeneralized _ _) = ASN1Header Universal 0x18 pc len -encodeHeader pc len (Start Sequence) = ASN1Header Universal 0x10 pc len -encodeHeader pc len (Start Set) = ASN1Header Universal 0x11 pc len -encodeHeader pc len (Start (Container tc tag)) = ASN1Header tc tag pc len -encodeHeader pc len (Other tc tag _) = ASN1Header tc tag pc len -encodeHeader _ _ (End _) = error "this should not happen" - -encodePrimitiveHeader :: ASN1Length -> ASN1 -> ASN1Header -encodePrimitiveHeader = encodeHeader False - -encodePrimitiveData :: ASN1 -> ByteString -encodePrimitiveData (Boolean b) = B.singleton (if b then 0xff else 0) -encodePrimitiveData (IntVal i) = putInteger i -encodePrimitiveData (BitString bits) = putBitString bits -encodePrimitiveData (OctetString b) = putString b -encodePrimitiveData Null = B.empty -encodePrimitiveData (OID oidv) = putOID oidv -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 -encodePrimitiveData (Other _ _ b) = b -encodePrimitiveData o = error ("not a primitive " ++ show o) - -encodePrimitive :: ASN1 -> (Int, [ASN1Event]) -encodePrimitive a = - let b = encodePrimitiveData a - blen = B.length b - len = makeLength blen - hdr = encodePrimitiveHeader len a - in (B.length (putHeader hdr) + blen, [Header hdr, Primitive b]) - where - makeLength len - | len < 0x80 = LenShort len - | otherwise = LenLong (nbBytes len) len - nbBytes nb = if nb > 255 then 1 + nbBytes (nb `div` 256) else 1 - -encodeOne :: ASN1 -> (Int, [ASN1Event]) -encodeOne (Start _) = error "encode one cannot do start" -encodeOne t = encodePrimitive t - -encodeList :: [ASN1] -> (Int, [ASN1Event]) -encodeList [] = (0, []) -encodeList (End _:xs) = encodeList xs -encodeList (t@(Start _):xs) = - let (ys, zs) = getConstructedEnd 0 xs - (llen, lev) = encodeList zs - (len, ev) = encodeConstructed t ys - in (llen + len, ev ++ lev) - -encodeList (x:xs) = - let (llen, lev) = encodeList xs - (len, ev) = encodeOne x - in (llen + len, ev ++ lev) - -encodeConstructed :: ASN1 -> [ASN1] -> (Int, [ASN1Event]) -encodeConstructed c@(Start _) children = - (tlen, Header h : ConstructionBegin : events ++ [ConstructionEnd]) - where (clen, events) = encodeList children - len = mkSmallestLength clen - h = encodeHeader True len c - tlen = B.length (putHeader h) + clen - -encodeConstructed _ _ = error "not a start node" - -mkSmallestLength :: Int -> ASN1Length -mkSmallestLength i - | i < 0x80 = LenShort i - | otherwise = LenLong (nbBytes i) i - where nbBytes nb = if nb > 255 then 1 + nbBytes (nb `div` 256) else 1 - -type ASN1Ret = Either ASN1Error ASN1 - -decodePrimitive :: ASN1Header -> B.ByteString -> ASN1Ret -decodePrimitive (ASN1Header Universal 0x1 _ _) p = getBoolean False p -decodePrimitive (ASN1Header Universal 0x2 _ _) p = getInteger p -decodePrimitive (ASN1Header Universal 0x3 _ _) p = getBitString p -decodePrimitive (ASN1Header Universal 0x4 _ _) p = getOctetString p -decodePrimitive (ASN1Header Universal 0x5 _ _) p = getNull p -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 _ _) 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 -decodePrimitive (ASN1Header Universal 0xd _ _) _ = Left $ TypeNotImplemented "RELATIVE-OID" -decodePrimitive (ASN1Header Universal 0x10 _ _) _ = Left $ TypePrimitiveInvalid "sequence" -decodePrimitive (ASN1Header Universal 0x11 _ _) _ = Left $ TypePrimitiveInvalid "set" -decodePrimitive (ASN1Header Universal 0x12 _ _) p = getCharacterString Numeric p -decodePrimitive (ASN1Header Universal 0x13 _ _) p = getCharacterString Printable p -decodePrimitive (ASN1Header Universal 0x14 _ _) p = getCharacterString T61 p -decodePrimitive (ASN1Header Universal 0x15 _ _) p = getCharacterString VideoTex p -decodePrimitive (ASN1Header Universal 0x16 _ _) p = getCharacterString IA5 p -decodePrimitive (ASN1Header Universal 0x17 _ _) p = getTime TimeUTC p -decodePrimitive (ASN1Header Universal 0x18 _ _) p = getTime TimeGeneralized p -decodePrimitive (ASN1Header Universal 0x19 _ _) p = getCharacterString Graphic p -decodePrimitive (ASN1Header Universal 0x1a _ _) p = getCharacterString Visible p -decodePrimitive (ASN1Header Universal 0x1b _ _) p = getCharacterString General p -decodePrimitive (ASN1Header Universal 0x1c _ _) p = getCharacterString UTF32 p -decodePrimitive (ASN1Header Universal 0x1d _ _) p = getCharacterString Character p -decodePrimitive (ASN1Header Universal 0x1e _ _) p = getCharacterString BMP p -decodePrimitive (ASN1Header tc tag _ _) p = Right $ Other tc tag p - - -getBoolean :: Bool -> ByteString -> Either ASN1Error ASN1 -getBoolean isDer s = - if B.length s == 1 - then case B.head s of - 0 -> Right (Boolean False) - 0xff -> Right (Boolean True) - _ -> if isDer then Left $ PolicyFailed "DER" "boolean value not canonical" else Right (Boolean True) - else Left $ TypeDecodingFailed "boolean: length not within bound" - -{- | getInteger, parse a value bytestring and get the integer out of the two complement encoded bytes -} -getInteger :: ByteString -> Either ASN1Error ASN1 -{-# INLINE getInteger #-} -getInteger s = IntVal <$> getIntegerRaw "integer" s - -{- | getEnumerated, parse an enumerated value the same way that integer values are parsed. -} -getEnumerated :: ByteString -> Either ASN1Error ASN1 -{-# INLINE getEnumerated #-} -getEnumerated s = Enumerated <$> getIntegerRaw "enumerated" s - -{- | According to X.690 section 8.4 integer and enumerated values should be encoded the same way. -} -getIntegerRaw :: String -> ByteString -> Either ASN1Error Integer -getIntegerRaw typestr s - | B.length s == 0 = Left . TypeDecodingFailed $ typestr ++ ": null encoding" - | B.length s == 1 = Right $ snd $ intOfBytes s - | otherwise = - if (v1 == 0xff && testBit v2 7) || (v1 == 0x0 && (not $ testBit v2 7)) - then Left . TypeDecodingFailed $ typestr ++ ": not shortest encoding" - else Right $ snd $ intOfBytes s - where - 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 - let toSkip' = if toSkip >= 48 && toSkip <= 48 + 7 then toSkip - (fromIntegral $ ord '0') else toSkip in - let xs = B.tail s in - if toSkip' >= 0 && toSkip' <= 7 - then Right $ BitString $ toBitArray xs (fromIntegral toSkip') - else Left $ TypeDecodingFailed ("bitstring: skip number not within bound " ++ show toSkip' ++ " " ++ show s) - -getCharacterString :: ASN1StringEncoding -> ByteString -> Either ASN1Error ASN1 -getCharacterString encoding bs = Right $ ASN1String (ASN1CharacterString encoding bs) - -getOctetString :: ByteString -> Either ASN1Error ASN1 -getOctetString = Right . OctetString - -getNull :: ByteString -> Either ASN1Error ASN1 -getNull s - | B.length s == 0 = Right Null - | otherwise = Left $ TypeDecodingFailed "Null: data length not within bound" - -{- | return an OID -} -getOID :: ByteString -> Either ASN1Error ASN1 -getOID s = Right $ OID $ (fromIntegral (x `div` 40) : fromIntegral (x `mod` 40) : groupOID xs) - where - (x:xs) = B.unpack s - - groupOID :: [Word8] -> [Integer] - groupOID = map (foldl (\acc n -> (acc `shiftL` 7) + fromIntegral n) 0) . groupSubOID - - groupSubOIDHelper [] = Nothing - groupSubOIDHelper l = Just $ spanSubOIDbound l - - groupSubOID :: [Word8] -> [[Word8]] - groupSubOID = unfoldr groupSubOIDHelper - - spanSubOIDbound [] = ([], []) - spanSubOIDbound (a:as) = if testBit a 7 then (clearBit a 7 : ys, zs) else ([a], as) - where (ys, zs) = spanSubOIDbound as - -getTime :: ASN1TimeType -> ByteString -> Either ASN1Error ASN1 -getTime timeType bs - | hasNonASCII bs = decodingError "contains non ASCII characters" - | otherwise = - case timeParseE format (BC.unpack bs) of -- BC.unpack is safe as we check ASCIIness first - Left _ -> - case timeParseE formatNoSeconds (BC.unpack bs) of - Left _ -> decodingError ("cannot convert string " ++ BC.unpack bs) - Right r -> parseRemaining r - Right r -> parseRemaining r - where - parseRemaining r = - case parseTimezone $ parseMs $ first adjustUTC r of - Left err -> decodingError err - Right (dt', tz) -> Right $ ASN1Time timeType dt' tz - - adjustUTC dt@(DateTime (Date y m d) tod) - | timeType == TimeGeneralized = dt - | y > 2050 = DateTime (Date (y - 100) m d) tod - | otherwise = dt - formatNoSeconds = init format - format | timeType == TimeGeneralized = 'Y':'Y':baseFormat - | otherwise = baseFormat - baseFormat = "YYMMDDHMIS" - - parseMs (dt,s) = - case s of - '.':s' -> let (ns, r) = first toNano $ spanToLength 3 isDigit s' - in (dt { dtTime = (dtTime dt) { todNSec = ns } }, r) - _ -> (dt,s) - parseTimezone (dt,s) = - case s of - '+':s' -> Right (dt, parseTimezoneFormat id s') - '-':s' -> Right (dt, parseTimezoneFormat ((-1) *) s') - 'Z':[] -> Right (dt, Just timezone_UTC) - "" -> Right (dt, Nothing) - _ -> Left ("unknown timezone format: " ++ s) - - parseTimezoneFormat transform s - | length s == 4 = Just $ toTz $ toInt $ fst $ spanToLength 4 isDigit s - | otherwise = Nothing - where toTz z = let (h,m) = z `divMod` 100 in TimezoneOffset $ transform (h * 60 + m) - - toNano :: String -> NanoSeconds - toNano l = fromIntegral (toInt l * order * 1000000) - where len = length l - order = case len of - 1 -> 100 - 2 -> 10 - 3 -> 1 - _ -> 1 - - spanToLength :: Int -> (Char -> Bool) -> String -> (String, String) - spanToLength len p l = loop 0 l - where loop i z - | i >= len = ([], z) - | otherwise = case z of - [] -> ([], []) - x:xs -> if p x - then let (r1,r2) = loop (i+1) xs - in (x:r1, r2) - else ([], z) - - toInt :: String -> Int - toInt = foldl (\acc w -> acc * 10 + (ord w - ord '0')) 0 - - decodingError reason = Left $ TypeDecodingFailed ("time format invalid for " ++ show timeType ++ " : " ++ reason) - hasNonASCII = maybe False (const True) . B.find (\c -> c > 0x7f) - --- FIXME need msec printed -putTime :: ASN1TimeType -> DateTime -> Maybe TimezoneOffset -> ByteString -putTime ty dt mtz = BC.pack etime - where - etime - | ty == TimeUTC = timePrint "YYMMDDHMIS" dt ++ tzStr - | otherwise = timePrint "YYYYMMDDHMIS" dt ++ msecStr ++ tzStr - msecStr = [] - tzStr = case mtz of - Nothing -> "" - Just tz | tz == timezone_UTC -> "Z" - | otherwise -> show tz - -putInteger :: Integer -> ByteString -putInteger i = B.pack $ bytesOfInt i - -putBitString :: BitArray -> ByteString -putBitString (BitArray n bits) = - B.concat [B.singleton (fromIntegral i),bits] - where i = (8 - (n `mod` 8)) .&. 0x7 - -putString :: ByteString -> ByteString -putString l = l - -{- no enforce check that oid1 is between [0..2] and oid2 is between [0..39] -} -putOID :: [Integer] -> ByteString -putOID oids = case oids of - (oid1:oid2:suboids) -> - let eoidclass = fromIntegral (oid1 * 40 + oid2) - subeoids = B.concat $ map encode suboids - in B.cons eoidclass subeoids - _ -> error ("invalid OID format " ++ show oids) - 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/Data/ASN1/Serialize.hs b/Data/ASN1/Serialize.hs deleted file mode 100644 --- a/Data/ASN1/Serialize.hs +++ /dev/null @@ -1,95 +0,0 @@ --- | --- Module : Data.ASN1.Serialize --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Data.ASN1.Serialize (getHeader, putHeader) where - -import qualified Data.ByteString as B -import Data.ASN1.Get -import Data.ASN1.Internal -import Data.ASN1.Types -import Data.ASN1.Types.Lowlevel -import Data.Bits -import Data.Word -import Control.Applicative ((<$>)) -import Control.Monad - --- | parse an ASN1 header -getHeader :: Get ASN1Header -getHeader = do - (cl,pc,t1) <- parseFirstWord <$> getWord8 - tag <- if t1 == 0x1f then getTagLong else return t1 - len <- getLength - return $ ASN1Header cl tag pc len - --- | Parse the first word of an header -parseFirstWord :: Word8 -> (ASN1Class, Bool, ASN1Tag) -parseFirstWord w = (cl,pc,t1) - where cl = toEnum $ fromIntegral $ (w `shiftR` 6) - pc = testBit w 5 - t1 = fromIntegral (w .&. 0x1f) - -{- when the first tag is 0x1f, the tag is in long form, where - - we get bytes while the 7th bit is set. -} -getTagLong :: Get ASN1Tag -getTagLong = do - t <- fromIntegral <$> getWord8 - when (t == 0x80) $ fail "non canonical encoding of long tag" - if testBit t 7 - then loop (clearBit t 7) - else return t - where loop n = do - t <- fromIntegral <$> getWord8 - if testBit t 7 - then loop (n `shiftL` 7 + clearBit t 7) - else return (n `shiftL` 7 + t) - - -{- get the asn1 length which is either short form if 7th bit is not set, - - indefinite form is the 7 bit is set and every other bits clear, - - or long form otherwise, where the next bytes will represent the length - -} -getLength :: Get ASN1Length -getLength = do - l1 <- fromIntegral <$> getWord8 - if testBit l1 7 - then case clearBit l1 7 of - 0 -> return LenIndefinite - len -> do - lw <- getBytes len - return (LenLong len $ uintbs lw) - else - return (LenShort l1) - where - {- uintbs return the unsigned int represented by the bytes -} - uintbs = B.foldl (\acc n -> (acc `shiftL` 8) + fromIntegral n) 0 - --- | putIdentifier encode an ASN1 Identifier into a marshalled value -putHeader :: ASN1Header -> B.ByteString -putHeader (ASN1Header cl tag pc len) = B.concat - [ B.singleton word1 - , if tag < 0x1f then B.empty else tagBS - , lenBS] - where cli = shiftL (fromIntegral $ fromEnum cl) 6 - pcval = shiftL (if pc then 0x1 else 0x0) 5 - tag0 = if tag < 0x1f then fromIntegral tag else 0x1f - word1 = cli .|. pcval .|. tag0 - lenBS = B.pack $ putLength len - tagBS = putVarEncodingIntegral tag - -{- | putLength encode a length into a ASN1 length. - - see getLength for the encoding rules -} -putLength :: ASN1Length -> [Word8] -putLength (LenShort i) - | i < 0 || i > 0x7f = error "putLength: short length is not between 0x0 and 0x80" - | otherwise = [fromIntegral i] -putLength (LenLong _ i) - | i < 0 = error "putLength: long length is negative" - | otherwise = lenbytes : lw - where - lw = bytesOfUInt $ fromIntegral i - lenbytes = fromIntegral (length lw .|. 0x80) -putLength (LenIndefinite) = [0x80] diff --git a/Data/ASN1/Stream.hs b/Data/ASN1/Stream.hs deleted file mode 100644 --- a/Data/ASN1/Stream.hs +++ /dev/null @@ -1,41 +0,0 @@ --- | --- Module : Data.ASN1.Stream --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Data.ASN1.Stream - ( ASN1Repr - , getConstructedEnd - , getConstructedEndRepr - ) where - -import Data.ASN1.Types -import Data.ASN1.Types.Lowlevel - -{- associate a list of asn1 event with an ASN1 type. - - it's sometimes required to know the exact byte sequence leading to an ASN1 type: - - eg: cryptographic signature -} -type ASN1Repr = (ASN1, [ASN1Event]) - -getConstructedEnd :: Int -> [ASN1] -> ([ASN1],[ASN1]) -getConstructedEnd _ xs@[] = (xs, []) -getConstructedEnd i ((x@(Start _)):xs) = let (yz, zs) = getConstructedEnd (i+1) xs in (x:yz,zs) -getConstructedEnd i ((x@(End _)):xs) - | i == 0 = ([], xs) - | otherwise = let (ys, zs) = getConstructedEnd (i-1) xs in (x:ys,zs) -getConstructedEnd i (x:xs) = let (ys, zs) = getConstructedEnd i xs in (x:ys,zs) - -getConstructedEndRepr :: [ASN1Repr] -> ([ASN1Repr],[ASN1Repr]) -getConstructedEndRepr = g - where g [] = ([], []) - g (x@(Start _,_):xs) = let (ys, zs) = getEnd 1 xs in (x:ys, zs) - g (x:xs) = ([x],xs) - - getEnd :: Int -> [ASN1Repr] -> ([ASN1Repr],[ASN1Repr]) - getEnd _ [] = ([], []) - getEnd 0 xs = ([], xs) - getEnd i ((x@(Start _, _)):xs) = let (ys, zs) = getEnd (i+1) xs in (x:ys,zs) - getEnd i ((x@(End _, _)):xs) = let (ys, zs) = getEnd (i-1) xs in (x:ys,zs) - getEnd i (x:xs) = let (ys, zs) = getEnd i xs in (x:ys,zs) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,9 +4,9 @@ Originally forked from [asn1-encoding-0.9.6](https://hackage.haskell.org/package/asn1-encoding-0.9.6). -ASN.1 for Haskell - -* crypton-asn1-encoding : BER and DER encoding decoder and encoder. +A reader and writer of data following the Abstract Syntax Notation One (ASN.1) +standard in raw form or in the high-level forms of Basic Encoding Rules (BER) +and Distinguished Encoding Rules (DER). History ------- diff --git a/crypton-asn1-encoding.cabal b/crypton-asn1-encoding.cabal --- a/crypton-asn1-encoding.cabal +++ b/crypton-asn1-encoding.cabal @@ -1,84 +1,95 @@ -cabal-version: 1.18 - --- This file has been generated from package.yaml by hpack version 0.38.1. --- --- see: https://github.com/sol/hpack - -name: crypton-asn1-encoding -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). -category: Data -stability: experimental -homepage: https://github.com/mpilgrem/crypton-asn1 -bug-reports: https://github.com/mpilgrem/crypton-asn1/issues -author: Vincent Hanquez -maintainer: Mike Pilgrem , - Kazu Yamamoto -copyright: Vincent Hanquez -license: BSD3 -license-file: LICENSE -build-type: Simple -extra-doc-files: - CHANGELOG.md - README.md - -source-repository head - type: git - location: https://github.com/mpilgrem/crypton-asn1 - subdir: encoding - -library - exposed-modules: - Data.ASN1.Error - Data.ASN1.BinaryEncoding - Data.ASN1.BinaryEncoding.Raw - Data.ASN1.Encoding - Data.ASN1.Stream - Data.ASN1.Object - Data.ASN1.Prim - other-modules: - Data.ASN1.BinaryEncoding.Parse - Data.ASN1.BinaryEncoding.Writer - Data.ASN1.Internal - Data.ASN1.Serialize - Data.ASN1.Get - ghc-options: -Wall -fwarn-tabs - build-depends: - base >=3 && <5 - , bytestring - , crypton-asn1-types >=0.3.0 && <0.4 - , hourglass >=0.2.6 - default-language: Haskell2010 - -test-suite tests-asn1-encoding - type: exitcode-stdio-1.0 - main-is: Tests.hs - other-modules: - Data.ASN1.BinaryEncoding - Data.ASN1.BinaryEncoding.Parse - Data.ASN1.BinaryEncoding.Raw - Data.ASN1.BinaryEncoding.Writer - Data.ASN1.Encoding - Data.ASN1.Error - Data.ASN1.Get - Data.ASN1.Internal - Data.ASN1.Object - Data.ASN1.Prim - Data.ASN1.Serialize - Data.ASN1.Stream - hs-source-dirs: - tests - ./ - ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures - build-depends: - base >=3 && <7 - , bytestring - , crypton-asn1-encoding - , crypton-asn1-types - , hourglass - , mtl - , tasty - , tasty-quickcheck - default-language: Haskell2010 +cabal-version: 1.22 + +-- This file has been generated from package.yaml by hpack version 0.38.1. +-- +-- see: https://github.com/sol/hpack + +name: crypton-asn1-encoding +version: 0.9.7 +synopsis: ASN.1 data (raw, BER or DER) readers and writers +description: A library providing readers and writers of data following the Abstract Syntax + Notation One (ASN.1) standard in raw form or in the high-level forms of Basic + Encoding Rules (BER) and Distinguished Encoding Rules (DER). +category: Data +stability: experimental +homepage: https://github.com/mpilgrem/crypton-asn1 +bug-reports: https://github.com/mpilgrem/crypton-asn1/issues +author: Vincent Hanquez +maintainer: Mike Pilgrem , + Kazu Yamamoto +copyright: Vincent Hanquez +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/mpilgrem/crypton-asn1 + subdir: encoding + +library + exposed-modules: + Data.ASN1.Error + Data.ASN1.BinaryEncoding + Data.ASN1.BinaryEncoding.Raw + Data.ASN1.Encoding + Data.ASN1.Object + Data.ASN1.Prim + other-modules: + Data.ASN1.BinaryEncoding.Parse + Data.ASN1.BinaryEncoding.Writer + Data.ASN1.Get + Data.ASN1.Internal + Data.ASN1.Serialize + reexported-modules: + Data.ASN1.Stream + hs-source-dirs: + src + other-extensions: + CPP + RankNTypes + ViewPatterns + ghc-options: -Wall + build-depends: + base >=4.13 && <5 + , bytestring + , crypton-asn1-types >=0.3.6 && <0.4 + , hourglass >=0.2.6 + default-language: Haskell2010 + +test-suite tests-asn1-encoding + type: exitcode-stdio-1.0 + main-is: Tests.hs + other-modules: + Data.ASN1.BinaryEncoding + Data.ASN1.BinaryEncoding.Parse + Data.ASN1.BinaryEncoding.Raw + Data.ASN1.BinaryEncoding.Writer + Data.ASN1.Encoding + Data.ASN1.Error + Data.ASN1.Get + Data.ASN1.Internal + Data.ASN1.Object + Data.ASN1.Prim + Data.ASN1.Serialize + hs-source-dirs: + tests + src + other-extensions: + CPP + RankNTypes + ViewPatterns + ghc-options: -Wall + build-depends: + base >=4.13 && <5 + , bytestring + , crypton-asn1-encoding + , crypton-asn1-types >=0.3.6 && <0.4 + , hourglass + , mtl + , tasty + , tasty-quickcheck + default-language: Haskell2010 diff --git a/src/Data/ASN1/BinaryEncoding.hs b/src/Data/ASN1/BinaryEncoding.hs new file mode 100644 --- /dev/null +++ b/src/Data/ASN1/BinaryEncoding.hs @@ -0,0 +1,113 @@ +{- | +Module : Data.ASN1.BinaryEncoding +License : BSD-style +Copyright : (c) 2010-2013 Vincent Hanquez +Stability : experimental +Portability : unknown + +A module containing ASN.1 BER and DER specification encoding/decoding. +-} + +module Data.ASN1.BinaryEncoding + ( BER (..) + , DER (..) + ) where + +import qualified Control.Exception as E +import Data.ASN1.BinaryEncoding.Parse ( parseLBS ) +import Data.ASN1.BinaryEncoding.Writer ( toLazyByteString ) +import Data.ASN1.Encoding + ( ASN1Decoding (..), ASN1DecodingRepr (..), ASN1Encoding (..) + ) +import Data.ASN1.Error ( ASN1Error (..) ) +import Data.ASN1.Prim + ( decodePrimitive, encodeConstructed, encodePrimitive ) +import Data.ASN1.Stream ( ASN1Repr ) +import Data.ASN1.Types ( ASN1 (..), ASN1ConstructionType (..) ) +import Data.ASN1.Types.Lowlevel + ( ASN1Class (..), ASN1Event (..), ASN1Header (..) + , ASN1Length (..) + ) + +-- | Basic Encoding Rules (BER). +data BER = BER + +-- | Distinguished Encoding Rules (DER). +data DER = DER + +instance ASN1DecodingRepr BER where + decodeASN1Repr _ lbs = decodeEventASN1Repr (const Nothing) `fmap` parseLBS lbs + +instance ASN1Decoding BER where + decodeASN1 _ lbs = + (map fst . decodeEventASN1Repr (const Nothing)) `fmap` parseLBS lbs + +instance ASN1DecodingRepr DER where + decodeASN1Repr _ lbs = decodeEventASN1Repr checkDER `fmap` parseLBS lbs + +instance ASN1Decoding DER where + decodeASN1 _ lbs = + (map fst . decodeEventASN1Repr checkDER) `fmap` parseLBS lbs + +instance ASN1Encoding DER where + encodeASN1 _ l = toLazyByteString $ encodeToRaw l + +decodeConstruction :: ASN1Header -> ASN1ConstructionType +decodeConstruction (ASN1Header Universal 0x10 _ _) = Sequence +decodeConstruction (ASN1Header Universal 0x11 _ _) = Set +decodeConstruction (ASN1Header c t _ _) = Container c t + +decodeEventASN1Repr :: (ASN1Header -> Maybe ASN1Error) -> [ASN1Event] -> [ASN1Repr] +decodeEventASN1Repr checkHeader = loop [] + where + loop _ [] = [] + loop acc (h@(Header hdr@(ASN1Header _ _ True _)):ConstructionBegin:xs) = + let ctype = decodeConstruction hdr + in case checkHeader hdr of + Nothing -> (Start ctype,[h,ConstructionBegin]) : loop (ctype:acc) xs + Just err -> E.throw err + loop acc (h@(Header hdr@(ASN1Header _ _ False _)):p@(Primitive prim):xs) = + case checkHeader hdr of + Nothing -> case decodePrimitive hdr prim of + Left err -> E.throw err + Right obj -> (obj, [h, p]) : loop acc xs + Just err -> E.throw err + loop (ctype:acc) (ConstructionEnd:xs) = + (End ctype, [ConstructionEnd]) : loop acc xs + loop _ (x:_) = E.throw $ StreamUnexpectedSituation (show x) + +-- | DER header need to be all of finite size and of minimum possible size. +checkDER :: ASN1Header -> Maybe ASN1Error +checkDER (ASN1Header _ _ _ len) = checkLength len + where + checkLength :: ASN1Length -> Maybe ASN1Error + checkLength LenIndefinite = + Just $ PolicyFailed "DER" "indefinite length not allowed" + checkLength (LenShort _) = Nothing + checkLength (LenLong n i) + | n == 1 && i < 0x80 = + Just $ PolicyFailed "DER" "long length should be a short length" + | n == 1 && i >= 0x80 = Nothing + | otherwise = if i >= 2^((n-1)*8) && i < 2^(n*8) + then Nothing + else Just $ PolicyFailed "DER" "long length is not shortest" + +encodeToRaw :: [ASN1] -> [ASN1Event] +encodeToRaw = concatMap writeTree . mkTree + where + writeTree (p@(Start _),children) = snd $ encodeConstructed p children + writeTree (p,_) = snd $ encodePrimitive p + + mkTree [] = [] + mkTree (x@(Start _):xs) = + let (tree, r) = spanEnd 0 xs + in (x, tree):mkTree r + mkTree (p:xs) = (p, []) : mkTree xs + + spanEnd :: Int -> [ASN1] -> ([ASN1], [ASN1]) + spanEnd _ [] = ([], []) + spanEnd 0 (x@(End _):xs) = ([x], xs) + spanEnd lvl (x:xs) = case x of + Start _ -> let (ys, zs) = spanEnd (lvl+1) xs in (x:ys, zs) + End _ -> let (ys, zs) = spanEnd (lvl-1) xs in (x:ys, zs) + _ -> let (ys, zs) = spanEnd lvl xs in (x:ys, zs) diff --git a/src/Data/ASN1/BinaryEncoding/Parse.hs b/src/Data/ASN1/BinaryEncoding/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Data/ASN1/BinaryEncoding/Parse.hs @@ -0,0 +1,202 @@ +{- | +Module : Data.ASN1.BinaryEncoding.Parse +License : BSD-style +Copyright : (c) 2010-2013 Vincent Hanquez +Stability : experimental +Portability : unknown + +Generic parsing facility for ASN.1. +-} + +module Data.ASN1.BinaryEncoding.Parse + ( -- * incremental parsing interfaces + runParseState + , isParseDone + , newParseState + , ParseState + , ParseCursor + -- * simple parsing interfaces + , parseLBS + , parseBS + ) where + +import Control.Arrow ( first ) +import Data.ASN1.Error ( ASN1Error (..) ) +import Data.ASN1.Get ( Result (..), getBytes, runGetPos ) +import Data.ASN1.Serialize ( getHeader ) +import Data.ASN1.Types.Lowlevel + ( ASN1Class (..), ASN1Event (..), ASN1Header (..) + , ASN1Length (..) + ) +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.Maybe ( fromJust ) +import Data.Word ( Word64 ) + +-- | Nothing means the parser stops this construction on an ASN.1 end tag, +-- otherwise specify the position where the construction terminates. +type ConstructionEndAt = Maybe Word64 + +data ParseExpect = + ExpectHeader (Maybe (B.ByteString -> Result ASN1Header)) + | ExpectPrimitive Word64 (Maybe (B.ByteString -> Result ByteString)) + +type ParsePosition = Word64 + +-- | Represent the parsing state of an ASN.1 stream. +-- +-- * the stack of constructed elements. +-- * the next expected type. +-- * the position in the stream. +-- +data ParseState = ParseState [ConstructionEndAt] ParseExpect ParsePosition + +-- | Create a new empty parse state. Position is 0. +newParseState :: ParseState +newParseState = ParseState [] (ExpectHeader Nothing) 0 + +isEOC :: ASN1Header -> Bool +isEOC (ASN1Header cl t _ _) = cl == Universal && t == 0 + +asn1LengthToConst :: ASN1Length -> Maybe Word64 +asn1LengthToConst (LenShort n) = Just $ fromIntegral n +asn1LengthToConst (LenLong _ n) = Just $ fromIntegral n +asn1LengthToConst LenIndefinite = Nothing + +-- In the future, drop this for the `mplus` with Either. +mplusEither :: Either b a -> (a -> Either b c) -> Either b c +mplusEither (Left e) _ = Left e +mplusEither (Right e) f = f e + +-- | Represent the events and state thus far. +type ParseCursor = ([ASN1Event], ParseState) + +-- | Run incrementally the ASN.1 parser on a bytestring. The result can be +-- either an error, or on success a list of events, and the new parsing state. +runParseState :: + ParseState -- ^ parser state + -> ByteString -- ^ input data as bytes + -> Either ASN1Error ParseCursor +runParseState = loop + where + loop iniState bs + | B.null bs = + terminateAugment (([], iniState), bs) `mplusEither` (Right . fst) + | otherwise = + go iniState bs `mplusEither` terminateAugment + `mplusEither` \((evs, newState), nbs) -> loop newState nbs + `mplusEither` (Right . first (evs ++)) + + terminateAugment ret@((evs, ParseState stackEnd pe pos), r) = + case stackEnd of + Just endPos:xs + | pos > endPos -> Left StreamConstructionWrongSize + | pos == endPos -> + terminateAugment ((evs ++ [ConstructionEnd], ParseState xs pe pos), r) + | otherwise -> Right ret + _ -> Right ret + + -- go get one element (either a primitive or a header) from the bytes + -- and returns the new cursor and the remaining byte. + go :: ParseState -> ByteString -> Either ASN1Error (ParseCursor, ByteString) + go (ParseState stackEnd (ExpectHeader cont) pos) bs = + case runGetHeader cont pos bs of + Fail s -> Left $ ParsingHeaderFail s + Partial f -> Right + (([], ParseState stackEnd (ExpectHeader $ Just f) pos), B.empty) + Done hdr nPos remBytes + | isEOC hdr -> case stackEnd of + [] -> Right (([], ParseState [] (ExpectHeader Nothing) nPos), remBytes) + Just _:_ -> Left StreamUnexpectedEOC + Nothing:newStackEnd -> Right + ( ( [ConstructionEnd] + , ParseState newStackEnd (ExpectHeader Nothing) nPos + ) + , remBytes + ) + | otherwise -> case hdr of + (ASN1Header _ _ True len) -> + let nEnd = (nPos +) `fmap` asn1LengthToConst len + in Right + ( ( [Header hdr,ConstructionBegin] + , ParseState (nEnd:stackEnd) (ExpectHeader Nothing) nPos + ) + , remBytes + ) + (ASN1Header _ _ False LenIndefinite) -> Left StreamInfinitePrimitive + (ASN1Header _ _ False len) -> + let pLength = fromJust $ asn1LengthToConst len + in if pLength == 0 + then Right + ( ( [Header hdr,Primitive B.empty] + , ParseState stackEnd (ExpectHeader Nothing) nPos + ) + , remBytes + ) + else Right + ( ( [Header hdr] + , ParseState stackEnd (ExpectPrimitive pLength Nothing) nPos + ) + , remBytes + ) + go (ParseState stackEnd (ExpectPrimitive len cont) pos) bs = + case runGetPrimitive cont len pos bs of + Fail _ -> Left ParsingPartial + Partial f -> Right + ( ( [] + , ParseState stackEnd (ExpectPrimitive len $ Just f) pos + ) + , B.empty + ) + Done p nPos remBytes -> Right + ( ( [Primitive p] + , ParseState stackEnd (ExpectHeader Nothing) nPos + ) + , remBytes + ) + + runGetHeader Nothing = (`runGetPos` getHeader) + runGetHeader (Just f) = const f + + runGetPrimitive Nothing n = \pos -> runGetPos pos (getBytes $ fromIntegral n) + runGetPrimitive (Just f) _ = const f + +-- | When no more input is available, it's important to check that the parser is +-- in a finish state too. +isParseDone :: ParseState -> Bool +isParseDone (ParseState [] (ExpectHeader Nothing) _) = True +isParseDone _ = False + +-- | Parse one lazy bytestring and returns on success all ASN.1 events +-- associated. +parseLBS :: L.ByteString -> Either ASN1Error [ASN1Event] +parseLBS lbs = foldrEither process ([], newParseState) (L.toChunks lbs) `mplusEither` onSuccess + where + onSuccess (allEvs, finalState) + | isParseDone finalState = Right $ concat $ reverse allEvs + | otherwise = Left ParsingPartial + + process :: + ([[ASN1Event]], ParseState) + -> ByteString + -> Either ASN1Error ([[ASN1Event]], ParseState) + process (pevs, cState) bs = + runParseState cState bs `mplusEither` \(es, cState') -> Right (es : pevs, cState') + + foldrEither :: + (a -> ByteString -> Either ASN1Error a) + -> a + -> [ByteString] + -> Either ASN1Error a + foldrEither _ acc [] = Right acc + foldrEither f acc (x:xs) = f acc x `mplusEither` \nacc -> foldrEither f nacc xs + +-- | Parse one strict bytestring and returns on success all ASN.1 events +-- associated. +parseBS :: ByteString -> Either ASN1Error [ASN1Event] +parseBS bs = runParseState newParseState bs `mplusEither` onSuccess + where + onSuccess (evs, pstate) + | isParseDone pstate = Right evs + | otherwise = Left ParsingPartial diff --git a/src/Data/ASN1/BinaryEncoding/Raw.hs b/src/Data/ASN1/BinaryEncoding/Raw.hs new file mode 100644 --- /dev/null +++ b/src/Data/ASN1/BinaryEncoding/Raw.hs @@ -0,0 +1,32 @@ +{- | +Module : Data.ASN1.BinaryEncoding.Raw +License : BSD-style +Copyright : (c) 2010-2013 Vincent Hanquez +Stability : experimental +Portability : unknown + +Raw encoding of binary format (BER/DER/CER) +-} + +module Data.ASN1.BinaryEncoding.Raw + ( -- * Types + ASN1Header (..) + , ASN1Class (..) + , ASN1Tag + , ASN1Length (..) + , ASN1Event (..) + -- * Parser + , parseLBS + , parseBS + -- * Writer + , toLazyByteString + , toByteString + ) where + +import Data.ASN1.BinaryEncoding.Parse ( parseBS, parseLBS ) +import Data.ASN1.BinaryEncoding.Writer + ( toByteString, toLazyByteString ) +import Data.ASN1.Types.Lowlevel + ( ASN1Class (..), ASN1Event (..), ASN1Header (..) + , ASN1Length (..), ASN1Tag + ) diff --git a/src/Data/ASN1/BinaryEncoding/Writer.hs b/src/Data/ASN1/BinaryEncoding/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Data/ASN1/BinaryEncoding/Writer.hs @@ -0,0 +1,43 @@ +{- | +Module : Data.ASN1.BinaryEncoding.Writer +License : BSD-style +Copyright : (c) 2010-2013 Vincent Hanquez +Stability : experimental +Portability : unknown + +Serialize events for streaming. +-} + +module Data.ASN1.BinaryEncoding.Writer + ( toByteString + , toLazyByteString + ) where + +import Data.ASN1.Serialize ( putHeader ) +import Data.ASN1.Types.Lowlevel + ( ASN1Event (..), ASN1Header (..), ASN1Length (..) ) +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +-- | Transform a list of ASN.1 events into a strict bytestring. +toByteString :: [ASN1Event] -> ByteString +toByteString = B.concat . L.toChunks . toLazyByteString + +-- | Transform a list of ASN.1 events into a lazy bytestring. +toLazyByteString :: [ASN1Event] -> L.ByteString +toLazyByteString evs = L.fromChunks $ loop [] evs + where + loop _ [] = [] + loop acc (x@(Header (ASN1Header _ _ pc len)):xs) = + toBs x : loop (if pc then (len == LenIndefinite):acc else acc) xs + loop acc (ConstructionEnd:xs) = case acc of + [] -> error "malformed stream: end before construction" + (True:r) -> toBs ConstructionEnd : loop r xs + (False:r) -> loop r xs + loop acc (x:xs) = toBs x : loop acc xs + + toBs (Header hdr) = putHeader hdr + toBs (Primitive bs) = bs + toBs ConstructionBegin = B.empty + toBs ConstructionEnd = B.empty diff --git a/src/Data/ASN1/Encoding.hs b/src/Data/ASN1/Encoding.hs new file mode 100644 --- /dev/null +++ b/src/Data/ASN1/Encoding.hs @@ -0,0 +1,57 @@ +{- | +Module : Data.ASN1.Encoding +License : BSD-style +Copyright : (c) 2010-2013 Vincent Hanquez +Stability : experimental +Portability : unknown +-} + +module Data.ASN1.Encoding + ( -- * Generic class for decoding and encoding a stream + ASN1Decoding (..) + , ASN1DecodingRepr (..) + , ASN1Encoding (..) + -- * Strict bytestring alternatives + , decodeASN1' + , decodeASN1Repr' + , encodeASN1' + ) where + +import Data.ASN1.Error ( ASN1Error ) +import Data.ASN1.Stream ( ASN1Repr ) +import Data.ASN1.Types ( ASN1 ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +-- | Describe an ASN.1 decoding, that transforms a lazy bytestring into a list +-- of ASN.1 values. +class ASN1Decoding a where + -- | Decode a lazy bytestring into a list of ASN.1 values. + decodeASN1 :: a -> L.ByteString -> Either ASN1Error [ASN1] + +-- | Transition class. +class ASN1DecodingRepr a where + -- | Decode a lazy bytestring into a list of 'ASN1Repr' pairs. + decodeASN1Repr :: a -> L.ByteString -> Either ASN1Error [ASN1Repr] + +-- | Describe an ASN.1 encoding, that transforms a list of ASN.1 values into a +-- lazy bytestring. +class ASN1Encoding a where + -- | Encode a list of ASN.1 values into a lazy bytestring. + encodeASN1 :: a -> [ASN1] -> L.ByteString + +-- | Decode a strict bytestring into a list of ASN.1 values. +decodeASN1' :: ASN1Decoding a => a -> B.ByteString -> Either ASN1Error [ASN1] +decodeASN1' encoding bs = decodeASN1 encoding $ L.fromChunks [bs] + +-- | Decode a strict bytestring into a list of 'ASN1Repr' pairs. +decodeASN1Repr' :: + ASN1DecodingRepr a + => a + -> B.ByteString + -> Either ASN1Error [ASN1Repr] +decodeASN1Repr' encoding bs = decodeASN1Repr encoding $ L.fromChunks [bs] + +-- | Encode a list of ASN.1 values into a strict bytestring. +encodeASN1' :: ASN1Encoding a => a -> [ASN1] -> B.ByteString +encodeASN1' encoding = B.concat . L.toChunks . encodeASN1 encoding diff --git a/src/Data/ASN1/Error.hs b/src/Data/ASN1/Error.hs new file mode 100644 --- /dev/null +++ b/src/Data/ASN1/Error.hs @@ -0,0 +1,40 @@ +{- | +Module : Data.ASN1.Error +License : BSD-style +Copyright : (c) 2010-2013 Vincent Hanquez +Stability : experimental +Portability : unknown +-} + +module Data.ASN1.Error + ( -- * Errors types + ASN1Error (..) + ) where + +import Control.Exception ( Exception ) + +-- | Possible errors during parsing operations. +data ASN1Error = + StreamUnexpectedEOC + -- ^ Unexpected EOC in the stream. + | StreamInfinitePrimitive + -- ^ Invalid primitive with infinite length in a stream. + | StreamConstructionWrongSize + -- ^ A construction goes over the size specified in the header. + | StreamUnexpectedSituation String + -- ^ An unexpected situation has come up parsing an ASN1 event stream. + | ParsingHeaderFail String + -- ^ Parsing an invalid header. + | ParsingPartial + -- ^ Parsing is not finished, there is construction unended. + | TypeNotImplemented String + -- ^ Decoding of a type that is not implemented. Contribution welcome. + | TypeDecodingFailed String + -- ^ Decoding of a knowed type failed. + | TypePrimitiveInvalid String + -- ^ Invalid primitive type. + | PolicyFailed String String + -- ^ Policy failed including the name of the policy and the reason. + deriving (Eq, Show) + +instance Exception ASN1Error diff --git a/src/Data/ASN1/Get.hs b/src/Data/ASN1/Get.hs new file mode 100644 --- /dev/null +++ b/src/Data/ASN1/Get.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE RankNTypes #-} + +{- | +Module : Data.ASN1.Get +License : BSD-style +Copyright : (c) 2010-2013 Vincent Hanquez +Stability : experimental +Portability : unknown + +Simple get module with really simple accessor for ASN.1. + +Original code is pulled from the Get module from cereal which is covered by: +Copyright : Lennart Kolmodin, Galois Inc. 2009 +License : BSD3-style (see LICENSE) + +The original code has been tailored and reduced to only cover the useful case +for ASN.1 and augmented by a position. +-} + +module Data.ASN1.Get + ( Result (..) + , Input + , Get + , runGetPos + , runGet + , getBytes + , getBytesCopy + , getWord8 + ) where + +import Control.Applicative ( Alternative (..) ) +import Control.Monad ( MonadPlus (..), ap ) +import qualified Data.ByteString as B +import Data.Maybe ( fromMaybe ) +import Data.Word ( Word64, Word8 ) + +-- | The result of a parse. +data Result r = + Fail String + -- ^ The parse failed. The 'String' is the message describing the error, if + -- any. + | Partial (B.ByteString -> Result r) + -- ^ Supply this continuation with more input so that the parser can resume. + -- To indicate that no more input is available, use an 'B.empty' string. + | Done r Position B.ByteString + -- ^ The parse succeeded. The 'B.ByteString' is the input that had not yet + -- been consumed (if any) when the parse succeeded. + +instance Show r => Show (Result r) where + show (Fail msg) = "Fail " ++ show msg + show (Partial _) = "Partial _" + show (Done r pos bs) = "Done " ++ show r ++ " " ++ show pos ++ " " ++ show bs + +instance Functor Result where + fmap _ (Fail msg) = Fail msg + fmap f (Partial k) = Partial (fmap f . k) + fmap f (Done r p bs) = Done (f r) p bs + +type Input = B.ByteString + +type Buffer = Maybe B.ByteString + +type Failure r = Input -> Buffer -> More -> Position -> String -> Result r + +type Success a r = Input -> Buffer -> More -> Position -> a -> Result r + +type Position = Word64 + +-- | Have we read all available input? +data More = + Complete + | Incomplete (Maybe Int) + deriving (Eq) + +-- | The Get monad is an Exception and State monad. +newtype Get a = Get + { unGet :: forall r. Input -> Buffer -> More -> Position -> Failure r -> Success a r -> Result r } + +append :: Buffer -> Buffer -> Buffer +append l r = B.append `fmap` l <*> r +{-# INLINE append #-} + +bufferBytes :: Buffer -> B.ByteString +bufferBytes = fromMaybe B.empty +{-# INLINE bufferBytes #-} + +instance Functor Get where + fmap p m = + Get $ \s0 b0 m0 p0 kf ks -> + let ks' s1 b1 m1 p1 a = ks s1 b1 m1 p1 (p a) + in unGet m s0 b0 m0 p0 kf ks' + +instance Applicative Get where + pure a = Get $ \ s0 b0 m0 p0 _ ks -> ks s0 b0 m0 p0 a + (<*>) = ap + +instance Alternative Get where + empty = failDesc "empty" + (<|>) = mplus + +-- Definition directly from Control.Monad.State.Strict +instance Monad Get where + return = pure + + m >>= g = Get $ \s0 b0 m0 p0 kf ks -> + 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' + +instance MonadFail Get where + fail = failDesc + +instance MonadPlus Get where + mzero = failDesc "mzero" + mplus a b = + Get $ \s0 b0 m0 p0 kf ks -> + let kf' _ b1 m1 p1 _ = unGet b (s0 `B.append` bufferBytes b1) + (b0 `append` b1) m1 p1 kf ks + in unGet a s0 (Just B.empty) m0 p0 kf' ks + +------------------------------------------------------------------------ + +put :: Position -> B.ByteString -> Get () +put pos s = Get (\_ b0 m p0 _ k -> k s b0 m (p0+pos) ()) +{-# INLINE put #-} + +finalK :: B.ByteString -> t -> t1 -> Position -> r -> Result r +finalK s _ _ p a = Done a p s + +failK :: Failure a +failK _ _ _ p s = Fail (show p ++ ":" ++ s) + +-- | Run the Get monad applies a 'get'-based parser on the input ByteString +runGetPos :: Position -> Get a -> B.ByteString -> Result a +runGetPos pos m str = unGet m str Nothing (Incomplete Nothing) pos failK finalK +{-# INLINE runGetPos #-} + +runGet :: Get a -> B.ByteString -> Result a +runGet = runGetPos 0 +{-# INLINE runGet #-} + +-- | If at least @n@ bytes of input are available, return the current +-- input, otherwise fail. +ensure :: Int -> Get B.ByteString +ensure n = n `seq` Get $ \ s0 b0 m0 p0 kf ks -> + if B.length s0 >= n + then ks s0 b0 m0 p0 s0 + else unGet (demandInput >> ensureRec n) s0 b0 m0 p0 kf ks +{-# INLINE ensure #-} + +-- | If at least @n@ bytes of input are available, return the current +-- input, otherwise fail. +ensureRec :: Int -> Get B.ByteString +ensureRec n = Get $ \s0 b0 m0 p0 kf ks -> + if B.length s0 >= n + then ks s0 b0 m0 p0 s0 + else unGet (demandInput >> ensureRec n) s0 b0 m0 p0 kf ks + +-- | Immediately demand more input via a 'Partial' continuation +-- result. +demandInput :: Get () +demandInput = Get $ \s0 b0 m0 p0 kf ks -> + case m0 of + Complete -> kf s0 b0 m0 p0 "too few bytes" + Incomplete mb -> Partial $ \s -> + if B.null s + then kf s0 b0 m0 p0 "too few bytes" + else let update l = l - B.length s + s1 = s0 `B.append` s + b1 = b0 `append` Just s + in ks s1 b1 (Incomplete (update `fmap` mb)) p0 () + +failDesc :: String -> Get a +failDesc err = + Get (\s0 b0 m0 p0 kf _ -> kf s0 b0 m0 p0 ("Failed reading: " ++ err)) + +------------------------------------------------------------------------ +-- Utility with ByteStrings + +-- | An efficient 'get' method for strict ByteStrings. Fails if fewer than @n@ +-- bytes are left in the input. This function creates a fresh copy of the +-- underlying bytes. +getBytesCopy :: Int -> Get B.ByteString +getBytesCopy n = do + bs <- getBytes n + pure $! B.copy bs + +------------------------------------------------------------------------ +-- Helpers + +-- | Pull @n@ bytes from the input, as a strict ByteString. +getBytes :: Int -> Get B.ByteString +getBytes n + | n <= 0 = pure B.empty + | otherwise = do + s <- ensure n + let (b1, b2) = B.splitAt n s + put (fromIntegral n) b2 + pure b1 + +getWord8 :: Get Word8 +getWord8 = do + s <- ensure 1 + case B.uncons s of + Nothing -> error "getWord8: ensure internal error" + Just (h, b2) -> put 1 b2 >> pure h diff --git a/src/Data/ASN1/Internal.hs b/src/Data/ASN1/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/ASN1/Internal.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE CPP #-} + +{- | +Module : Data.ASN1.Internal +License : BSD-style +Copyright : (c) 2010-2013 Vincent Hanquez +Stability : experimental +Portability : unknown +-} + +module Data.ASN1.Internal + ( uintOfBytes + , intOfBytes + , bytesOfUInt + , bytesOfInt + , putVarEncodingIntegral + ) where + +import Data.Bits + ( Bits, (.&.), (.|.), complement, shiftL, shiftR, testBit ) +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as B +import Data.List.NonEmpty ( NonEmpty (..), (<|) ) +import qualified Data.List.NonEmpty as NE +import Data.Word ( Word8 ) + +-- | Helper function while base < 4.15.0.0 (GHC < 9.0.1) is supported. +singletonNE :: a -> NonEmpty a +#if MIN_VERSION_base(4,15,0) +singletonNE = NE.singleton +#else +singletonNE a = a :| [] +#endif + +-- | Returns the number of bytes and the unsigned integer represented by the +-- bytes. +uintOfBytes :: ByteString -> (Int, Integer) +uintOfBytes b = + (B.length b, B.foldl (\acc n -> (acc `shiftL` 8) + fromIntegral n) 0 b) + +--bytesOfUInt i = B.unfoldr (\x -> if x == 0 then Nothing else Just (fromIntegral (x .&. 0xff), x `shiftR` 8)) i +bytesOfUInt :: Integer -> NonEmpty Word8 +bytesOfUInt x = NE.reverse (list x) + where + list i = if i <= 0xff + then singletonNE (fromIntegral i) + else (fromIntegral i .&. 0xff) <| list (i `shiftR` 8) + +-- | Returns the number of bytes in the list and the represented integer by a +-- two's completement list of bytes. +intOfBytes :: ByteString -> (Int, Integer) +intOfBytes b + | B.length b == 0 = (0, 0) + | otherwise = (len, if isNeg then -(maxIntLen - v + 1) else v) + where + (len, v) = uintOfBytes b + maxIntLen = 2 ^ (8 * len) - 1 + isNeg = testBit (B.head b) 7 + +-- | Convert an integer into a two's completemented list of bytes. +bytesOfInt :: Integer -> NonEmpty Word8 +bytesOfInt i + | i > 0 = if testBit (NE.head uints) 7 then 0 <| uints else uints + | i == 0 = singletonNE 0 + | otherwise = if testBit (NE.head nints) 7 then nints else 0xff <| nints + where + uints = bytesOfUInt (abs i) + nints = NE.reverse $ plusOne $ NE.reverse $ NE.map complement uints + plusOne (0xff :| []) = 0 :| [1] + plusOne (0xff :| (x : xs)) = 0 <| plusOne (x :| xs) + plusOne (x :| xs) = (x + 1) :| xs + +{- ASN1 often uses a particular kind of 7-bit encoding of integers like + in the case of long tags or encoding of integer component of OID's. + Use this function for such an encoding. Assumes a positive integer. + + Here is the description of the algorithm of the above encoding: + + 1. The integer is chunked up into 7-bit groups. Each of these 7bit + chunks are encoded as a single octet. + + 2. All the octets except the last one has its 8th bit set. +-} +putVarEncodingIntegral :: (Bits i, Integral i) => i -> ByteString +putVarEncodingIntegral i = B.reverse $ B.unfoldr genOctets (i, True) + where + genOctets (x, first) + | x > 0 = + let out = fromIntegral (x .&. 0x7F) .|. (if first then 0 else 0x80) + in Just (out, (shiftR x 7, False)) + | otherwise = Nothing diff --git a/src/Data/ASN1/Object.hs b/src/Data/ASN1/Object.hs new file mode 100644 --- /dev/null +++ b/src/Data/ASN1/Object.hs @@ -0,0 +1,13 @@ +{- | +Module : Data.ASN1.Object +License : BSD-style +Copyright : (c) 2010-2013 Vincent Hanquez +Stability : experimental +Portability : unknown +-} + +module Data.ASN1.Object {-# DEPRECATED "Use Data.ASN1.Types instead" #-} + ( ASN1Object (..) + ) where + +import Data.ASN1.Types ( ASN1Object (..) ) diff --git a/src/Data/ASN1/Prim.hs b/src/Data/ASN1/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Data/ASN1/Prim.hs @@ -0,0 +1,499 @@ +{-# LANGUAGE ViewPatterns #-} + +{- | +Module : Data.ASN1.Prim +License : BSD-style +Copyright : (c) 2010-2013 Vincent Hanquez +Stability : experimental +Portability : unknown + +Tools to read ASN1 primitive (e.g. boolean, int) +-} + +module Data.ASN1.Prim + ( -- * ASN.1 high-level algebraic types + ASN1 (..) + , ASN1ConstructionType (..) + + , encodeHeader + , encodePrimitiveHeader + , encodePrimitive + , decodePrimitive + , encodeConstructed + , encodeList + , encodeOne + , mkSmallestLength + + -- * Marshall an ASN.1 value from a val struct or a strict bytestring + , getBoolean + , getInteger + , getDouble + , getBitString + , getOctetString + , getNull + , getOID + , getTime + + -- * Marshall an ASN.1 value to a strict bytestring + , putTime + , putInteger + , putDouble + , putBitString + , putString + , putOID + ) where + +import Control.Arrow ( first ) +import Control.Monad ( unless ) +import Data.ASN1.BitArray ( BitArray (..), toBitArray ) +import Data.ASN1.Error ( ASN1Error (..) ) +import Data.ASN1.Internal + ( bytesOfInt, intOfBytes, putVarEncodingIntegral, uintOfBytes + ) +import Data.ASN1.Serialize ( putHeader ) +import Data.ASN1.Stream ( getConstructedEnd ) +import Data.ASN1.Types + ( ASN1 (..), ASN1CharacterString (..) + , ASN1ConstructionType (..), ASN1StringEncoding (..) + , ASN1TimeType (..) + ) +import Data.ASN1.Types.Lowlevel + ( ASN1Class (..), ASN1Event (..), ASN1Header (..) + , ASN1Length (..) + ) +import Data.Bits + ( (.&.), (.|.), clearBit, countTrailingZeros, shiftL, shiftR + , testBit + ) +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Unsafe as B +import Data.Char (ord, isDigit) +import Data.Hourglass + ( Date (..), DateTime (..), NanoSeconds (..) + , TimezoneOffset (..), timeParseE, timePrint, timezone_UTC + , todNSec + ) +import Data.List ( unfoldr ) +import qualified Data.List.NonEmpty as NE +import Data.Maybe ( isJust ) +import Data.Word ( Word64, Word8 ) +import Prelude hiding ( exp, exponent ) + +encodeHeader :: Bool -> ASN1Length -> ASN1 -> ASN1Header +encodeHeader pc len (Boolean _) = ASN1Header Universal 0x1 pc len +encodeHeader pc len (IntVal _) = ASN1Header Universal 0x2 pc len +encodeHeader pc len (BitString _) = ASN1Header Universal 0x3 pc len +encodeHeader pc len (OctetString _) = ASN1Header Universal 0x4 pc len +encodeHeader pc len Null = ASN1Header Universal 0x5 pc len +encodeHeader pc len (OID _) = ASN1Header Universal 0x6 pc len +encodeHeader pc len (Real _) = ASN1Header Universal 0x9 pc len +encodeHeader pc len (Enumerated _) = ASN1Header Universal 0xa pc len +encodeHeader pc len (ASN1String cs) = ASN1Header Universal (characterStringType $ characterEncoding cs) pc len + where + characterStringType UTF8 = 0xc + characterStringType Numeric = 0x12 + characterStringType Printable = 0x13 + characterStringType T61 = 0x14 + characterStringType VideoTex = 0x15 + characterStringType IA5 = 0x16 + characterStringType Graphic = 0x19 + characterStringType Visible = 0x1a + characterStringType General = 0x1b + characterStringType UTF32 = 0x1c + characterStringType Character = 0x1d + characterStringType BMP = 0x1e +encodeHeader pc len (ASN1Time TimeUTC _ _) = ASN1Header Universal 0x17 pc len +encodeHeader pc len (ASN1Time TimeGeneralized _ _) = ASN1Header Universal 0x18 pc len +encodeHeader pc len (Start Sequence) = ASN1Header Universal 0x10 pc len +encodeHeader pc len (Start Set) = ASN1Header Universal 0x11 pc len +encodeHeader pc len (Start (Container tc tag)) = ASN1Header tc tag pc len +encodeHeader pc len (Other tc tag _) = ASN1Header tc tag pc len +encodeHeader _ _ (End _) = error "this should not happen" + +encodePrimitiveHeader :: ASN1Length -> ASN1 -> ASN1Header +encodePrimitiveHeader = encodeHeader False + +encodePrimitiveData :: ASN1 -> ByteString +encodePrimitiveData (Boolean b) = B.singleton (if b then 0xff else 0) +encodePrimitiveData (IntVal i) = putInteger i +encodePrimitiveData (BitString bits) = putBitString bits +encodePrimitiveData (OctetString b) = putString b +encodePrimitiveData Null = B.empty +encodePrimitiveData (OID oidv) = putOID oidv +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 +encodePrimitiveData (Other _ _ b) = b +encodePrimitiveData o = error ("not a primitive " ++ show o) + +encodePrimitive :: ASN1 -> (Int, [ASN1Event]) +encodePrimitive a = + let b = encodePrimitiveData a + blen = B.length b + len = makeLength blen + hdr = encodePrimitiveHeader len a + in (B.length (putHeader hdr) + blen, [Header hdr, Primitive b]) + where + makeLength len + | len < 0x80 = LenShort len + | otherwise = LenLong (nbBytes len) len + nbBytes nb = if nb > 255 then 1 + nbBytes (nb `div` 256) else 1 + +encodeOne :: ASN1 -> (Int, [ASN1Event]) +encodeOne (Start _) = error "encode one cannot do start" +encodeOne t = encodePrimitive t + +encodeList :: [ASN1] -> (Int, [ASN1Event]) +encodeList [] = (0, []) +encodeList (End _:xs) = encodeList xs +encodeList (t@(Start _):xs) = + let (ys, zs) = getConstructedEnd 0 xs + (llen, lev) = encodeList zs + (len, ev) = encodeConstructed t ys + in (llen + len, ev ++ lev) + +encodeList (x:xs) = + let (llen, lev) = encodeList xs + (len, ev) = encodeOne x + in (llen + len, ev ++ lev) + +encodeConstructed :: ASN1 -> [ASN1] -> (Int, [ASN1Event]) +encodeConstructed c@(Start _) children = + (tlen, Header h : ConstructionBegin : events ++ [ConstructionEnd]) + where + (clen, events) = encodeList children + len = mkSmallestLength clen + h = encodeHeader True len c + tlen = B.length (putHeader h) + clen + +encodeConstructed _ _ = error "not a start node" + +mkSmallestLength :: Int -> ASN1Length +mkSmallestLength i + | i < 0x80 = LenShort i + | otherwise = LenLong (nbBytes i) i + where + nbBytes nb = if nb > 255 then 1 + nbBytes (nb `div` 256) else 1 + +type ASN1Ret = Either ASN1Error ASN1 + +decodePrimitive :: ASN1Header -> B.ByteString -> ASN1Ret +decodePrimitive (ASN1Header Universal 0x1 _ _) p = getBoolean False p +decodePrimitive (ASN1Header Universal 0x2 _ _) p = getInteger p +decodePrimitive (ASN1Header Universal 0x3 _ _) p = getBitString p +decodePrimitive (ASN1Header Universal 0x4 _ _) p = getOctetString p +decodePrimitive (ASN1Header Universal 0x5 _ _) p = getNull p +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 _ _) 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 +decodePrimitive (ASN1Header Universal 0xd _ _) _ = Left $ TypeNotImplemented "RELATIVE-OID" +decodePrimitive (ASN1Header Universal 0x10 _ _) _ = Left $ TypePrimitiveInvalid "sequence" +decodePrimitive (ASN1Header Universal 0x11 _ _) _ = Left $ TypePrimitiveInvalid "set" +decodePrimitive (ASN1Header Universal 0x12 _ _) p = getCharacterString Numeric p +decodePrimitive (ASN1Header Universal 0x13 _ _) p = getCharacterString Printable p +decodePrimitive (ASN1Header Universal 0x14 _ _) p = getCharacterString T61 p +decodePrimitive (ASN1Header Universal 0x15 _ _) p = getCharacterString VideoTex p +decodePrimitive (ASN1Header Universal 0x16 _ _) p = getCharacterString IA5 p +decodePrimitive (ASN1Header Universal 0x17 _ _) p = getTime TimeUTC p +decodePrimitive (ASN1Header Universal 0x18 _ _) p = getTime TimeGeneralized p +decodePrimitive (ASN1Header Universal 0x19 _ _) p = getCharacterString Graphic p +decodePrimitive (ASN1Header Universal 0x1a _ _) p = getCharacterString Visible p +decodePrimitive (ASN1Header Universal 0x1b _ _) p = getCharacterString General p +decodePrimitive (ASN1Header Universal 0x1c _ _) p = getCharacterString UTF32 p +decodePrimitive (ASN1Header Universal 0x1d _ _) p = getCharacterString Character p +decodePrimitive (ASN1Header Universal 0x1e _ _) p = getCharacterString BMP p +decodePrimitive (ASN1Header tc tag _ _) p = Right $ Other tc tag p + +getBoolean :: Bool -> ByteString -> Either ASN1Error ASN1 +getBoolean isDer s = + if B.length s == 1 + then case B.head s of + 0 -> Right (Boolean False) + 0xff -> Right (Boolean True) + _ -> if isDer + then Left $ PolicyFailed "DER" "boolean value not canonical" + else Right (Boolean True) + else + Left $ TypeDecodingFailed "boolean: length not within bound" + +-- | Parse a value bytestring and get the integer out of the two complement +-- encoded bytes. +getInteger :: ByteString -> Either ASN1Error ASN1 +{-# INLINE getInteger #-} +getInteger s = IntVal <$> getIntegerRaw "integer" s + +-- | Parse an enumerated value the same way that integer values are parsed. +getEnumerated :: ByteString -> Either ASN1Error ASN1 +{-# INLINE getEnumerated #-} +getEnumerated s = Enumerated <$> getIntegerRaw "enumerated" s + +-- | According to X.690 section 8.4 integer and enumerated values should be +-- encoded the same way. +getIntegerRaw :: String -> ByteString -> Either ASN1Error Integer +getIntegerRaw typestr s + | B.length s == 0 = Left . TypeDecodingFailed $ typestr ++ ": null encoding" + | B.length s == 1 = Right $ snd $ intOfBytes s + | otherwise = + if (v1 == 0xff && testBit v2 7) || (v1 == 0x0 && not ( testBit v2 7)) + then Left . TypeDecodingFailed $ typestr ++ ": not shortest encoding" + else Right $ snd $ intOfBytes s + where + 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) -> pure 2 + (False, True) -> pure 8 + (True, False) -> pure 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" + pure $ B.unsafeIndex s 1 + | otherwise -> pure $ l + 1 + +getBitString :: ByteString -> Either ASN1Error ASN1 +getBitString s = + let toSkip = B.head s in + let toSkip' = if toSkip >= 48 && toSkip <= 48 + 7 + then toSkip - fromIntegral ( ord '0') + else toSkip in + let xs = B.tail s in + if toSkip' >= 0 && toSkip' <= 7 + then Right $ BitString $ toBitArray xs (fromIntegral toSkip') + else Left $ TypeDecodingFailed + ( "bitstring: skip number not within bound " + ++ show toSkip' + ++ " " + ++ show s + ) + +getCharacterString :: ASN1StringEncoding -> ByteString -> Either ASN1Error ASN1 +getCharacterString encoding bs = Right $ ASN1String (ASN1CharacterString encoding bs) + +getOctetString :: ByteString -> Either ASN1Error ASN1 +getOctetString = Right . OctetString + +getNull :: ByteString -> Either ASN1Error ASN1 +getNull s + | B.length s == 0 = Right Null + | otherwise = Left $ TypeDecodingFailed "Null: data length not within bound" + +-- | Return an OID. +getOID :: ByteString -> Either ASN1Error ASN1 +getOID s = case B.unpack s of + [] -> Left $ TypeDecodingFailed "OID: no data" + (x : xs) -> Right $ OID + ( fromIntegral (x `div` 40) + : fromIntegral (x `mod` 40) + : groupOID xs + ) + where + groupOID :: [Word8] -> [Integer] + groupOID = + map (foldl (\acc n -> (acc `shiftL` 7) + fromIntegral n) 0) . groupSubOID + + groupSubOIDHelper [] = Nothing + groupSubOIDHelper l = Just $ spanSubOIDbound l + + groupSubOID :: [Word8] -> [[Word8]] + groupSubOID = unfoldr groupSubOIDHelper + + spanSubOIDbound [] = ([], []) + spanSubOIDbound (a:as) = if testBit a 7 + then (clearBit a 7 : ys, zs) + else ([a], as) + where + (ys, zs) = spanSubOIDbound as + +getTime :: ASN1TimeType -> ByteString -> Either ASN1Error ASN1 +getTime timeType bs + | hasNonASCII bs = decodingError "contains non ASCII characters" + | otherwise = + case timeParseE format (BC.unpack bs) of -- BC.unpack is safe as we check ASCIIness first + Left _ -> + case timeParseE formatNoSeconds (BC.unpack bs) of + Left _ -> decodingError ("cannot convert string " ++ BC.unpack bs) + Right r -> parseRemaining r + Right r -> parseRemaining r + where + parseRemaining r = + case parseTimezone $ parseMs $ first adjustUTC r of + Left err -> decodingError err + Right (dt', tz) -> Right $ ASN1Time timeType dt' tz + + adjustUTC dt@(DateTime (Date y m d) tod) + | timeType == TimeGeneralized = dt + | y > 2050 = DateTime (Date (y - 100) m d) tod + | otherwise = dt + formatNoSeconds = init format + format + | timeType == TimeGeneralized = 'Y':'Y':baseFormat + | otherwise = baseFormat + baseFormat = "YYMMDDHMIS" + + parseMs (dt, s) = + case s of + '.':s' -> let (ns, r) = first toNano $ spanToLength 3 isDigit s' + in (dt { dtTime = (dtTime dt) { todNSec = ns } }, r) + _ -> (dt, s) + parseTimezone (dt, s) = + case s of + '+':s' -> Right (dt, parseTimezoneFormat id s') + '-':s' -> Right (dt, parseTimezoneFormat ((-1) *) s') + ['Z'] -> Right (dt, Just timezone_UTC) + "" -> Right (dt, Nothing) + _ -> Left ("unknown timezone format: " ++ s) + + parseTimezoneFormat transform s + | length s == 4 = Just $ toTz $ toInt $ fst $ spanToLength 4 isDigit s + | otherwise = Nothing + where + toTz z = let (h,m) = z `divMod` 100 + in TimezoneOffset $ transform (h * 60 + m) + + toNano :: String -> NanoSeconds + toNano l = fromIntegral (toInt l * order * 1000000) + where + len = length l + order = case len of + 1 -> 100 + 2 -> 10 + 3 -> 1 + _ -> 1 + + spanToLength :: Int -> (Char -> Bool) -> String -> (String, String) + spanToLength len p = loop 0 + where + loop i z + | i >= len = ([], z) + | otherwise = case z of + [] -> ([], []) + x:xs -> if p x + then let (r1, r2) = loop (i + 1) xs + in (x:r1, r2) + else ([], z) + + toInt :: String -> Int + toInt = foldl (\acc w -> acc * 10 + (ord w - ord '0')) 0 + + decodingError reason = Left $ TypeDecodingFailed + ("time format invalid for " ++ show timeType ++ " : " ++ reason) + hasNonASCII = isJust . B.find (> 0x7f) + +-- FIXME need msec printed +putTime :: ASN1TimeType -> DateTime -> Maybe TimezoneOffset -> ByteString +putTime ty dt mtz = BC.pack etime + where + etime + | ty == TimeUTC = timePrint "YYMMDDHMIS" dt ++ tzStr + | otherwise = timePrint "YYYYMMDDHMIS" dt ++ msecStr ++ tzStr + msecStr = [] + tzStr = case mtz of + Nothing -> "" + Just tz + | tz == timezone_UTC -> "Z" + | otherwise -> show tz + +putInteger :: Integer -> ByteString +putInteger i = B.pack $ NE.toList $ bytesOfInt i + +putBitString :: BitArray -> ByteString +putBitString (BitArray n bits) = + B.concat [B.singleton (fromIntegral i), bits] + where + i = (8 - (n `mod` 8)) .&. 0x7 + +putString :: ByteString -> ByteString +putString l = l + +{- no enforce check that oid1 is between [0..2] and oid2 is between [0..39] -} +putOID :: [Integer] -> ByteString +putOID oids = case oids of + (oid1:oid2:suboids) -> + let eoidclass = fromIntegral (oid1 * 40 + oid2) + subeoids = B.concat $ map encode suboids + in B.cons eoidclass subeoids + _ -> error ("invalid OID format " ++ show oids) + 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 + +bINARY_POSITIVE_NUMBER_ID, bINARY_NEGATIVE_NUMBER_ID :: Word8 +bINARY_POSITIVE_NUMBER_ID = 0x80 +bINARY_NEGATIVE_NUMBER_ID = 0xc0 diff --git a/src/Data/ASN1/Serialize.hs b/src/Data/ASN1/Serialize.hs new file mode 100644 --- /dev/null +++ b/src/Data/ASN1/Serialize.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE CPP #-} + +{- | +Module : Data.ASN1.Serialize +License : BSD-style +Copyright : (c) 2010-2013 Vincent Hanquez +Stability : experimental +Portability : unknown +-} + +module Data.ASN1.Serialize + ( getHeader + , putHeader + ) where + +import Control.Monad ( when ) +import Data.ASN1.Get ( Get, getBytes, getWord8 ) +import Data.ASN1.Internal ( bytesOfUInt, putVarEncodingIntegral ) +import Data.ASN1.Types.Lowlevel + ( ASN1Class, ASN1Header (..), ASN1Length (..), ASN1Tag ) +import Data.Bits ( (.&.), (.|.), clearBit, shiftL, shiftR, testBit ) +import qualified Data.ByteString as B +import Data.List.NonEmpty ( NonEmpty (..), (<|) ) +import qualified Data.List.NonEmpty as NE +import Data.Word ( Word8 ) + +-- | Helper function while base < 4.15.0.0 (GHC < 9.0.1) is supported. +singletonNE :: a -> NonEmpty a +#if MIN_VERSION_base(4,15,0) +singletonNE = NE.singleton +#else +singletonNE a = a :| [] +#endif + +-- | Parse an ASN1 header. +getHeader :: Get ASN1Header +getHeader = do + (cl, pc, t1) <- parseFirstWord <$> getWord8 + tag <- if t1 == 0x1f then getTagLong else pure t1 + ASN1Header cl tag pc <$> getLength + +-- | Parse the first word of an header. +parseFirstWord :: Word8 -> (ASN1Class, Bool, ASN1Tag) +parseFirstWord w = (cl, pc, t1) + where + cl = toEnum $ fromIntegral (w `shiftR` 6) + pc = testBit w 5 + t1 = fromIntegral (w .&. 0x1f) + +{- when the first tag is 0x1f, the tag is in long form, where + - we get bytes while the 7th bit is set. -} +getTagLong :: Get ASN1Tag +getTagLong = do + t <- fromIntegral <$> getWord8 + when (t == 0x80) $ fail "non canonical encoding of long tag" + if testBit t 7 + then loop (clearBit t 7) + else pure t + where + loop n = do + t <- fromIntegral <$> getWord8 + if testBit t 7 + then loop (n `shiftL` 7 + clearBit t 7) + else pure (n `shiftL` 7 + t) + +{- get the asn1 length which is either short form if 7th bit is not set, + - indefinite form is the 7 bit is set and every other bits clear, + - or long form otherwise, where the next bytes will represent the length + -} +getLength :: Get ASN1Length +getLength = do + l1 <- fromIntegral <$> getWord8 + if testBit l1 7 + then case clearBit l1 7 of + 0 -> pure LenIndefinite + len -> do + lw <- getBytes len + pure (LenLong len $ uintbs lw) + else + pure (LenShort l1) + where + {- uintbs return the unsigned int represented by the bytes -} + uintbs = B.foldl (\acc n -> (acc `shiftL` 8) + fromIntegral n) 0 + +-- | putIdentifier encode an ASN1 Identifier into a marshalled value. +putHeader :: ASN1Header -> B.ByteString +putHeader (ASN1Header cl tag pc len) = B.concat + [ B.singleton word1 + , if tag < 0x1f then B.empty else tagBS + , lenBS + ] + where + cli = shiftL (fromIntegral $ fromEnum cl) 6 + pcval = shiftL (if pc then 0x1 else 0x0) 5 + tag0 = if tag < 0x1f then fromIntegral tag else 0x1f + word1 = cli .|. pcval .|. tag0 + lenBS = B.pack $ NE.toList $ putLength len + tagBS = putVarEncodingIntegral tag + +-- | putLength encode a length into a ASN1 length. See 'getLength' for the +-- encoding rules. +putLength :: ASN1Length -> NonEmpty Word8 +putLength (LenShort i) + | i < 0 || i > 0x7f = error "putLength: short length is not between 0x0 and 0x80" + | otherwise = singletonNE (fromIntegral i) +putLength (LenLong _ i) + | i < 0 = error "putLength: long length is negative" + | otherwise = lenbytes <| lw + where + lw = bytesOfUInt $ fromIntegral i + lenbytes = fromIntegral (length lw .|. 0x80) +putLength LenIndefinite = singletonNE 0x80 diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,222 +1,269 @@ -import Test.Tasty.QuickCheck -import Test.Tasty - -import Control.Applicative -import Data.ASN1.Get (runGet, Result(..)) -import Data.ASN1.BitArray -import Data.ASN1.Prim -import Data.ASN1.Serialize -import Data.ASN1.BinaryEncoding.Parse -import Data.ASN1.BinaryEncoding.Writer -import Data.ASN1.BinaryEncoding -import Data.ASN1.Encoding -import Data.ASN1.Types -import Data.ASN1.Types.Lowlevel - -import Data.Hourglass +{-# OPTIONS_GHC -Wno-orphans #-} +import Control.Monad ( liftM4, replicateM ) +import Data.ASN1.BinaryEncoding ( DER (..) ) +import Data.ASN1.BinaryEncoding.Parse ( parseLBS ) +import Data.ASN1.BinaryEncoding.Writer ( toLazyByteString ) +import Data.ASN1.BitArray ( BitArray, toBitArray ) +import Data.ASN1.Encoding ( ASN1Decoding (..), ASN1Encoding (..) ) +import Data.ASN1.Get ( Result (..), runGet ) +import Data.ASN1.Prim ( mkSmallestLength ) +import Data.ASN1.Serialize ( getHeader, putHeader ) +import Data.ASN1.Types + ( ASN1 (..), ASN1CharacterString (..) + , ASN1ConstructionType (..), ASN1StringEncoding (..) + , ASN1TimeType (..), OID, asn1CharacterString + ) +import Data.ASN1.Types.Lowlevel + ( ASN1Class (..), ASN1Event (..), ASN1Header (..) + , ASN1Length (..), ASN1Tag + ) import qualified Data.ByteString as B - -import Control.Monad +import Data.Hourglass + ( Date (..), DateTime (..), Elapsed (..), Hours (..) + , Minutes (..), Month (..), Seconds (..), TimeOfDay (..) + , TimezoneOffset (..), timeConvert, timezone_UTC + ) +import Test.Tasty ( TestTree, defaultMain, testGroup ) +import Test.Tasty.QuickCheck + ( Arbitrary (..), Gen, choose, elements, listOf1, oneof + , resize, suchThat, testProperty + ) instance Arbitrary ASN1Class where - arbitrary = elements [ Universal, Application, Context, Private ] + arbitrary = elements [ Universal, Application, Context, Private ] instance Arbitrary ASN1Length where - arbitrary = do - c <- choose (0,2) :: Gen Int - case c of - 0 -> liftM LenShort (choose (0,0x79)) - 1 -> do - nb <- choose (0x80,0x1000) - return $ mkSmallestLength nb - _ -> return LenIndefinite - where - nbBytes nb = if nb > 255 then 1 + nbBytes (nb `div` 256) else 1 + arbitrary = do + c <- choose (0, 2) :: Gen Int + case c of + 0 -> fmap LenShort (choose (0, 0x79)) + 1 -> do + nb <- choose (0x80, 0x1000) + pure $ mkSmallestLength nb + _ -> pure LenIndefinite arbitraryDefiniteLength :: Gen ASN1Length -arbitraryDefiniteLength = arbitrary `suchThat` (\l -> l /= LenIndefinite) +arbitraryDefiniteLength = arbitrary `suchThat` (/= LenIndefinite) arbitraryTag :: Gen ASN1Tag -arbitraryTag = choose(1,10000) +arbitraryTag = choose (1, 10000) instance Arbitrary ASN1Header where - arbitrary = liftM4 ASN1Header arbitrary arbitraryTag arbitrary arbitrary + arbitrary = liftM4 ASN1Header arbitrary arbitraryTag arbitrary arbitrary arbitraryEvents :: Gen ASN1Events arbitraryEvents = do - hdr@(ASN1Header _ _ _ len) <- liftM4 ASN1Header arbitrary arbitraryTag (return False) arbitraryDefiniteLength - let blen = case len of - LenLong _ x -> x - LenShort x -> x - _ -> 0 - pr <- liftM Primitive (arbitraryBSsized blen) - return (ASN1Events [Header hdr, pr]) + hdr@(ASN1Header _ _ _ len) <- + liftM4 ASN1Header arbitrary arbitraryTag (pure False) arbitraryDefiniteLength + let blen = case len of + LenLong _ x -> x + LenShort x -> x + _ -> 0 + pr <- fmap Primitive (arbitraryBSsized blen) + pure (ASN1Events [Header hdr, pr]) newtype ASN1Events = ASN1Events [ASN1Event] instance Show ASN1Events where - show (ASN1Events x) = show x + show (ASN1Events x) = show x instance Arbitrary ASN1Events where - arbitrary = arbitraryEvents - + arbitrary = arbitraryEvents arbitraryOID :: Gen OID arbitraryOID = do - i1 <- choose (0,2) :: Gen Integer - i2 <- choose (0,39) :: Gen Integer - ran <- choose (0,30) :: Gen Int - l <- replicateM ran (suchThat arbitrary (\i -> i > 0)) - return $ (i1:i2:l) + i1 <- choose (0, 2) :: Gen Integer + i2 <- choose (0, 39) :: Gen Integer + ran <- choose (0, 30) :: Gen Int + l <- replicateM ran (suchThat arbitrary (> 0)) + pure (i1:i2:l) arbitraryBSsized :: Int -> Gen B.ByteString arbitraryBSsized len = do - ws <- replicateM len (choose (0, 255) :: Gen Int) - return $ B.pack $ map fromIntegral ws + ws <- replicateM len (choose (0, 255) :: Gen Int) + pure $ B.pack $ map fromIntegral ws instance Arbitrary B.ByteString where - arbitrary = do - len <- choose (0, 529) :: Gen Int - arbitraryBSsized len + arbitrary = do + len <- choose (0, 529) :: Gen Int + arbitraryBSsized len instance Arbitrary BitArray where - arbitrary = do - bs <- arbitrary - w <- choose (0,7) :: Gen Int - return $ toBitArray bs w + arbitrary = do + bs <- arbitrary + w <- choose (0, 7) :: Gen Int + pure $ toBitArray bs w instance Arbitrary Date where - arbitrary = do - y <- choose (1951, 2050) - m <- elements [ January .. December] - d <- choose (1, 30) - return $ normalizeDate $ Date y m d + arbitrary = do + y <- choose (1951, 2050) + m <- elements [ January .. December] + d <- choose (1, 30) + pure $ normalizeDate $ Date y m d normalizeDate :: Date -> Date normalizeDate origDate - | y < 1951 = normalizeDate (Date (y + 50) m d) - | otherwise = normalizedDate - where - normalizedDate@(Date y m d) = timeConvert (timeConvert origDate :: Elapsed) + | y < 1951 = normalizeDate (Date (y + 50) m d) + | otherwise = normalizedDate + where + normalizedDate@(Date y m d) = timeConvert (timeConvert origDate :: Elapsed) instance Arbitrary TimeOfDay where - arbitrary = do - h <- choose (0, 23) - mi <- choose (0, 59) - se <- choose (0, 59) - nsec <- return 0 - return $ TimeOfDay (Hours h) (Minutes mi) (Seconds se) nsec + arbitrary = do + h <- choose (0, 23) + mi <- choose (0, 59) + se <- choose (0, 59) + let nsec = 0 + pure $ TimeOfDay (Hours h) (Minutes mi) (Seconds se) nsec instance Arbitrary DateTime where - arbitrary = DateTime <$> arbitrary <*> arbitrary + arbitrary = DateTime <$> arbitrary <*> arbitrary instance Arbitrary TimezoneOffset where - arbitrary = elements [ timezone_UTC, TimezoneOffset 60, TimezoneOffset 120, TimezoneOffset (-360) ] + arbitrary = elements + [ timezone_UTC + , TimezoneOffset 60 + , TimezoneOffset 120 + , TimezoneOffset (-360) + ] instance Arbitrary Elapsed where - arbitrary = Elapsed . Seconds <$> arbitrary + arbitrary = Elapsed . Seconds <$> arbitrary instance Arbitrary ASN1TimeType where - arbitrary = elements [TimeUTC, TimeGeneralized] + arbitrary = elements [TimeUTC, TimeGeneralized] instance Arbitrary ASN1StringEncoding where - arbitrary = elements [UTF8, Numeric, Printable, T61, VideoTex, IA5, Graphic, Visible, General, UTF32, BMP] + arbitrary = elements + [ UTF8 + , Numeric + , Printable + , T61 + , VideoTex + , IA5 + , Graphic + , Visible + , General + , UTF32 + , BMP + ] +arbitraryPrintString :: ASN1StringEncoding -> Gen ASN1CharacterString arbitraryPrintString encoding = do - let printableString = (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ " ()+,-./:=?") - asn1CharacterString encoding <$> replicateM 21 (elements printableString) + let printableString = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ " ()+,-./:=?" + asn1CharacterString encoding <$> replicateM 21 (elements printableString) -arbitraryBS encoding = ASN1CharacterString encoding . B.pack <$> replicateM 7 (choose (0,0xff)) +arbitraryBS :: ASN1StringEncoding -> Gen ASN1CharacterString +arbitraryBS encoding = + ASN1CharacterString encoding . B.pack <$> replicateM 7 (choose (0, 0xff)) -arbitraryIA5String = asn1CharacterString IA5 <$> replicateM 21 (choose (toEnum 0,toEnum 127)) +arbitraryIA5String :: Gen ASN1CharacterString +arbitraryIA5String = + asn1CharacterString IA5 <$> replicateM 21 (choose (toEnum 0, toEnum 127)) arbitraryUCS2 :: Gen ASN1CharacterString -arbitraryUCS2 = asn1CharacterString BMP <$> replicateM 12 (choose (toEnum 0,toEnum 0xffff)) +arbitraryUCS2 = + asn1CharacterString BMP <$> replicateM 12 (choose (toEnum 0, toEnum 0xffff)) arbitraryUnicode :: ASN1StringEncoding -> Gen ASN1CharacterString -arbitraryUnicode e = asn1CharacterString e <$> replicateM 35 (choose (toEnum 0,toEnum 0x10ffff)) +arbitraryUnicode e = + asn1CharacterString e <$> replicateM 35 (choose (toEnum 0, toEnum 0x10ffff)) instance Arbitrary ASN1CharacterString where - arbitrary = oneof - [ arbitraryUnicode UTF8 - , arbitraryUnicode UTF32 - , arbitraryUCS2 - , arbitraryPrintString Numeric - , arbitraryPrintString Printable - , arbitraryBS T61 - , arbitraryBS VideoTex - , arbitraryIA5String - , arbitraryPrintString Graphic - , arbitraryPrintString Visible - , arbitraryPrintString General - ] + arbitrary = oneof + [ arbitraryUnicode UTF8 + , arbitraryUnicode UTF32 + , arbitraryUCS2 + , arbitraryPrintString Numeric + , arbitraryPrintString Printable + , arbitraryBS T61 + , arbitraryBS VideoTex + , arbitraryIA5String + , arbitraryPrintString Graphic + , arbitraryPrintString Visible + , arbitraryPrintString General + ] instance Arbitrary ASN1 where - arbitrary = oneof - [ liftM Boolean arbitrary - , liftM IntVal arbitrary - , liftM BitString arbitrary - , liftM OctetString arbitrary - , return Null - , liftM OID arbitraryOID - , liftM Real arbitrary - -- , return Enumerated - , ASN1String <$> arbitrary - , ASN1Time <$> arbitrary <*> arbitrary <*> arbitrary - ] + arbitrary = oneof + [ fmap Boolean arbitrary + , fmap IntVal arbitrary + , fmap BitString arbitrary + , fmap OctetString arbitrary + , pure Null + , fmap OID arbitraryOID + , fmap Real arbitrary + -- , pure Enumerated + , ASN1String <$> arbitrary + , ASN1Time <$> arbitrary <*> arbitrary <*> arbitrary + ] newtype ASN1s = ASN1s [ASN1] instance Show ASN1s where - show (ASN1s x) = show x + show (ASN1s x) = show x instance Arbitrary ASN1s where - arbitrary = do - x <- choose (0,5) :: Gen Int - z <- case x of - 4 -> makeList Sequence - 3 -> makeList Set - _ -> resize 2 $ listOf1 arbitrary - return $ ASN1s z - where - makeList str = do - (ASN1s l) <- arbitrary - return ([Start str] ++ l ++ [End str]) + arbitrary = do + x <- choose (0,5) :: Gen Int + z <- case x of + 4 -> makeList Sequence + 3 -> makeList Set + _ -> resize 2 $ listOf1 arbitrary + pure $ ASN1s z + where + makeList str = do + (ASN1s l) <- arbitrary + pure ([Start str] ++ l ++ [End str]) prop_header_marshalling_id :: ASN1Header -> Bool -prop_header_marshalling_id v = (ofDone $ runGet getHeader $ putHeader v) == Right v - where ofDone (Done r _ _) = Right r - ofDone _ = Left "not done" +prop_header_marshalling_id v = + ofDone ( runGet getHeader $ putHeader v) == Right v + where + ofDone (Done r _ _) = Right r + ofDone _ = Left "not done" prop_event_marshalling_id :: ASN1Events -> Bool -prop_event_marshalling_id (ASN1Events e) = (parseLBS $ toLazyByteString e) == Right e +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_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_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 +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 :: TestTree 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 - ] + [ 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 :: IO () main = defaultMain $ testGroup "asn1-encoding" [marshallingTests]